(defpackage "PATTERN-MATCHING"
  (:nicknames "PM")
  (:use "CL")
  (:export "DEFH" "ONE-OF" "AIF"))
(in-package "PATTERN-MATCHING")

;;; Some basic macros

(defmacro aif ((arg test) then &optional else)
  (let ((tt (gensym)))
    `(let ((,tt ,test))
       (if ,tt
	   (let ((,arg ,tt))
	     ,then)
	 ,else))))

(defmacro one-of (&rest things)
  "Constructs a function that checks whether is in the set of 'things'"
  `(lambda (x)
     (find x ',things)))

;;; Pattern matching as in Haskell

;; Variables are constructed using this read macro:
;; ?var -> #S(VARIABLE :NAME VAR :KEY NIL)
;; ?(var test) -> #S(VARIABLE :NAME VAR :KEY TEST)

;; A structure that describes a variable.
;; On the first occurrence of a variable key is a function
;; taking one argument and returning a generalised boolean. On
;; every other occurrence it takes two parameters and returns 
;; true iff they match.
(defstruct variable
  name
  (key nil))

(set-macro-character #\? 
		     (lambda (stream char)
		       (declare (ignore char))
		       (let ((form (read stream t nil t)))
			 (if (consp form)
			     (make-variable :name (first form)
					    :key (second form))
			   (make-variable :name form)))))

;; This special variable is used during pattern compilation
(defvar *vars-assigned*)

(defun generate-matcher (pattern variable)
  "Generate code to match a specific pattern in a given variable"
  (cond
   ;; If the pattern is a variable and it was already assigned
   ;; check whether the new value is equal, else fail.
   ((and (variable-p pattern)
	 (member pattern *vars-assigned*))
    (aif (key (variable-key pattern))
	 `(funcall ,key
		   ,(variable-name pattern) ,variable)
	 `(eql ,(variable-name pattern) ,variable)))
   ;; If the pattern is an unassigned variable and fits key, 
   ;; set it.
   ((variable-p pattern)
    (push pattern *vars-assigned*)
    (aif (key (variable-key pattern))
	 `(cond
	   ((funcall ,key ,variable)
	    (setq ,(variable-name pattern) ,variable)
	    t)
	   (t nil))
	 `(progn
	    (setq ,(variable-name pattern) ,variable)
	    t)))
   ;; If the pattern is NIL so must be the variable we were given
   ((null pattern)
    `(null ,variable))
   ;; Our pattern is a CONS. Let's generate code for its head
   ;; and tail.
   ((consp pattern)
    (let ((new-var (gensym)))
      `(and 
	(consp ,variable)
	(let ((,new-var (car ,variable)))
	  ,(generate-matcher (car pattern) new-var))
	(let ((,new-var (cdr ,variable)))
	  ,(generate-matcher (cdr pattern) new-var)))))
   ;; The pattern is an ATOM, it has to be equal to what we have
   ;; been given.
   ((atom pattern)
    `(eql ',pattern ,variable))
   ;; If we arrive here, somethings wrong...
   (t
    (error "Do know how to compile pattern ~S." pattern))))
       
(defun find-all-variables (pattern)
  "Find all variables in a given pattern"
  (cond
    ((variable-p pattern)
     (cons pattern nil))
    ((consp pattern)
     (nconc (find-all-variables (car pattern))
	    (find-all-variables (cdr pattern))))
    ((or (null pattern)
	 (atom pattern))
     nil)))
       
(defun compile-pattern-spec (patterns forms body not-matched)
  "Compile a pattern specification of a defh form"
  (let* ((variables (remove-duplicates
		     (mapcan #'find-all-variables patterns))))
    `(let ,(mapcar (lambda (x)
		     `(,(variable-name x) nil))
		   variables)
      (if ,(let ((*vars-assigned* nil))
		`(and ,@(loop for form-var in forms
			      and pattern in patterns
			      collect (generate-matcher pattern form-var))))
	  ,body
	  ,not-matched))))

(defun clauses-sane-p (clauses)
  "Every clause should have the same number of patterns"
  (and clauses
       (every (let ((first-len (length (first (first clauses)))))
		(lambda (x)
		  (= (length (first x)) first-len)))
	      clauses)))
		   
(defun compile-defh-body (clauses)
  "This functions returns a parameter list and body for a defh form"
  (if (not (clauses-sane-p clauses))
      (error "Malformed defh body: ~{~S~}" clauses)

      ;; So we got a correctly formed clause list
      (let ((form-vars (loop 		; Our list of parameters the function takes
			   repeat (length (first (first clauses)))
			 collect (gensym))))
	(values form-vars
		(loop for (patterns body) in (reverse clauses)
		      for code = (compile-pattern-spec patterns form-vars body
						       `(error "No pattern matched"))
		      then (compile-pattern-spec patterns form-vars body old-code)
		      for old-code = code
		      finally (return code))))))
	
(defun parse-defh-clauses (clauses)
  "Parse the raw clauses into the internal form"
  (and clauses
       (aif (pos (position-if (lambda (x) ; avoid exporting '->
				(and (symbolp x)
				     (string= "->" (string x))))
			      clauses))
	    (cons (list (subseq clauses 0 pos)
			(elt clauses (1+ pos)))
		  (parse-defh-clauses (subseq clauses (+ 2 pos))))
	    (error "Malformed defh form: ~S" clauses))))

(defmacro defh (name &rest raw-clauses)
  "Define a function based on patterns"
  (let ((parsed-clauses (parse-defh-clauses raw-clauses)))
    (multiple-value-bind (parameter body)
	(compile-defh-body parsed-clauses)
      `(defun ,name ,parameter 
	,body))))