clucumber 0.1.1 → 0.2.0

data/lib/clucumber/vendor/lift/dev/prototypes.lisp

@@ -0,0 +1,282 @@
+;;;-*- Mode: Lisp; Package: LIFT -*-
+
+(in-package #:lift)
+
+(pushnew :cases *deftest-clauses*)
+
+(add-code-block
+ :cases 2 :methods
+ (lambda () (def :cases)) 
+ '((setf (def :cases) (cleanup-parsed-parameter value)))
+ 'build-cases-method)
+
+(defun build-cases-method ()
+  (when (atom (car (def :cases)))
+    (setf (def :cases) (list (def :cases))))
+  ;(spy (def :cases))
+  (let ((cases (standardize-cases-form (def :cases))))
+    `(defmethod initialize-prototypes :after ((test ,(def :testsuite-name)))
+       (setf (prototypes test) 
+             (rest (process-cases-form 
+		    ,(first cases) 
+		    ,@(mapcar (lambda (a) `',a) (rest cases))))))))
+
+;; goal is spec := (<tag> <spec>+)
+;;         spec := (<var value>+)
+(defun standardize-cases-form (cases)
+  (cond ((atom (first cases))
+         (cond ((valid-tag-p (first cases)) 
+                `(,(first cases) ,@(mapcar #'standardize-cases-form (rest cases))))
+               (t
+                cases)))
+        ((and (length-1-list-p cases)
+              (consp (first cases))
+              (valid-tag-p (first (first cases))))
+         (standardize-cases-form (first cases)))
+        (t
+         `(:cross ,@(mapcar #'standardize-cases-form cases)))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun check-subcases (cases)
+  (cond ((not (valid-tag-p (first cases)))
+         `(,(default-cases-tag) ,@(mapcar #'standardize-cases-form cases)))
+        (t
+         (mapcar #'standardize-cases-form cases))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun default-cases-tag ()
+  :cross)
+
+;;; ---------------------------------------------------------------------------
+
+(defun valid-tag-p (tag)
+  (member tag '(:map :cross)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod process-cases-form :around ((type t) &rest forms)
+  (apply #'call-next-method type (if (atom (car forms))
+                                   (list forms) forms)))
+
+;;; ---------------------------------------------------------------------------
+  
+(defmethod process-cases-form ((type t) &rest forms)
+  (cond ((atom (first type))
+         (apply #'process-cases-form (first type) (append (rest type) forms)))
+        (t (apply #'process-cases-form :cross (append type forms)))))
+
+#+Old
+(defmethod process-cases-form ((type (eql :map)) &rest forms)
+  (let ((vars (mapcar #'car forms))
+        (values (mapcar #'rest forms)))
+    `(let (,@(mapcar (lambda (var value) `(,var ,@value))
+                     vars values))
+       (mapcar (lambda ,vars
+                 (list ,@(mapcar (lambda (var) `(cons ',var ,var)) vars)))
+               ,@vars))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod process-cases-form ((type (eql :map)) &rest forms)
+  (let ((vars (ensure-list (flatten (vars-from-assignment forms))))
+        (values (values-from-assignment forms)))
+    `(:b ,@(apply #'mapcar
+                  (lambda (&rest args)
+                    (mapcar (lambda (var value)
+                              (cons var value))
+                            vars args))
+                  values))))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod process-cases-form ((type (eql :cross)) &rest forms)
+  (let ((vars (ensure-list (flatten (vars-from-assignment forms))))
+        (values (values-from-assignment forms))
+        (result nil))
+    (iterate-over-indexes
+     (mapcar #'length values)
+     (lambda (indexes)
+       (let ((datum nil))
+         (mapcar (lambda (name var index)
+                   (push (cons name (elt var index)) datum))
+                 vars
+                 values
+                 indexes)
+         (push (nreverse datum) result))) 
+     :right)
+    `(:b ,@(nreverse result))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun vars-from-assignment (assignment)
+  (cond ((is-binding-p assignment)
+         (mapcar #'car (second assignment)))
+        ((metatilities:dotted-pair-p assignment)
+         (car assignment))
+        ((atom (car assignment))
+         (car assignment))
+        ((length-1-list-p assignment)
+         (vars-from-assignment (first assignment)))
+        (t (loop for assignment in assignment collect
+                 (vars-from-assignment assignment)))))
+         
+;;; ---------------------------------------------------------------------------
+
+(defun values-from-assignment (assignment)
+  (cond ((is-binding-p assignment)
+         (apply #'mapcar (lambda (&rest bindings)
+                   (mapcar (lambda (binding)
+                             (cdr binding))
+                           bindings))
+                 (rest assignment)))
+        ((dotted-pair-p assignment)
+         (cdr assignment))
+        ((atom (car assignment))
+         (list (eval (first (rest assignment)))))
+        (t 
+         (loop for assignment in assignment nconc
+                 (ensure-list (values-from-assignment assignment))))))
+
+;;; ---------------------------------------------------------------------------
+
+(defun is-binding-p (assignment)
+  (eq (first assignment) :b))
+
+
+#|
+
+
+(export '(map-prototypes-of
+          prototypes-of
+          prototype-of
+          prototype-exists-p))
+
+;;; ---------------------------------------------------------------------------
+;;; API
+;;; ---------------------------------------------------------------------------
+
+(defgeneric map-prototypes-of (fn thing)
+  (:documentation ""))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric prototypes-of (thing)
+  (:documentation ""))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric prototype-of (thing)
+  (:documentation ""))
+
+;;; ---------------------------------------------------------------------------
+
+(defgeneric prototype-exists-p (thing)
+  (:documentation ""))
+
+;;; ---------------------------------------------------------------------------
+;;; implementation
+;;; ---------------------------------------------------------------------------
+
+(defmethod map-prototypes-of :around (fn thing)
+  (declare (ignore fn))
+  (when (prototype-exists-p thing)
+    (call-next-method)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod map-prototypes-of (fn (thing standard-class))
+  (map-subclass-prototypes fn thing))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod map-prototypes-of (fn (thing built-in-class))
+  (map-subclass-prototypes fn thing))
+
+;;; ---------------------------------------------------------------------------
+
+(defun map-subclass-prototypes (fn thing)
+  (mopu:map-subclasses thing
+                       (lambda (subclass)
+                         (when (prototype-exists-p subclass)
+                           (funcall fn (prototype-of subclass)))))
+  (values))
+   
+;;; ---------------------------------------------------------------------------
+
+(defmethod prototypes-of (thing)
+  (containers:collect-using 'map-prototypes-of nil thing))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod prototype-exists-p (thing)
+  ;; the expensive way to see if a prototype exists is to try and make one
+  ;; and see if it works...
+  (handler-case 
+    (let ((creator-method (compute-applicable-methods #'prototype-of (list thing))))
+      (when creator-method
+        (let ((x (prototype-of thing)))
+          (declare (optimize (safety 3) (debug 3) (speed 0) (space 0)))
+          x
+          (values t))))
+    (error (c) (inspect c) nil)))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod prototype-of ((thing standard-class))
+  (allocate-instance thing))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod prototype-of ((thing (eql 'fixnum)))
+  (variates:integer-random variates:*random-generator* -10 10))
+
+
+|#
+
+
+
+(defmethod more-prototypes-p :before ((testsuite test-mixin))
+  (setf (current-step testsuite) 'more-prototypes-p))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod initialize-prototypes :before ((testsuite test-mixin))
+  (setf (current-step testsuite) 'initialize-prototypes))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod next-prototype :before ((testsuite test-mixin))
+  (setf (current-step testsuite) 'next-prototype))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod testsuite-teardown :before ((testsuite test-mixin))
+  (setf (current-step testsuite) 'testsuite-teardown))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod start-test :before
+    ((result test-result) (testsuite test-mixin) method-name)
+  (declare (ignore method-name)) 
+  (setf (current-step testsuite) 'start-test))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod end-test :before
+    ((result test-result) (testsuite test-mixin) method-name)
+  (declare (ignore method-name))
+  (setf (current-step testsuite) 'end-test))
+
+;;; ---------------------------------------------------------------------------
+
+(defmethod setup-test :before ((testsuite test-mixin))
+  (setf (current-step testsuite) 'setup-test))
+
+;;; ---------------------------------------------------------------------------
+
+#+Ignore
+(defmethod teardown-test :before ((testsuite test-mixin))
+  (setf (current-step testsuite) 'teardown-test))
+

data/lib/clucumber/vendor/lift/dev/random-testing.lisp

@@ -0,0 +1,124 @@
+(in-package #:lift)
+
+;; we redefine the class and possibly method each time, ick.
+
+(define-condition ensure-random-cases-failure (test-condition)
+  ((total :initarg :total :initform 0)
+   (problems :initarg :problems :initform nil))
+  (:report (lambda (condition stream)
+	     (format stream "Ensure-random-cases: ~d out of ~d failed. Failing values are: ~{~%  ~s~^, ~}" 
+		     (length (slot-value condition 'problems))
+		     (slot-value condition 'total)
+		     (slot-value condition 'problems)))))
+
+(defgeneric random-instance-for-suite (thing suite))
+
+(defmacro defrandom-instance (instance-type suite &body body)
+  `(progn
+     (defclass ,instance-type () ())
+     (defvar ,(intern (format nil "+~a+" instance-type) :lift)
+       (make-instance ',instance-type))
+     (defmethod random-instance-for-suite 
+	 ((thing ,instance-type) (suite ,(if suite suite t)))
+       ,@body)))
+
+(defmacro ensure-random-cases (count (&rest vars-and-types)
+			     &body body)
+  (let ((problems (gensym)))
+    (flet ((intern-type (type)
+	     (intern (format nil "+~a+" type) :lift)))
+      `(let ((,problems nil))
+	 (loop repeat ,count do
+	      (let (,@(mapcar 
+		       (lambda (var-and-type)
+			 `(,(first var-and-type) 
+			    (random-instance-for-suite
+			     ,(intern-type (second var-and-type))
+			     *current-test*)))
+		       vars-and-types))
+		(restart-case
+		    (progn ,@body
+			   (princ #\. *debug-io*))
+		  (ensure-failed (cond)
+		    (declare (ignorable cond))
+		    (princ #\* *debug-io*)
+		    (push (list ,@(mapcar 
+				   (lambda (var-and-type)
+				     `(list ',(first var-and-type) 
+					    ,(first var-and-type)))
+				   vars-and-types)) ,problems)))))
+	 (when ,problems
+	   (let ((condition (make-condition 
+			     'ensure-random-cases-failure
+			     :total ,count 
+			     :problems ,problems)))
+	     (if (find-restart 'ensure-failed)
+		 (invoke-restart 'ensure-failed condition) 
+		 (warn condition))))))))
+
+(defmacro ensure-random-cases+ (count (&rest vars) (&rest case-form)
+				&body body)
+  (let ((total (gensym))
+	(problems (gensym)))
+    `(let ((,problems nil) (,total 0))
+       (loop repeat ,count do
+	    (incf ,total)
+	    (destructuring-bind ,vars ,case-form
+	      (restart-case
+		  (progn ,@body)
+		(ensure-failed (cond)
+		  (declare (ignore cond))
+		  (push (list ,@vars) ,problems)))))
+       (when ,problems
+	 (let ((condition (make-condition 
+			   'ensure-random-cases-failure
+			   :total ,total
+			   :problems ,problems)))
+	   (if (find-restart 'ensure-failed)
+	       (invoke-restart 'ensure-failed condition) 
+	       (warn condition)))))))
+
+;;; merge with deftestsuite macro
+(pushnew :random-instance *deftest-clauses*)
+
+(add-code-block 
+ :random-instance 2 :methods
+ (lambda () (def :random-instances)) 
+ '((push (cleanup-parsed-parameter value) (def :random-instances)))
+ 'build-random-instances-method)
+
+(defun build-random-instances-method ()
+  `(let (#+allegro
+	 (excl:*redefinition-warnings* nil))
+     ,@(mapcar (lambda (instance)
+		      (let ((atype (first instance))
+			    (body (second instance)))
+			`(defrandom-instance ,atype test-mixin ,body)))
+		    (def :random-instances))))
+
+(defgeneric random-number (suite min max))
+
+(defgeneric random-element (suite sequence))
+
+(defmethod random-number (suite min max)
+  (declare (ignore suite))
+  (+ min (random (- max min))))
+
+(defmethod random-element (suite sequence)
+  (elt sequence (random-number suite 0 (1- (length sequence)))))
+
+(defrandom-instance an-integer test-mixin
+  (random-number suite -100 100))
+
+(defrandom-instance a-single-float test-mixin
+  (random-number suite -100s0 100.0s0))
+
+(defrandom-instance a-double-float test-mixin
+  (random-number suite -100d0 100.0d0))
+
+(defrandom-instance a-symbol test-mixin
+  (random-element suite '(a hello a-c d_f |MiXeD|
+			  -2<>#$%#)))
+
+
+

data/lib/clucumber/vendor/lift/dev/report-locations.lisp

@@ -0,0 +1,13 @@
+(in-package #:lift)
+
+(defmethod generate-report-summary-pathname :around ()
+  (let ((basepath (call-next-method)))
+    (add-implementation-specific-directory-name basepath)))
+
+(defun add-implementation-specific-directory-name (basepath)
+    (merge-pathnames
+     (make-pathname 
+      :directory `(:relative 
+		   ,(asdf::implementation-specific-directory-name)))
+   basepath))
+