[cl-unification-cvs] CVS cl-unification/lib-dependent

[mantoniotti]

Update of /project/cl-unification/cvsroot/cl-unification/lib-dependent
In directory cl-net:/tmp/cvs-serv30009/lib-dependent

Added Files:
	cl-ppcre-template.lisp 
Log Message:
Modified Files:
 	test/unification-tests.lisp 
Added Files:
 	lib-dependent/cl-ppcre-template.lisp 

The cl-ppcre-template reuses E. Weitz's wonderful CL-PPCRE library
to provide a seamless (YMMV) reuse of regular expressions within
CL-UNIFICATION.




--- /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.lisp	2009/04/15 10:24:28	NONE
+++ /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.lisp	2009/04/15 10:24:28	1.1
;;;; -*- Mode: Lisp -*-

;;;; cl-ppcre-template.lisp --
;;;; REGEXP template dependent on CL-PPCRE.

(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.

(require "CL-PPCRE")


;;;; REGEXP Templates.
;;;; Another extension of the type specifier language.

;;;; A template can also be
;;;;
;;;;    <template> ::= #| templates from template-hierarchy.lisp |#
;;;;               |   <regexp template>
;;;;
;;;; Hairier REGEXP template spec syntax:
;;;;
;;;; (regexp|regular-expression) <REGEXP> &optional <unification vars> &rest <keys>
;;;;
;;;; where
;;;;
;;;; <REGEXP> ::= <a CL-PPCRE regexp string or tree>
;;;; <unification vars> ::= '(' <variable>* ')'
;;;; <keys> ::= <CL-PPCRE (constant) keys to be passed to CL-PPCRE:CREATE-SCANNER>

(defclass regular-expression-template (string-template)
  ((scanner :reader scanner)
   (regexp :reader regular-expression)
   (vars :reader variables
         :reader registers
         :type list)
   )
  (:documentation "The Regular Expression Template.

A template for matching strings using regular expressions.
The actual matching is done thankes to the CL-PPCRE library.")
  )



(defgeneric regular-expression-template-p (x)
  (:method ((x regular-expression-template)) t)
  (:method ((x t)) nil))


(defmethod make-template ((kind (eql 'regexp)) (spec cons))
  (make-instance 'regular-expression-template :spec spec))

(defmethod make-template ((kind (eql 'regular-expression)) (spec cons))
  (make-template 'regexp spec))


(defmethod initialize-instance :after ((re-t regular-expression-template) &key)
  (destructuring-bind (re-kwd regexp &optional vars &rest keys)
      (template-spec re-t)
    (declare (ignore re-kwd))
    (multiple-value-bind (scanner reg-names)
        (let ((cl-ppcre:*allow-named-registers* t))
          (apply #'cl-ppcre:create-scanner regexp keys))
      (declare (ignorable reg-names))
      (setf (slot-value re-t 'scanner)
            scanner

            (slot-value re-t 'regexp)
            regexp

            (slot-value re-t 'vars)
            vars ; Maybe will merge with REG-NAMES...
            )
      )))

#|
(defmethod initialize-instance :after ((re-t regular-expression-template) &key)
  ;; FIX: handling of CL-PPCRE:CREATE-SCANNER keywords.  This can be
  ;; done by using the "harier" syntax of SPEC (see above).
  (destructuring-bind (re-kwd regexp &optional vars &rest keys)
      (template-spec re-t)
    (declare (ignore re-kwd)
             (ignorable regexp vars keys))
    (multiple-value-bind (scanner reg-names)
        (let ((cl-ppcre:*allow-named-registers* t))
          (cl-ppcre:create-scanner (second (template-spec re-t))))
      (declare (ignorable reg-names))
      (setf (slot-value re-t 'scanner)
            scanner

            (slot-value re-t 'regexp)
            (second (template-spec re-t)) ; For the time being just stored and
                                          ; used for debugging.
            )
      )))
|#

;;;;---------------------------------------------------------------------------
;;;; Implementation.

;;; Unification.

(defmethod unify ((ret1 regular-expression-template)
                  (ret2 regular-expression-template)
                  &optional (env (make-empty-environment))
                  &key &allow-other-keys)
  (if (eq ret1 ret2)
      env
      ;; I could UNIFY the result of the CL-PPCRE:PARSE-STRINGs.
      (error 'unification-failure
             :format-control "Do not know how unify the two ~
                              regular-expression templates: ~S and ~S."
             :format-arguments (list ret1 ret2))))


(defmethod unify ((re-t regular-expression-template) (s string)
                  &optional (env (make-empty-environment))
                  &key
                  (start 0)
                  end
                  &allow-other-keys)
  (declare (type (integer 0 #.most-positive-fixnum) start)
           (type (or null (integer 0 #.most-positive-fixnum)) end))
  (let ((end (or end (length s))))
    (declare (type (integer 0 #.most-positive-fixnum) end))
    (multiple-value-bind (m-start m-end r-starts r-ends)
        (cl-ppcre:scan (scanner re-t) s :start start :end end)
      ;; Maybe SCAN-TO-STRINGS would be simpler to use...

      (declare (type (integer 0 #.most-positive-fixnum) m-start m-end)
               (type (vector (integer 0 #.most-positive-fixnum)) r-starts r-ends))
      (unless (and (= start m-start) (= m-end end))
        (error 'unification-failure
               :format-control "String ~S cannot be matched against ~
                                regular expression ~S."
               :format-arguments (list s
                                       (regular-expression re-t))))
      (let ((vars (variables re-t)))
        (if (null vars)
            env
            (loop for r-start across r-starts
                  for r-end   across r-ends
                  for r-string of-type string = (subseq s r-start r-end)
                  for v in vars
                  for result-env = (var-unify v r-string env)
                  then (var-unify v r-string result-env)
                  finally (return result-env))))
      )))


(defmethod unify ((s string) (re-t regular-expression-template)
                  &optional (env (make-empty-environment))
                  &key (start 0) end &allow-other-keys)
  (unify re-t s env :start start :end end))
  

;;;; end of file -- cl-ppcre-template.lisp --