external/lift.darcs/_darcs/pristine/dev/prototypes.lisp

   1 ;;;-*- Mode: Lisp; Package: LIFT -*-
   2
   3 (in-package #:lift)
   4
   5 (pushnew :cases *deftest-clauses*)
   6
   7 (add-code-block
   8  :cases 2 :methods
   9  (lambda () (def :cases))
  10  '((setf (def :cases) (cleanup-parsed-parameter value)))
  11  'build-cases-method)
  12
  13 (defun build-cases-method ()
  14   (when (atom (car (def :cases)))
  15     (setf (def :cases) (list (def :cases))))
  16   ;(spy (def :cases))
  17   (let ((cases (standardize-cases-form (def :cases))))
  18     `(defmethod initialize-prototypes :after ((test ,(def :testsuite-name)))
  19        (setf (prototypes test)
  20              (rest (process-cases-form
  21                     ,(first cases)
  22                     ,@(mapcar (lambda (a) `',a) (rest cases))))))))
  23
  24 ;; goal is spec := (<tag> <spec>+)
  25 ;;         spec := (<var value>+)
  26 (defun standardize-cases-form (cases)
  27   (cond ((atom (first cases))
  28          (cond ((valid-tag-p (first cases))
  29                 `(,(first cases) ,@(mapcar #'standardize-cases-form (rest cases))))
  30                (t
  31                 cases)))
  32         ((and (length-1-list-p cases)
  33               (consp (first cases))
  34               (valid-tag-p (first (first cases))))
  35          (standardize-cases-form (first cases)))
  36         (t
  37          `(:cross ,@(mapcar #'standardize-cases-form cases)))))
  38
  39 ;;; ---------------------------------------------------------------------------
  40
  41 (defun check-subcases (cases)
  42   (cond ((not (valid-tag-p (first cases)))
  43          `(,(default-cases-tag) ,@(mapcar #'standardize-cases-form cases)))
  44         (t
  45          (mapcar #'standardize-cases-form cases))))
  46
  47 ;;; ---------------------------------------------------------------------------
  48
  49 (defun default-cases-tag ()
  50   :cross)
  51
  52 ;;; ---------------------------------------------------------------------------
  53
  54 (defun valid-tag-p (tag)
  55   (member tag '(:map :cross)))
  56
  57 ;;; ---------------------------------------------------------------------------
  58
  59 (defmethod process-cases-form :around ((type t) &rest forms)
  60   (apply #'call-next-method type (if (atom (car forms))
  61                                    (list forms) forms)))
  62
  63 ;;; ---------------------------------------------------------------------------
  64
  65 (defmethod process-cases-form ((type t) &rest forms)
  66   (cond ((atom (first type))
  67          (apply #'process-cases-form (first type) (append (rest type) forms)))
  68         (t (apply #'process-cases-form :cross (append type forms)))))
  69
  70 #+Old
  71 (defmethod process-cases-form ((type (eql :map)) &rest forms)
  72   (let ((vars (mapcar #'car forms))
  73         (values (mapcar #'rest forms)))
  74     `(let (,@(mapcar (lambda (var value) `(,var ,@value))
  75                      vars values))
  76        (mapcar (lambda ,vars
  77                  (list ,@(mapcar (lambda (var) `(cons ',var ,var)) vars)))
  78                ,@vars))))
  79
  80 ;;; ---------------------------------------------------------------------------
  81
  82 (defmethod process-cases-form ((type (eql :map)) &rest forms)
  83   (let ((vars (ensure-list (flatten (vars-from-assignment forms))))
  84         (values (values-from-assignment forms)))
  85     `(:b ,@(apply #'mapcar
  86                   (lambda (&rest args)
  87                     (mapcar (lambda (var value)
  88                               (cons var value))
  89                             vars args))
  90                   values))))
  91
  92 ;;; ---------------------------------------------------------------------------
  93
  94 (defmethod process-cases-form ((type (eql :cross)) &rest forms)
  95   (let ((vars (ensure-list (flatten (vars-from-assignment forms))))
  96         (values (values-from-assignment forms))
  97         (result nil))
  98     (iterate-over-indexes
  99      (mapcar #'length values)
 100      (lambda (indexes)
 101        (let ((datum nil))
 102          (mapcar (lambda (name var index)
 103                    (push (cons name (elt var index)) datum))
 104                  vars
 105                  values
 106                  indexes)
 107          (push (nreverse datum) result)))
 108      :right)
 109     `(:b ,@(nreverse result))))
 110
 111 ;;; ---------------------------------------------------------------------------
 112
 113 (defun vars-from-assignment (assignment)
 114   (cond ((is-binding-p assignment)
 115          (mapcar #'car (second assignment)))
 116         ((metatilities:dotted-pair-p assignment)
 117          (car assignment))
 118         ((atom (car assignment))
 119          (car assignment))
 120         ((length-1-list-p assignment)
 121          (vars-from-assignment (first assignment)))
 122         (t (loop for assignment in assignment collect
 123                  (vars-from-assignment assignment)))))
 124
 125 ;;; ---------------------------------------------------------------------------
 126
 127 (defun values-from-assignment (assignment)
 128   (cond ((is-binding-p assignment)
 129          (apply #'mapcar (lambda (&rest bindings)
 130                    (mapcar (lambda (binding)
 131                              (cdr binding))
 132                            bindings))
 133                  (rest assignment)))
 134         ((dotted-pair-p assignment)
 135          (cdr assignment))
 136         ((atom (car assignment))
 137          (list (eval (first (rest assignment)))))
 138         (t
 139          (loop for assignment in assignment nconc
 140                  (ensure-list (values-from-assignment assignment))))))
 141
 142 ;;; ---------------------------------------------------------------------------
 143
 144 (defun is-binding-p (assignment)
 145   (eq (first assignment) :b))
 146
 147
 148 #|
 149
 150
 151 (export '(map-prototypes-of
 152           prototypes-of
 153           prototype-of
 154           prototype-exists-p))
 155
 156 ;;; ---------------------------------------------------------------------------
 157 ;;; API
 158 ;;; ---------------------------------------------------------------------------
 159
 160 (defgeneric map-prototypes-of (fn thing)
 161   (:documentation ""))
 162
 163 ;;; ---------------------------------------------------------------------------
 164
 165 (defgeneric prototypes-of (thing)
 166   (:documentation ""))
 167
 168 ;;; ---------------------------------------------------------------------------
 169
 170 (defgeneric prototype-of (thing)
 171   (:documentation ""))
 172
 173 ;;; ---------------------------------------------------------------------------
 174
 175 (defgeneric prototype-exists-p (thing)
 176   (:documentation ""))
 177
 178 ;;; ---------------------------------------------------------------------------
 179 ;;; implementation
 180 ;;; ---------------------------------------------------------------------------
 181
 182 (defmethod map-prototypes-of :around (fn thing)
 183   (declare (ignore fn))
 184   (when (prototype-exists-p thing)
 185     (call-next-method)))
 186
 187 ;;; ---------------------------------------------------------------------------
 188
 189 (defmethod map-prototypes-of (fn (thing standard-class))
 190   (map-subclass-prototypes fn thing))
 191
 192 ;;; ---------------------------------------------------------------------------
 193
 194 (defmethod map-prototypes-of (fn (thing built-in-class))
 195   (map-subclass-prototypes fn thing))
 196
 197 ;;; ---------------------------------------------------------------------------
 198
 199 (defun map-subclass-prototypes (fn thing)
 200   (mopu:map-subclasses thing
 201                        (lambda (subclass)
 202                          (when (prototype-exists-p subclass)
 203                            (funcall fn (prototype-of subclass)))))
 204   (values))
 205
 206 ;;; ---------------------------------------------------------------------------
 207
 208 (defmethod prototypes-of (thing)
 209   (containers:collect-using 'map-prototypes-of nil thing))
 210
 211 ;;; ---------------------------------------------------------------------------
 212
 213 (defmethod prototype-exists-p (thing)
 214   ;; the expensive way to see if a prototype exists is to try and make one
 215   ;; and see if it works...
 216   (handler-case
 217     (let ((creator-method (compute-applicable-methods #'prototype-of (list thing))))
 218       (when creator-method
 219         (let ((x (prototype-of thing)))
 220           (declare (optimize (safety 3) (debug 3) (speed 0) (space 0)))
 221           x
 222           (values t))))
 223     (error (c) (inspect c) nil)))
 224
 225 ;;; ---------------------------------------------------------------------------
 226
 227 (defmethod prototype-of ((thing standard-class))
 228   (allocate-instance thing))
 229
 230 ;;; ---------------------------------------------------------------------------
 231
 232 (defmethod prototype-of ((thing (eql 'fixnum)))
 233   (variates:integer-random variates:*random-generator* -10 10))
 234
 235
 236 |#
 237
 238
 239
 240 (defmethod more-prototypes-p :before ((testsuite test-mixin))
 241   (setf (current-step testsuite) 'more-prototypes-p))
 242
 243 ;;; ---------------------------------------------------------------------------
 244
 245 (defmethod initialize-prototypes :before ((testsuite test-mixin))
 246   (setf (current-step testsuite) 'initialize-prototypes))
 247
 248 ;;; ---------------------------------------------------------------------------
 249
 250 (defmethod next-prototype :before ((testsuite test-mixin))
 251   (setf (current-step testsuite) 'next-prototype))
 252
 253 ;;; ---------------------------------------------------------------------------
 254
 255 (defmethod testsuite-teardown :before ((testsuite test-mixin))
 256   (setf (current-step testsuite) 'testsuite-teardown))
 257
 258 ;;; ---------------------------------------------------------------------------
 259
 260 (defmethod start-test :before
 261     ((result test-result) (testsuite test-mixin) method-name)
 262   (declare (ignore method-name))
 263   (setf (current-step testsuite) 'start-test))
 264
 265 ;;; ---------------------------------------------------------------------------
 266
 267 (defmethod end-test :before
 268     ((result test-result) (testsuite test-mixin) method-name)
 269   (declare (ignore method-name))
 270   (setf (current-step testsuite) 'end-test))
 271
 272 ;;; ---------------------------------------------------------------------------
 273
 274 (defmethod setup-test :before ((testsuite test-mixin))
 275   (setf (current-step testsuite) 'setup-test))
 276
 277 ;;; ---------------------------------------------------------------------------
 278
 279 #+Ignore
 280 (defmethod teardown-test :before ((testsuite test-mixin))
 281   (setf (current-step testsuite) 'teardown-test))
 282