;; -*- Mode: Irken -*-

;; based on my python translation of Dorai Sitaram's common lisp implementation
;;   of scheme's <syntax-rules>.
;;
;; see http://www.ccs.neu.edu/home/dorai/mbe/mbe-imps.html
;;     http://www.ccs.neu.edu/home/dorai/mbe/mbe-lsp.html
;;
;; XXX add back in the ability to specify keywords
;; XXX look at the various scheme versions that do hygiene

;; for macros, s-expressions are mostly lists & symbols.

;; a useful pattern when matching against s-expressions
;;  is to have a helper function for matching against
;;  lists.

(define matches-list?
  ;; empty lists match
  () ()
  -> #t
  ;; ellipsis pattern
  (p0 (sexp:symbol '...)) el
  -> (every? (lambda (x) (matches-pattern? p0 x)) el)
  ;; any other list
  (p0 . pl) (e0 . el)
  -> (and (matches-pattern? p0 e0)
	  (matches-list? pl el))
  _ _ -> #f
  )

;; a symbol in angle brackets indicates a literal symbol,
;;  not a variable, which must match exactly.
(define (angle-bracket-equal? s0 s1)
  (let ((s0 (symbol->string s0))
	(n (string-length s0)))
    (if (eq? (string-ref s0 (- n 1)) #\>)
	(string=? (substring s0 1 (- n 1)) (symbol->string s1))
	#t)))

(define matches-pattern?
  ;; symbol usually means a variable, unless surround by <brackets>
  (sexp:symbol v0) v1
  -> (if (eq? (string-ref (symbol->string v0) 0) #\<)
	 (match v1 with
	   (sexp:symbol v1)
	   -> (angle-bracket-equal? v0 v1) ;; both literal symbols
	   _ -> #f) ;; literal symbol matched against a non-symbol
	 #t) ;; non-literal symbol matches anything
  ;; list pattern
  (sexp:list pl) (sexp:list el) -> (matches-list? pl el)
  ;; now what other objects should we support in patterns?
  ;; this is probably incorrect, we really need an equal? function
  p e				-> (eq? p e)
  )

;; Very confusing.  With *no* ellipses, this returns a flat list of
;;  every symbol.  If an ellipsis is present, the symbols that it
;;  'repeats' are embedded in a list to a depth equal to the level of
;;  ellipsis nesting.  Yeah.  Theoretically this could be replaced
;;  with a list of symbol/depth pairs, but then I'd have to understand
;;  what the callers are doing as well. 8^)
;;
;; examples:
;; (a b c d) => (a b c d)
;; (a (b c) d) => (a b c d)
;; (a b c ...) => (a b (c))
;; (a b (c ...) ...) => (a b ((c)))


(define (get-ellipsis-nestings p) ;; (sexp) -> (list sexp)
  (define dolist ;; (list sexp) -> (list sexp)
    (p0 (sexp:symbol '...)) -> (LIST (sexp:list (get-ellipsis-nestings p0)))
    (hd . tl)		    -> (append (get-ellipsis-nestings hd) (dolist tl))
    _			    -> '())
  (match p with
    (sexp:list pl)    -> (dolist pl)
    (sexp:symbol sym) -> (LIST p)
    _		      -> '()))

(define intersect?
  (sexp:symbol v) (sexp:symbol y) -> (eq? v y)
  (sexp:list vl)  (sexp:list yl)
  -> (some? (lambda (vi)
	      (some? (lambda (yj)
		       (intersect? vi yj))
		     yl))
	    vl)
  _ _ -> #f
  )

(define ellipsis-sub-envs ;; (list sexp), (list sexp) -> sexp
  nestings ()                       -> (sexp:list '())
  nestings ((sexp:list (k v)) . tl) -> (if (intersect? (sexp:list nestings) k)
					   v
					   (ellipsis-sub-envs nestings tl))
  _ _ -> (error "unexpected args to ellipsis-sub-envs")
  )

;; get-bindings (sexp, sexp) -> (list sexp)
;; returns the bindings in the form of embedded sets of sexp's.
;; at first glance I thought it could be an alist, but the levels
;; of embedding preclude that.

;; p = (((x y) ...) ...)
;; e = (((1 2) (3 4)) ((5 6) (7 8)))
;; =>  ((((x y)) ((((x y) (((x 1) (y 2)) ((x 3) (y 4)))))
;;                (((x y) (((x 5) (y 6)) ((x 7) (y 8))))))))

(define (get-bindings p e) ;; -> (list sexp)
  (define dolist
    (p (sexp:symbol '...)) e
    -> (LIST (sexp (sexp:list (get-ellipsis-nestings p))
		   (sexp:list (map (lambda (ei)
				      (sexp:list (get-bindings p ei)))
				    e))))
    (hdp . tlp) (hde . tle)
    -> (append (get-bindings hdp hde)
	       (dolist tlp tle))
    _ _ -> '()
    )
  (match p e with 
     (sexp:symbol k) e           -> (LIST (sexp p e))
     (sexp:list p) (sexp:list e) -> (dolist p e)
     _ _ -> '()
     )
  )

;; look up a binding
(define (mbe/assoc k0 r)
  (let loop ((r r))
    (match r with
      () -> (maybe:no)
      ((sexp:list ((sexp:symbol k1) v1)) . tl)
      -> (if (eq? k0 k1)
	     (maybe:yes v1)
	     (loop tl))
      (hd . tl) -> (loop tl)
      )))

(define (expand-pattern p r) ;; sexp, (list sexp) -> sexp
  (match p with
    (sexp:list pl)    -> (sexp:list (expand-list pl r))
    (sexp:symbol sym) -> (match (mbe/assoc sym r) with
			    (maybe:yes v) -> v
			    (maybe:no)    -> p)
    x                 -> x
    ))

(define (expand-list p r) ;; (list sexp), (list sexp) -> (list sexp)
  (define sexp/append
    (sexp:list al) bl -> (append al bl)
    _ _ -> (error "expected list"))
  (match p with
    (p (sexp:symbol '...) . tl)
    -> (let ((nestings (get-ellipsis-nestings p))
	     (rr0 (ellipsis-sub-envs nestings r))
	     ;; rr0 is always a list of lists
	     (rr1 (match rr0 with
		    (sexp:list rrl) -> (map
					(lambda (ri)
					  ;; so ri is always a list
					  (expand-pattern p (sexp/append ri r)))
					rrl)
		    x -> (error1 "expected sexp:list" x)
		    )))
	 (append rr1 (expand-list tl r)))
    (hd . tl)
    -> (list:cons (expand-pattern hd r) (expand-list tl r))
    p -> p
    )
  )

(define (make-macro name patterns)
  (define (apply exp debug?)
    (let loop ((l patterns))
      (match l with
	((:pair in-pat out-pat) . tl)
	-> (if (matches-pattern? in-pat exp)
	       (begin
		 (if debug? (print-string (format "expanding macro " (sym name) " in " (repr exp) "\n")))
		 (let ((r (expand-pattern out-pat (get-bindings in-pat exp))))
		   (if debug? (print-string (format "  -> " (repr r) "\n")) )
		   r))
	       (loop tl))
	()
	-> (error1 "no matching clause for macro" (repr exp)))))
  (define (unread-macro)
    (print-string "(macro <")
    (print name)
    (print-string ">\n\t")
    (for-each
     (lambda (x)
       (match x with
	 (:pair in-pat out-pat)
	 -> (begin (pp 0 in-pat) (print-string " ") (pp 0 out-pat) (print-string "\n\t"))))
     patterns)
    (print-string ")\n"))
  { name     = name
    patterns = patterns
    apply    = apply
    unread   = unread-macro
    }
  )