;;;; -*- Mode: Lisp -*-

;;;; match-block.lisp --
;;;; Various macros built on top of the unifier: MATCH, MATCHING and MATCH-CASE.

;;;; See file COPYING for copyright licensing information.

(in-package "UNIFY")

(defun clean-unify-var-name (v)
  (assert (variablep v))
  (intern (subseq (symbol-name v) 1)
          (symbol-package v)))

(defmacro with-unification-variables ((&rest variables) environment &body body)
  "Execute body with variables bound to their values in environment."
  (flet ((variable-bindings (v)
           `((,v (find-variable-value ',v ,environment))
             (,(clean-unify-var-name v) ,v))))
    `(let* ,(mapcan #'variable-bindings variables)
       (declare (ignorable ,@(mapcar #'clean-unify-var-name variables)))
       ,@body)))

(defun %match-expander (template-munger clause-munger clauses
                        &key default named environment errorp error-form keyform)
  "A rather hairy internal function which handles expansion for all the MATCH* macros.

template-munger should be either 'match or 'matchf, and will massage the
template into the proper form for that macro set.

clause-munger should be either 'cond, 'case, or 'nil.  This affects the expected
syntax of items in clauses as follows:
  'cond: { ((<template> <object>) &body) }+ default-clause
  'case: { (<template> &body) }+            default-clause
  'nil:  { (<template> <object> &body) }+   default-clause
  default-clause: [ (t &body) ]

clauses is a list of forms conforming to the syntax just described.

default is a single form to be executed if no other forms match.
named is the name for a surrounding block.

environment is a base environment object which template matches should extend.
The new environments created will share frames with this environment, though any
additional bindings will be in a new, unshared frame.  environment defaults to
'(make-empty-environment).

errorp is a single form which will be evaluated to determine if error-form is
executed.

error-form is a form which is expected to generate an error (e.g., `(error
'unification-non-exhaustive)).  It defaults to providing the error returned by
the last form which failed unification.

keyform should be used only for a clause-munger of 'case.  It provides the form
to evaluate to produce the object for unification in -case macros.

*Interaction between default-clause, :errorp + :error-form, and :default

This function produces a giant COND form which ends one or more of these
assorted \"default\" clauses.  They are produced in a very specific order:
1. errorp + error-form are tried first.  Thus, if errorp is 't, neither the
   default-clause in clauses will be reached, nor the :default clause.  This is
   essentially a hook to produce a pre-user default clause.  (e.g., for
   MATCH's :errorp)
2. The default-clause in clauses, if it exists, will be tried next.  Because
   clauses is expected to contain user-specified clauses, this is expected to be
   the user-specified default clause.
3. Finally, the :default clause, if specified, will be tried.  This is
   essentially a hook to produce a post-user default clause.  (e.g., for
   -ECASE's error form)
"
  (flet ((default-clause-p (clause) (member (first clause) '(t otherwise))))
    (let ((match-environment (gensym "MATCH-ENV-"))
          (base-environment  (gensym "BASE-ENV-"))
          (match-error       (gensym "MATCH-ERR-"))
          (case-keyform      (gensym "KEYFORM-"))
          (match-clauses     (remove-if #'default-clause-p clauses))
          (default-clauses   (remove-if-not #'default-clause-p clauses)))
      (when (or (and (< 1 (length default-clauses))
                     ;; whether the default clause is the last one
                     (every #'eq clauses (append match-clauses default-clauses)))
                ;; :keyform only applies for 'case
                (and keyform (not (eq clause-munger 'case))))
        (error 'program-error))
      (labels ((ensure-template (template)
                 (cond (;; Logical variables are special-cased.
                        (variablep template) `',template)
                       ;; Same for lists (under matchf)
                       ((and (eq 'matchf template-munger)
                             (listp template))
                        (make-instance 'list-template
                                       :spec (cons 'list template)))
                       (t template)))
               (expand-clause (clause)
                 (destructuring-bind (template object &rest body)
                     (munge-clause clause)
                   (let* ((template (ensure-template template))
                          (variables (collect-template-vars template)))
                     `((setf (values ,match-environment ,match-error)
                             (unify* ,template ,object (make-expanded-environment ,base-environment)))
                       (with-unification-variables ,variables ,match-environment
                         ,@body)))))
               (munge-clause (clause)
                 (ecase clause-munger
                   (cond (destructuring-bind (head . tail) clause
                           (if (consp head)
                               (list* (car head) (cadr head) tail)
                               clause)))
                   (case (list* (car clause) case-keyform (cdr clause)))
                   ((nil) clause))))
        `(block ,named
           (let ((,match-environment nil)
                 (,match-error nil)
                 (,case-keyform ,keyform)
                 (,base-environment ,(if environment
                                         `(make-shared-environment ,environment)
                                         '(make-empty-environment))))
             (declare (dynamic-extent ,match-environment ,base-environment)
                      (ignorable ,case-keyform))
             (cond
               ,@(mapcar #'expand-clause match-clauses)
               ,@(when errorp `((,errorp ,(or error-form `(error ,match-error)))))
               ,@(when default-clauses `((t ,@(cdar default-clauses))))
               ,@(when default `((t ,default))))))))))

(defmacro %set-documentation ((&rest symbols) docstring)
  `(eval-when (:load-toplevel :execute)
     (mapcar (lambda (fn) (setf (documentation fn 'function) ,docstring))
             ',symbols)))

(defmacro match ((template object
                           &key
                           (named nil)
                           (match-named nil match-named-p)
                           (substitution nil)
                           (errorp t)
                           (error-value nil))
                 &body forms)
  (when match-named-p
    (warn ":match-named is deprecated.  Use :named instead."))
  (%match-expander 'match
                   'nil
                   `((,template ,object ,@forms))
                   :default error-value
                   :named (or named match-named)
                   :environment substitution
                   :errorp errorp))

(defmacro matchf ((template object
                            &key
                            (named nil)
                            (match-named nil match-named-p)
                            (substitution nil)
                            (errorp t)
                            (error-value nil))
                  &body forms)
  (when match-named-p
    (warn ":match-named is deprecated.  Use :named instead."))
  (%match-expander 'matchf
                   'nil
                   `((,template ,object ,@forms))
                   :default error-value
                   :named (or named match-named)
                   :environment substitution
                   :errorp errorp))

(%set-documentation
 (match matchf)
 "Sets up a lexical environment to evaluate FORMS after an unification.

MATCH and MATCHF unify a TEMPLATE and an OBJECT and then set up a lexical
environment where the variables present in the template are bound
lexically.  Note that both variable names '?FOO' and 'FOO' are bound
for convenience.

MATCHF does not 'evaluate' TEMPLATE (note that using the #T syntax will
generate a template at read-time).

MATCH and MATCHF forms return the values returned by the evaluation of the
last of the FORMS.

If ERRORP is non-NIL (the default) then the form raises a
UNIFICATION-FAILURE, otherwise the result of evaluating ERROR-VALUE,
whose default is NIL is returned. (Note that UNIFICATION-FAILUREs
raising from the evaluation of FORMS will /not/ be caught and handled
according to ERRORP settings.)

A surrounding BLOCK named NAMED is set up around the matching code.")



(define-condition unification-non-exhaustive (unification-failure)
  ()
  (:default-initargs
   :format-control "Non exhaustive matching."))


(defmacro match-cond (&body clauses)
  (%match-expander 'match 'cond clauses))

(defmacro matchf-cond (&body clauses)
  (%match-expander 'matchf 'cond clauses))

(defmacro matching ((&key errorp
                          default-substitution
                          (named nil)
                          (matching-named nil matching-named-p))
                    &body match-clauses)
  (when matching-named-p
    (warn ":matching-named is deprecated.  Use :named instead."))
  (%match-expander 'match 'cond match-clauses
                   :errorp errorp
                   :error-form `(error 'unification-non-exhaustive)
                   :named (or named matching-named)
                   :environment default-substitution))

(%set-documentation
 (match-cond matchf-cond matching)
 "MATCH-COND, MATCHF-COND, and MATCHING set up a COND-like environment for
multiple template matching clauses.

Their syntax comprises a number of clauses of the form
  <clause> ::= <regular-clause> | <default-clause>
  <regular-clause> ::= ((<template> <form>) &body <forms>)
  <default-clause> ::= (t &body <forms>)
                   |   (otherwise &body <forms>)
<form> and <forms> are regular Common Lisp forms.
<template> is a unification template.

The full syntax is
  match-cond <clauses>
  matchf-cond <clauses>
  matching (&key errorp default-substitution named) <clauses>

Each clause evaluates its forms in an environment where the variables
present in the template are bound lexically.  Note that both variable
names '?FOO' and 'FOO' are bound for convenience.

The values returned by the macros are those of the last form in
the first clause that satisfies the match test.

If ERRORP is non-NIL then if none of the regular clauses matches, then
an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of
any default clause.  Otherwise, the default clause behaves as a
standard COND default clause.  The default value of ERRORP is NIL.
")


(defmacro match-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
                      &body clauses)
  (when match-case-named-p
    (warn ":match-case-named is deprecated.  Use :named instead."))
  (%match-expander 'match 'case clauses
                   :named (or named match-case-named)
                   :environment default-substitution
                   :errorp errorp
                   :error-form `(error 'unification-non-exhaustive)
                   :keyform object))

(defmacro match-ecase ((object &key default-substitution named)
                       &body clauses)
  (%match-expander 'match 'case clauses
                   :named named
                   :environment default-substitution
                   :default `(error 'unification-non-exhaustive)
                   :keyform object))

(defmacro matchf-case ((object &key errorp default-substitution named (match-case-named nil match-case-named-p))
                       &body clauses)
  (when match-case-named-p
    (warn ":match-case-named is deprecated.  Use :named instead."))
  (%match-expander 'matchf 'case clauses
                   :named (or named match-case-named)
                   :environment default-substitution
                   :errorp errorp
                   :error-form `(error 'unification-non-exhaustive)
                   :keyform object))

(defmacro matchf-ecase ((object &key default-substitution named)
                       &body clauses)
  (%match-expander 'matchf 'case clauses
                   :named named
                   :environment default-substitution
                   :default `(error 'unification-non-exhaustive)
                   :keyform object))

(%set-documentation
 (match-case match-ecase matchf-case matchf-ecase)
 "MATCH-CASE, MATCH-ECASE, MATCHF-CASE, and MATCHF-ECASE set up a CASE-like
environment for multiple template matching clauses.

Their syntax comprises a number of clauses of the form
  <clause> ::= <regular-clause> | <default-clause>
  <regular-clause> ::= (<template> &body <forms>)
  <default-clause> ::= (t &body <forms>)
                   |   (otherwise &body <forms>)
<form> and <forms> are regular Common Lisp forms.
<template> is a unification template.

The full syntax is
  match-case   (<object> &key default-substitution named errorp) <clauses>
  match-ecase  (<object> &key default-substitution named)        <clauses>
  matchf-case  (<object> &key default-substitution named errorp) <clauses>
  matchf-ecase (<object> &key default-substitution named)        <clauses>

Each clause evaluates its forms in an environment where the variables
present in the template are bound lexically.  Note that both variable
names '?FOO' and 'FOO' are bound for convenience.

The values returned by the macros are those of the last form in
the first clause that satisfies the match test.

MATCHF-ECASE and MATCHF-CASE behave like MATCH-ECASE and MATCH-CASE, but the
patterns are not evaluated (i.e., they rely on MATCHF instead of MATCH to
construct the macro expansion).
")


;;;;---------------------------------------------------------------------------
;;;; Testing.

#| Tests

(let ((n 42))
  (matching ()
            ((0 n) 1)
            ((?x n) (* x (1- x)))))


(let ((n 42))
  (match-case (n)
              (0 1)
              (?x (* x (1- x)))))


(let ((n 42))
  (match-case (n)
              (0 1)
              (otherwise (* n (1- n)))))

(defun fatt (x)
  (match-case (x :errorp t)
              (0 1)
              (#T(number ?n) (* ?n (fatt (1- n))))
              ))

|#

;;;; end of file -- math-blocks.lisp --