src/pattern-specializer/pattern-specializer.lisp

   1 ;;;; pattern-specializer.lisp --- Implementation of pattern specializers.
   2 ;;;;
   3 ;;;; Copyright (C) 2014 Jan Moringen
   4 ;;;;
   5 ;;;; Author: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
   6
   7 (cl:in-package #:pattern-specializer)
   8
   9 ;;; `pattern-generalizer' class
  10
  11 (defstruct (pattern-generalizer
  12             (:constructor make-pattern-generalizer (specializers key variables &optional next))
  13             (:copier nil))
  14   (specializers nil :type list :read-only t)
  15   (key          nil :type t    :read-only t)
  16   (variables    nil :type list :read-only t)
  17   (next         nil :type t))
  18
  19 (defmethod specializable:generalizer-equal-hash-key
  20     ((generic-function specializable:specializable-generic-function)
  21      (generalizer pattern-generalizer))
  22   (let ((key (pattern-generalizer-key generalizer)))
  23     (if-let ((next (pattern-generalizer-next generalizer))) ; TODO compute lazily?
  24       (cons key (specializable:generalizer-equal-hash-key
  25                  generic-function next))
  26       key)))
  27
  28 (defmethod specializable::generalizer-args
  29     ((generic-function specializable:specializable-generic-function)
  30      (generalizer pattern-generalizer))
  31   (pattern-generalizer-variables generalizer))
  32
  33 ;;; `pattern-specializer' class
  34
  35 (defclass pattern-specializer (specializable:extended-specializer)
  36   ((pattern :initarg  :pattern
  37             :reader   specializer-pattern))
  38   (:default-initargs
  39    :pattern (required-argument :pattern)))
  40
  41 (defmethod print-object ((object pattern-specializer) stream)
  42   (print-unreadable-object (object stream :type t :identity t)
  43     (princ (specializer-pattern object) stream)))
  44
  45 (defun specializer-parsed-pattern (specializer)
  46   (optima.core:parse-pattern (specializer-pattern specializer)))
  47
  48 (defun specializer-pattern-variables (specializer)
  49   (optima.core:pattern-variables (specializer-parsed-pattern specializer)))
  50
  51 (specializable:define-extended-specializer pattern (generic-function pattern)
  52   (declare (ignore generic-function))
  53   (make-instance 'pattern-specializer :pattern pattern))
  54
  55 ;; Parsing is handled by `define-extended-specializer' above
  56
  57 (defmethod unparse-specializer-using-class
  58     ((gf specializable:specializable-generic-function) (specializer pattern-specializer))
  59   `(pattern ,(specializer-pattern specializer)))
  60
  61 (defmethod make-specializer-form-using-class or
  62     ((proto-generic-function specializable:specializable-generic-function) ; TODO should work for all specializable generic functions
  63      (proto-method specializable:specializable-method)
  64      (specializer-name cons)
  65      (environment t))
  66   (when (typep specializer-name '(cons (eql pattern)))
  67     `(sb-pcl:parse-specializer-using-class ; TODO packages
  68       (sb-pcl:class-prototype (find-class ',(type-of proto-generic-function)))
  69       ',specializer-name)))
  70
  71 ;;; Equality and ordering
  72
  73 (defmethod sb-pcl::same-specializer-p ((specializer1 pattern-specializer)
  74                                        (specializer2 pattern-specializer))
  75   (let ((pattern1 (specializer-parsed-pattern specializer1))
  76         (pattern2 (specializer-parsed-pattern specializer2)))
  77     (eq (pattern-more-specific-p pattern1 pattern2) '=)))
  78
  79 ;; TODO should (pattern SOME-CLASS) be `same-specializer-p' to SOME-CLASS?
  80
  81 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
  82                                        (specializer1 pattern-specializer)
  83                                        (specializer2 pattern-specializer)
  84                                        (generalizer t))
  85   (pattern-more-specific-p
  86    (specializer-parsed-pattern specializer1)
  87    (specializer-parsed-pattern specializer2)))
  88
  89 ;; TODO necessary?
  90 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
  91                                        (specializer1 t)
  92                                        (specializer2 pattern-specializer)
  93                                        (generalizer t))
  94   '/=)
  95
  96 ;; TODO necessary?
  97 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
  98                                        (specializer1 pattern-specializer)
  99                                        (specializer2 t)
 100                                        (generalizer t))
 101   '/=)
 102
 103 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
 104                                        (specializer1 class)
 105                                        (specializer2 pattern-specializer)
 106                                        (generalizer t))
 107   (multiple-value-bind (result definitivep)
 108       (specializable:specializer-accepts-generalizer-p
 109        generic-function specializer2 specializer1)
 110     (cond
 111       ((and result definitivep) '<)
 112       (result                   '>))))
 113
 114 ;; TODO can this be avoided?
 115 (defmethod specializable:specializer< ((generic-function specializable:specializable-generic-function)
 116                                        (specializer1 class)
 117                                        (specializer2 class)
 118                                        (generalizer pattern-generalizer))
 119   (let ((next (pattern-generalizer-next generalizer)))
 120     (cond
 121       ((typep next 'class)
 122        (specializable:specializer< generic-function specializer1 specializer2 next))
 123       ((multiple-value-bind (result1 definitivep1)
 124            (subtypep specializer1 specializer2)
 125          (multiple-value-bind (result2 definitivep2)
 126              (subtypep specializer2 specializer1)
 127            (cond
 128              ((not (and definitivep1 definitivep2)))
 129              ((and result1 result2) '=)
 130              (result1               '>)
 131              (result2               '<)
 132              (t                     '/=))))))))
 133
 134 ;;; Accepting objects and generalizers
 135
 136 (defmethod specializable:specializer-accepts-p ((specializer pattern-specializer) object)
 137   ;; TODO store in specializer later
 138   (let* ((accept-form (with-gensyms (object)
 139                         `(lambda (,object)
 140                            (optima:match ,object
 141                              (,(specializer-pattern specializer)
 142                               (declare (ignore ,@(specializer-pattern-variables specializer)))
 143                               t)))))
 144          (accept-function (compile nil accept-form)))
 145     (funcall accept-function object)))
 146
 147 (defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
 148                                                             (specializer pattern-specializer)
 149                                                             (generalizer pattern-generalizer))
 150   (values (find specializer (pattern-generalizer-specializers generalizer)) t))
 151
 152 (defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
 153                                                             (specializer t)
 154                                                             (generalizer pattern-generalizer))
 155   (when-let ((next (pattern-generalizer-next generalizer))) ; TODO needed?
 156     (specializable:specializer-accepts-generalizer-p gf specializer next)))
 157
 158 (defmethod specializable:specializer-accepts-generalizer-p ((gf specializable:specializable-generic-function)
 159                                                             (specializer pattern-specializer)
 160                                                             (generalizer t))
 161   (specializer-accepts-generalizer-p-using-pattern
 162    gf specializer (specializer-parsed-pattern specializer) generalizer))
 163
 164 (defmethod specializer-accepts-generalizer-p-using-pattern
 165     ((gf specializable:specializable-generic-function)
 166      (specializer pattern-specializer)
 167      (pattern optima.core:variable-pattern)
 168      (generalizer t))
 169   (values t t))
 170
 171 (defmethod specializer-accepts-generalizer-p-using-pattern
 172     ((gf specializable:specializable-generic-function)
 173      (specializer pattern-specializer)
 174      (pattern optima.core:and-pattern)
 175      (generalizer t))
 176   (let ((definitivep t))
 177     (values
 178      (block nil
 179        (mapc (lambda (subpattern)
 180                (multiple-value-bind (result definitivep)
 181                    (specializer-accepts-generalizer-p-using-pattern
 182                     gf specializer subpattern generalizer)
 183                  (unless result
 184                    (setf definitivep t) ; TODO correct?
 185                    (return nil))
 186                  (unless definitivep
 187                    (setf definitivep nil))))
 188              (optima::complex-pattern-subpatterns pattern)))
 189      definitivep)))
 190
 191 (defmethod specializer-accepts-generalizer-p-using-pattern
 192     ((gf specializable:specializable-generic-function)
 193      (specializer pattern-specializer)
 194      (pattern optima.core:or-pattern)
 195      (generalizer t))
 196   (error "not implemented"))
 197
 198 (defmethod specializer-accepts-generalizer-p-using-pattern
 199     ((gf specializable:specializable-generic-function)
 200      (specializer pattern-specializer)
 201      (pattern optima.core:not-pattern)
 202      (generalizer t))
 203   (multiple-value-bind (result definitivep)
 204       (specializer-accepts-generalizer-p-using-pattern
 205        gf specializer (optima.core:not-pattern-subpattern pattern) generalizer)
 206     (values (not result) definitivep)))
 207
 208 (defmethod specializer-accepts-generalizer-p-using-pattern
 209     ((gf specializable:specializable-generic-function)
 210      (specializer pattern-specializer)
 211      (pattern optima.core:cons-pattern)
 212      (generalizer t))
 213   (multiple-value-bind (result definitivep) (subtypep generalizer 'cons)
 214     (if result
 215         (values t (and definitivep (subpatterns-unrestricted-p pattern)))
 216         (values nil definitivep))))
 217
 218 (defmethod specializer-accepts-generalizer-p-using-pattern
 219     ((gf specializable:specializable-generic-function)
 220      (specializer pattern-specializer)
 221      (pattern optima.core:class-pattern)
 222      (generalizer t))
 223   (multiple-value-bind (result definitivep)
 224       (specializable:specializer-accepts-generalizer-p
 225        gf (find-class (optima.core:class-pattern-class-name pattern)) generalizer)
 226     (if result
 227         (values t (and definitivep (subpatterns-unrestricted-p pattern)))
 228         (values nil definitivep))))
 229
 230 (defmethod specializer-accepts-generalizer-p-using-pattern
 231     ((gf specializable:specializable-generic-function)
 232      (specializer pattern-specializer)
 233      (pattern optima.core:guard-pattern)
 234      (generalizer t))
 235   (values t nil)) ; TODO
 236
 237 ;; TODO why did i need this again?
 238 (defmethod class-name ((class (eql (find-class 'pattern-specializer))))
 239   'pattern-specializer)
 240 ;; at least this one is for slime
 241 (defmethod class-name ((class pattern-specializer))
 242   'pattern-specializer)
 243
 244 ;;; pattern-method
 245
 246 ;; Forward definition. Actual definition is below.
 247 (defclass pattern-generic-function (specializable:specializable-generic-function)
 248   ()
 249   (:metaclass funcallable-standard-class))
 250
 251 (defclass pattern-method (standard-method)
 252   ())
 253
 254 (defmethod method-pattern-specializers ((gf pattern-generic-function)
 255                                         (method pattern-method))
 256   (remove-if-not (of-type 'pattern-specializer)
 257                  (mapcar (curry #'parse-specializer-using-class gf) ; TODO necessary?
 258                          (method-specializers method))))
 259
 260 (defmethod make-method-lambda-using-specializers
 261     ((gf pattern-generic-function) (method pattern-method) qualifiers specializers
 262      lambda-expression environment)
 263
 264   ;; This transforms LAMBDA-EXPRESSION of the form
 265   ;;
 266   ;;   (lambda (arg1 arg2 …) BODY)
 267   ;;
 268   ;; into
 269   ;;
 270   ;;   (lambda (arg1 arg2 …
 271   ;;            &key
 272   ;;            ((:PATTERN-VAR1 PATTERN-VAR1)) ((:PATTERN-VAR2 PATTERN-VAR2)) …
 273   ;;            &allow-other-keys)
 274   ;;     BODY)
 275   ;;
 276   ;; where BODY contains uses of PATTERN-VAR1, PATTERN-VAR2, …
 277   (destructuring-bind (operator lambda-list &body body) lambda-expression
 278     (declare (ignore operator))
 279     (multiple-value-bind (required optional rest keyword allow-other-keys-p)
 280         (parse-ordinary-lambda-list lambda-list :normalize nil)
 281       (flet ((make-keyword-parameter (variable)
 282                (list `((,(make-keyword variable) ,variable)))))
 283         (let* ((variables (mappend #'specializer-pattern-variables ; TODO this stuff is repeated in make-method-matching-form
 284                                    (remove-if-not (of-type 'pattern-specializer)
 285                                                   (mapcar (curry #'parse-specializer-using-class gf)
 286                                                           specializers))))
 287                (new-lambda-list `(,@required
 288                                   ,@(when optional
 289                                       `(&optional ,@optional))
 290                                   ,@(when rest
 291                                       `(&rest ,rest))
 292                                   ,@(when (or keyword variables)
 293                                       `(&key ,@keyword
 294                                              ,@(mapcan #'make-keyword-parameter variables)))
 295                                   ,@(when allow-other-keys-p
 296                                       '(&allow-other-keys))))
 297                (new-lambda-expression `(lambda ,new-lambda-list ,@body)))
 298           (call-next-method
 299            gf method qualifiers specializers new-lambda-expression environment))))))
 300
 301 ;;; pattern-generic-function
 302
 303 (defclass pattern-generic-function (specializable:specializable-generic-function)
 304   ((specializer-clusters :type     list)
 305    (generalizer-makers   :type     list #|of function|#))
 306   (:metaclass funcallable-standard-class)
 307   (:default-initargs
 308    :method-class (find-class 'pattern-method))) ; TODO is pattern-method even needed?
 309
 310 (defmethod reinitialize-instance :after ((instance pattern-generic-function)
 311                                          &key)
 312   (slot-makunbound instance 'specializer-clusters)
 313   (slot-makunbound instance 'generalizer-makers))
 314
 315 (defmethod generic-function-specializer-clusters ((generic-function pattern-generic-function))
 316   (if (slot-boundp generic-function 'specializer-clusters) ; TODO ensure-slot-value
 317       (slot-value generic-function 'specializer-clusters)
 318       (setf (slot-value generic-function 'specializer-clusters)
 319             ;; TODO copied from make-generalizer-makers
 320             (when-let* ((methods (generic-function-methods generic-function))
 321                         (arity (when-let ((first-method (first methods)))
 322                                  (length (method-specializers first-method)))) ; TODO improve
 323                         )
 324               (loop :for i :below arity
 325                  :collect (let* ((specializers (mapcar (lambda (method)
 326                                                          (nth i (method-specializers method)))
 327                                                        methods))
 328                                  (non-pattern-specializers
 329                                   (remove-if (of-type 'pattern-specializer) specializers))
 330                                  (pattern-specializers
 331                                   (set-difference specializers non-pattern-specializers)))
 332                             (specializer-clusters generic-function pattern-specializers)))))))
 333
 334 (defmethod generic-function-generalizer-makers ((generic-function pattern-generic-function))
 335   (if (slot-boundp generic-function 'generalizer-makers)
 336       (slot-value generic-function 'generalizer-makers)
 337       (setf (slot-value generic-function 'generalizer-makers)
 338             (make-generalizer-makers generic-function))))
 339
 340 (defmethod specializable:generalizers-of-using-class ((generic-function pattern-generic-function) args)
 341   (let ((nexts))
 342     (loop
 343        :for i :from 0
 344        :for maker :in (generic-function-generalizer-makers generic-function)
 345        :for arg :in args
 346        :do (pop nexts)
 347        :collect
 348        (cond
 349          ((funcall maker arg))
 350          ((not nexts) (first (setf nexts (nthcdr i (call-next-method)))))
 351          (t           (first  nexts))))))
 352
 353 ;;; Specializer clustering
 354
 355 (defmethod in-same-cluster-p ((generic-function t) (specializer1 t) (specializer2 t))
 356   nil)
 357
 358 (defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
 359                               (specializer1 pattern-specializer)
 360                               (specializer2 pattern-specializer))
 361   (let ((pattern1 (specializer-parsed-pattern specializer1))
 362         (pattern2 (specializer-parsed-pattern specializer2)))
 363     (member (pattern-more-specific-p pattern1 pattern2) '(= < >))))
 364
 365 (defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
 366                               (specializer1 pattern-specializer)
 367                               (specializer2 class))
 368   (specializable:specializer-accepts-generalizer-p
 369    generic-function specializer1 specializer2))
 370
 371 (defmethod in-same-cluster-p ((generic-function specializable:specializable-generic-function)
 372                               (specializer2 class)
 373                               (specializer1 pattern-specializer))
 374   (specializable:specializer-accepts-generalizer-p
 375    generic-function specializer1 specializer2))
 376
 377 (defun specializer-clusters (generic-function specializers)
 378   (let ((clusters '()))
 379     (dolist (specializer specializers)
 380       (dolist (cluster clusters (push (list (list specializer)) clusters))
 381         (when (every (lambda (entry)
 382                        (in-same-cluster-p
 383                         generic-function specializer (first entry)))
 384                      cluster)
 385           (dolist (entry cluster (nconcf cluster (list (list specializer))))
 386             (when (sb-pcl::same-specializer-p specializer (first entry))
 387               (nconcf entry (list specializer))
 388               (return)))
 389           (return))))
 390     (mapcar (lambda (cluster)
 391               (stable-sort cluster (lambda (entry1 entry2)
 392                                      (eq '< (specializable:specializer<
 393                                              generic-function entry1 entry2 :TODO)))
 394                            :key #'first))
 395             clusters)))
 396
 397 ;;; Generalizers maker
 398
 399 (defun make-generalizer-maker-form (generic-function specializers clusters)
 400   (labels ((cluster-element-clause (element rest)
 401              (let* ((specializer (first element))
 402                     (variables (specializer-pattern-variables specializer)))
 403                `(,(specializer-pattern specializer)
 404                   (make-pattern-generalizer
 405                    '(,@(mappend #'identity (list* element rest)))
 406                    ',(specializer-pattern specializer)
 407                    (list ,@(loop :for variable in (remove-if-not #'symbol-package variables) ; TODO hack
 408                               :collect (make-keyword variable)
 409                               :collect variable))))))
 410            (cluster-clauses (cluster)
 411              (loop :for (element . rest) :on cluster
 412                 :collect (cluster-element-clause element rest))))
 413     `(lambda (arg)
 414        (optima:match arg
 415          ,@(mappend #'cluster-clauses clusters)
 416          (t ,(make-pattern-generalizer '() nil '()))))))
 417
 418 (defun make-generalizer-maker (generic-function specializers clusters)
 419   (let* ((non-pattern-specializers
 420           (remove-if (of-type 'pattern-specializer) specializers))
 421          (pattern-specializers
 422           (set-difference specializers non-pattern-specializers)))
 423     (values (compile nil (make-generalizer-maker-form
 424                           generic-function pattern-specializers clusters))
 425             non-pattern-specializers)))
 426
 427 (defun make-generalizer-makers (generic-function)
 428   (let* ((clusters (generic-function-specializer-clusters generic-function))
 429          (methods  (generic-function-methods generic-function))
 430          (arity    (when-let ((first-method (first methods)))
 431                      (length (method-specializers first-method)))) ; TODO improve
 432          (any-non-pattern-specializers-p nil))
 433     (values
 434      (loop :for i :below arity
 435         :collect (multiple-value-bind
 436                        (generalizer-maker non-pattern-specializers-p)
 437                      (make-generalizer-maker
 438                       generic-function
 439                       (mapcar (lambda (method)
 440                                 (nth i (method-specializers method)))
 441                               methods)
 442                       (nth i clusters))
 443                    (when non-pattern-specializers-p
 444                      (setf any-non-pattern-specializers-p t))
 445                    generalizer-maker))
 446      any-non-pattern-specializers-p)))