;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/any)
(use goo/log)
(use goo/chr)
(use goo/math)
(use goo/cols)

(ds op (,f ,@args)
  (loc ((splice (y|<lst>)
          (map (fun (x) (if (== x '...) `(as <lst> _*) `(lst ,x))) y))
        (rest-op? (x => <log>)
          (or (and (isa? x <lst>) (any? rest-op? x)) (== x '...)))
        (walk-op (vars|<lst> x)
          (cond ((== x '_)
                 (def var (cat-sym "_" (len vars)))
                 (set (tail vars) (pair var (tail vars)))
                 var)
                ((isa? x <lst>)
                 (def splice? (any? (fun (y) (== y '...)) x))
                 (def y       (map (fun (y) (walk-op vars y)) x))
                 (if splice? `(app ,(head y) (cat! ,@(splice (tail y)))) y))
                (#t
                 x))))
    (if (nul? args)
      (if (== f '_)
          `(fun (x) x)
          `(fun (x|...) ,f))
      (let ((vars  (pair #f '()))
            (expr  (walk-op vars `(,f ,@args)))
            (args `(,@(rev! (tail vars)) ,@(if (rest-op? args) '(_*|...) '()))))
        `(fun ,args ,expr)))))

(export op)

;;; MACRO SUPPORT

(df match-nul-list (x|<lst> fail|<fun>)
  (if (empty? x)
      x
      (fail "Match Empty Failure of %=" x)))

(df match-unquote (x|<lst> fail|<fun>)
  (if (nul? x)
      (fail "Match Failure Nul List on Unquote")
      (head x)))

(df match-atom (x|<lst> pat fail|<fun>)
  (if (nul? x)
      (fail "Match Failure Nul List on %=" pat)
      (let ((exp (head x)))
        (if (== exp pat)
            (tail x)
            (fail "Match Failure of %= on %=" exp pat)))))

(df match-sublist (x|<lst> fail|<fun>)
  (def x (head x))
  (if (isa? x <lst>)
      x
      (fail "Match Failure on Sub List on %=" x)))

(dm cat-sym (x|...  => <sym>)
  (as <sym> (fold (fun (r e) (cat r (to-str e))) "" x)))

(dv *gensym-counter* 1000)

(dm gensym (=> <sym>)
  (cat-sym "x-" (incf *gensym-counter*)))

(dm fab-setter-name (x|<sym> => <sym>)
  (cat-sym x "-setter"))

(dm var-name (x|<sym>) x)

(dm var-name (x|<lst>) (elt x 0))

(dm var-type (x|<sym>) '<any>)

(dm var-type (x|<lst>) (elt x 1))

(export
  match-nul-list
  match-unquote
  match-atom
  match-sublist
  cat-sym
  *gensym-counter*
  gensym
  fab-setter-name
  var-name
  var-type
)
