1 ;;;; -*- Mode: Lisp -*-
  2 
  3 ;;;; cl-ppcre-template.lisp --
  4 ;;;; REGEXP template dependent on CL-PPCRE.
  5 
  6 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
  7 
  8 
  9 ;;;; REGEXP Templates.
 10 ;;;; Another extension of the type specifier language.
 11 
 12 ;;;; A template can also be
 13 ;;;;
 14 ;;;;    <template> ::= #| templates from template-hierarchy.lisp |#
 15 ;;;;               |   <regexp template>
 16 ;;;;
 17 ;;;; Hairier REGEXP template spec syntax:
 18 ;;;;
 19 ;;;; (regexp|regular-expression) <REGEXP> &optional <unification vars> &rest <keys>
 20 ;;;;
 21 ;;;; where
 22 ;;;;
 23 ;;;; <REGEXP> ::= <a CL-PPCRE regexp string or tree>
 24 ;;;; <unification vars> ::= '(' <variable>* ')'
 25 ;;;; <keys> ::= <CL-PPCRE (constant) keys to be passed to CL-PPCRE:CREATE-SCANNER>
 26 
 27 (defclass regular-expression-template (string-template)
 28   ((scanner :reader scanner)
 29    (regexp :reader regular-expression)
 30    (vars :reader variables
 31          :reader registers
 32          :type list)
 33    )
 34   (:documentation "The Regular Expression Template.
 35 
 36 A template for matching strings using regular expressions.
 37 The actual matching is done thankes to the CL-PPCRE library.")
 38   )
 39 
 40 
 41 
 42 (defgeneric regular-expression-template-p (x)
 43   (:method ((x regular-expression-template)) t)
 44   (:method ((x t)) nil))
 45 
 46 
 47 (defmethod make-template ((kind (eql 'regexp)) (spec cons))
 48   (make-instance 'regular-expression-template :spec spec))
 49 
 50 (defmethod make-template ((kind (eql 'regular-expression)) (spec cons))
 51   (make-template 'regexp spec))
 52 
 53 
 54 (defmethod initialize-instance :after ((re-t regular-expression-template) &key)
 55   (destructuring-bind (re-kwd regexp &optional vars &rest keys)
 56       (template-spec re-t)
 57     (declare (ignore re-kwd))
 58     (multiple-value-bind (scanner reg-names)
 59         (let ((cl-ppcre:*allow-named-registers* t))
 60           (apply #'cl-ppcre:create-scanner regexp keys))
 61       (declare (ignorable reg-names))
 62       (setf (slot-value re-t 'scanner)
 63             scanner
 64 
 65             (slot-value re-t 'regexp)
 66             regexp
 67 
 68             (slot-value re-t 'vars)
 69             vars ; Maybe will merge with REG-NAMES...
 70             )
 71       )))
 72 
 73 #|
 74 (defmethod initialize-instance :after ((re-t regular-expression-template) &key)
 75   ;; FIX: handling of CL-PPCRE:CREATE-SCANNER keywords.  This can be
 76   ;; done by using the "harier" syntax of SPEC (see above).
 77   (destructuring-bind (re-kwd regexp &optional vars &rest keys)
 78       (template-spec re-t)
 79     (declare (ignore re-kwd)
 80              (ignorable regexp vars keys))
 81     (multiple-value-bind (scanner reg-names)
 82         (let ((cl-ppcre:*allow-named-registers* t))
 83           (cl-ppcre:create-scanner (second (template-spec re-t))))
 84       (declare (ignorable reg-names))
 85       (setf (slot-value re-t 'scanner)
 86             scanner
 87 
 88             (slot-value re-t 'regexp)
 89             (second (template-spec re-t)) ; For the time being just stored and
 90                                           ; used for debugging.
 91             )
 92       )))
 93 |#
 94 
 95 ;;;;---------------------------------------------------------------------------
 96 ;;;; Implementation.
 97 
 98 ;;; Unification.
 99 
100 (defmethod unify ((ret1 regular-expression-template)
101                   (ret2 regular-expression-template)
102                   &optional (env (make-empty-environment))
103                   &key &allow-other-keys)
104   (if (eq ret1 ret2)
105       env
106       ;; I could UNIFY the result of the CL-PPCRE:PARSE-STRINGs.
107       (error 'unification-failure
108              :format-control "Do not know how unify the two ~
109                               regular-expression templates: ~S and ~S."
110              :format-arguments (list ret1 ret2))))
111 
112 
113 (defmethod unify ((re-t regular-expression-template) (s string)
114                   &optional (env (make-empty-environment))
115                   &key
116                   (start 0)
117                   end
118                   &allow-other-keys)
119   (declare (type (integer 0 #.most-positive-fixnum) start)
120            (type (or null (integer 0 #.most-positive-fixnum)) end))
121   (let ((end (or end (length s))))
122     (declare (type (integer 0 #.most-positive-fixnum) end))
123 
124     (multiple-value-bind (matched-p strings)
125 	(cl-ppcre:scan-to-strings (scanner re-t) s :start start :end end)
126       (unless matched-p
127         (error 'unification-failure
128                :format-control "String ~S cannot be matched against ~
129                                 regular expression ~S."
130                :format-arguments (list s
131                                        (regular-expression re-t))))
132       (let ((vars (variables re-t)))
133         (if (null vars)
134             env
135             (loop for r-string of-type string across strings
136                   for v in vars
137                   for result-env = (var-unify v r-string env)
138                   then (var-unify v r-string result-env)
139                   finally (return result-env))))
140       )))
141 
142 
143 (defmethod unify ((s string) (re-t regular-expression-template)
144                   &optional (env (make-empty-environment))
145                   &key (start 0) end &allow-other-keys)
146   (unify re-t s env :start start :end end))
147 
148 
149 ;;;; end of file -- cl-ppcre-template.lisp --