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

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/packer)
(use goo/types)
(use goo/any)
(use goo/log)
(use goo/chr)
(use goo/mag)
(use goo/math)
(use goo/io/port)
(use goo/cols)
(use goo/conditions)
(use goo/io/read)
(use goo/packer)
(use goo/late-macros)

(ddv *max-print-depth*  4)

(ddv *max-print-length* 12)

(dm as-binding-name (name) 
  (as <str> name))

(dm do-emit (port|<out-port> x|<str> d|<int> recur|<fun>)
  (puts port x))

(dm do-emit (port|<out-port> x|<chr> d|<int> recur|<fun>)
  (put port x))

(dm do-emit (port|<out-port> x d|<int> recur|<fun>)
  (recurring-write port x d recur))

(dm emit (port|<out-port> x)
  (rep recur ((x x) (d -1))
    (if (>= d *max-print-depth*)
        (puts port "*")
        (do-emit port x (+ d 1) recur))))

(dm write-to-string (x => <str>)
  (port-to-str port (write port x)))

(dm write (port|<out-port> x)
  (rep recur ((x x) (d -1))
    (if (>= d *max-print-depth*)
        (puts port "*")
        (recurring-write port x (+ d 1) recur))))

(dm writeln (port|<out-port> x)
  (write port x) (newline port))

(dm recurring-write (port|<out-port> x|<lst> d|<int> recur|<fun>)
  (if (nul? x)
      (puts port "()")
      (write-list port x d recur)))

(dm recurring-write (port|<out-port> x|<flat> d|<int> recur|<fun>)
  (def prefix (cat "$$" (as <str> (class-name (class-of x))) "("))
  (write-flat port prefix x ")" d recur))

(dm recurring-write (port|<out-port> x|<tup> d|<int> recur|<fun>)
  (write-flat port "#(" x ")" d recur))

(dm recurring-write (port|<out-port> x|<vec> d|<int> recur|<fun>)
  (write-flat port "#[" x "]" d recur))

(dm recurring-write (port|<out-port> x|<map> d|<int> recur|<fun>)
  (write-map port x d recur))

(dm recurring-write (port|<out-port> x|<log> d|<int> recur|<fun>)
  (if x
      (write-boolean port 't)
      (write-boolean port 'f)))

(dm recurring-write (port|<out-port> x|<sym> d|<int> recur|<fun>)
  (puts port (as <str> x)))

(dm recurring-write (port|<out-port> x|<loc> d|<int> recur|<fun>)
  (puts port "&0x")
  (puts port (num-to-str-base (%ib (%lu x)) 16)))

(dm recurring-write (port|<out-port> x|<num> d|<int> recur|<fun>)
  (if (== x <num>)
      (puts port (as-binding-name "<num>"))
      (write-number port x)))

(dm recurring-write (port|<out-port> x|<str> d|<int> recur|<fun>)
  (write-string-literal port x))

(dm recurring-write (port|<out-port> x|<chr> d|<int> recur|<fun>)
  (write-char-literal port x))

(dm write-boolean (port|<out-port> mumble)
  (put port #\#)
  (write port mumble))

(dm write-number (port|<out-port> x|<num>)
  (puts port (num-to-str x)))

(dm write-char-literal (port|<out-port> x)
  (def probe (character-name x))
  (puts port "#\\")
  (if probe
      (write port probe)
      (put port x)))

(dm character-name (char|<chr> => <any>)
  (def assoc (assqn char $char-long-names 1))
  (and assoc (1st assoc)))

(dm write-string-literal (port|<out-port> x)
  (put port #\")
  (def len (len x))
  (rep loop ((i 0))
    (if (= i len)
        (put port #\")
        (let ((c (elt x i)))
          (if (or (= c #\\) (= c #\"))
              (put port #\\))
          (put port c)
          (loop (+ i 1))))))

(dm write-list (port|<out-port> x|<lst> d|<int> recur|<fun>)
  (if (quotation? x)
      (seq (put port #\')
           (recur (head (tail x)) d))
      (seq (put port #\()
           (recur (head x) d)
           (rep loop ((l (tail x)) (n 1))
             (unless (nul? l)
               (if (>= n *max-print-length*)
                   (puts port " ...")
                   (seq (put port #\space)
                        (recur (head l) d)
                        (loop (tail l) (+ n 1))))))
           (put port #\) ))))

(dm quotation? (x => <log>)
  (and (isa? x <lst>) 
       (== (head x) 'quote)
       (isa? (tail x) <lst>)
       (nul? (tail (tail x)))))

(dm write-flat 
    (port|<out-port> prefix|<str> x|<flat> suffix|<str> d|<int> recur|<fun>)
  (puts port prefix)
  (def z (len x))
  (when (> z 0)
    (recur (elt x 0) d)
    (rep loop ((i 1))
      (if (>= i *max-print-length*)
          (puts port " ...")
          (unless (>= i z)
            (put port #\space)
            (recur (elt x i) d)
            (loop (+ i 1))))))
  (puts port suffix))

(dm write-map (port|<out-port> x|<map> d|<int> recur|<fun>)
  (puts port "#<")
  (emit port (class-name (class-of x)))
  (esc blow
    (for (((tup key val) x) (i (from 0)))
      (when (>= i *max-print-length*)
        (puts port " ...") (blow #f))
      (put port #\space)
      (recur key d)
      (puts port ": ")
      (recur val d)))
  (put port #\>))

(dm recurring-write (port|<out-port> x|<file-in-port> d|<int> recur|<fun>)
  (msg port "#{File-in-port %s %d}" (port-filename x) (port-line x)))

(dm recurring-write (port|<out-port> x|<file-out-port> d|<int> recur|<fun>)
  (msg port "#{File-out-port %s}" (port-filename x)))

(dm recurring-write (port|<out-port> x|<in-port> d|<int> recur|<fun>)
  (puts port "#{In-port}"))

(dm recurring-write (port|<out-port> x|<out-port> d|<int> recur|<fun>)
  (puts port "#{Out-port}"))

;; TODO: CHANGE C IMPLEMENTATION

(dm write-params (port|<out-port> x|<fun> recur|<fun>)
  (def names (fun-names x))
  (put port #\()
  (def names (fun-names x))
  (for ((i (from 0)) (spec (fun-specs x)) (first? (first-then (op #t) (op #f))))
    (unless first? (put port #\space))
    (if (nul? names)
        (write-type port spec)
        (seq (msg port "(%s " (as <str> (elt names i)))
             (write-type port spec)
             (put port #\)))))
  (def value (fun-val x))
  (unless (or (not value) (== value <any>))
    (msg port " => ") (write-value-type port value))
  (put port #\)))

(dm write-fun-guts (port|<out-port> x|<fun> name|<str> recur|<fun>)
  (puts port "#{")
  (puts port name)
  (def name (fun-name x))
  (and name (seq (put port #\space) 
                 (puts port (as <str> name))))
  (put port #\space)
  (write-params port x recur)
  (puts port "}"))

(dm recurring-write (port|<out-port> x|<gen> d|<int> recur|<fun>)
  (write-fun-guts port x "Gen" recur))

(dm recurring-write (port|<out-port> x|<met> d|<int> recur|<fun>)
  (write-fun-guts port x "Met" recur))

(dm recurring-write (port|<out-port> x|<src-loc> d|<int> recur|<fun>)
  (msg out "<SRC-LOC %= %s>" (src-loc-line x) (src-loc-file x)))

(dm recurring-write (port|<out-port> x|<class> d|<int> recur|<fun>)
  (puts port "#{Class ")
  (puts port (as <str> (class-name x)))
  (puts port " ")
  (recur (map class-name (class-parents x)) d)
  (puts port "}"))

(dm recurring-write (port|<out-port> x|<singleton> d|<int> recur|<fun>)
  (puts port "#{T= ")
  (recur (type-object x) d)
  (puts port "}"))

(dm recurring-write (port|<out-port> x|<subclass> d|<int> recur|<fun>)
  (puts port "#{T< ")
  (write-type port (type-class x))
  (puts port "}"))

(dm recurring-write (port|<out-port> x|<union> d|<int> recur|<fun>)
  (puts port "#{T+")
  (do (fun (t) (put port #\space) (write-type port t)) (union-elts x))
  (puts port "}"))

(dm recurring-write (port|<out-port> x|<product> d|<int> recur|<fun>)
  (puts port "#{T*")
  (do (fun (t) (put port #\space) (write-type port t)) (product-elts x))
  (puts port "}"))

(dm write-value-type (port|<out-port> x|<product>)
  (puts port "(tup")
  (do (fun (t) (put port #\space) (write-type port t)) (product-elts x))
  (puts port ")"))

(dm write-value-type (port|<out-port> x)
  (write-type port x))

(dm recurring-write-type (port|<out-port> x|<class> d|<int> recur|<fun>)
  (puts port (as <str> (class-name x))))

(dm recurring-write-type (port|<out-port> x d|<int> recur|<fun>)
  (recurring-write port x d recur))

(dm write-type (port|<out-port> x)
  (rep recur ((x x) (d 0))
    (recurring-write-type port x d recur)))

(dm recurring-write (port|<out-port> x|<prop> d|<int> recur|<fun>)
  (puts port "#{Prop ")
  (recur (prop-getter x) d)
  (puts port "}"))

(dm recurring-write (port|<out-port> x d|<int> recur|<fun>)
  (puts port "#{")
  (emit port (class-name (class-of x)))
  (esc blow
    (without-prop-unbound-errors
      (for ((prop (props-of x)) (i (from 0)))
        (when (>= i *max-print-length*)
          (puts port " ...") (blow #f))
        (def getter (prop-getter prop))
        (put port #\space)
        (emit port (fun-name getter))
        (puts port ": ")
        (recur (getter x) d))))
  (puts port "}"))

(dm recurring-write (port|<out-port> (x (t= (eof-object))) d|<int> recur|<fun>)
  (puts port "#{End-of-file}"))

(dm msg (port|<out-port> message|<str> arguments|...)
  (def found-percent?       #f)
  (def argument-index|<int> 0)
  (def num-arguments        (len arguments))
  (loc ((arg (char|<chr> class|<any> => <any>)
          (def current-index argument-index)
          (set argument-index (+ argument-index 1))
          (assert (< current-index num-arguments)
                  "Too few arguments for msg string %=: %="
                  message arguments)
          (def argument (elt arguments current-index))
            (assert (or (== class <any>) (isa? argument class))
              "Msg argument for directive '%%%c' not of class %t: %="
              char class argument)
            argument))
    (do (fun ((c <chr>))
          (if found-percent?
              (seq (case (to-upper c)
                     ((#\D) (puts port (num-to-str (arg c <num>))))
                     ((#\B) (puts port (num-to-str (arg c <int>) 2)))
                     ((#\O) (puts port (num-to-str (arg c <int>) 8)))
                     ((#\X) (puts port (num-to-str (arg c <int>) 16)))
                     ((#\C) (put port (arg c <chr>)))
                     ((#\S) (emit port (arg c <any>)))
                     ((#\=) (write port (arg c <any>)))
                     ((#\T) (write-type port (arg c <any>)))
                     ((#\%) (put port #\%))
                     (#t    (error "Invalid msg directive '%s' in \"%s\""
                                   c message)))
                   (set found-percent? #f))
              (if (== c #\%)
                  (set found-percent? #t)
                  (put port c))))
        message))
  (assert (not found-percent?)
          "Incomplete msg directive in \"%s\"" message))

(dm post (message|<str> arguments|...)
  (app msg out message arguments))

;;; PARTIAL EVALUATOR FOR MSG 
;;; TODO: SHOULD GO AWAY WHEN REAL PARTIAL EVALUATION IS WORKING 
;;; TODO: SHOULD PROBABLY BE CT-ALSO BUT THEN AST-EVAL KICKS IN

(df pe-msg (port-expr message|<str> args|<lst>)
  (def found-percent?  #f)
  (def arg-index|<int> 0)
  (def num-args        (len args))
  (def chars           (fab <vec> 0))
  (def port            (gensym))
  (def exprs
    (packing
     (loc ((maybe-pack-chars ()
             (unless (nul? chars)
               (pack `(puts ,port ,(as <str> chars)))
               (zap! chars)))
           (arg (char|<chr> => <any>)
             (maybe-pack-chars)
             (def current-index arg-index)
             (set arg-index (+ arg-index 1))
             (assert (< current-index num-args)
                     "Too few arguments for msg string %=: %=" message args)
             (elt args current-index)))
       (do (fun ((c <chr>))
             (if found-percent?
                 (seq (case (to-upper c)
                        ((#\D) (pack `(puts ,port (num-to-str ,(arg c)))))
                        ((#\B) (pack `(puts ,port (num-to-str ,(arg c) 2))))
                        ((#\O) (pack `(puts ,port (num-to-str ,(arg c) 8))))
                        ((#\X) (pack `(puts ,port (num-to-str ,(arg c) 16))))
                        ((#\C) (pack `(put ,port ,(arg c <chr>))))
                        ((#\S) (pack `(emit ,port ,(arg c))))
                        ((#\=) (pack `(write ,port ,(arg c))))
                        ((#\T) (pack `(write-type ,port ,(arg c))))
                        ((#\%) (add! chars #\%))
                        (#t    (error "Invalid msg directive '%s' in \"%s\""
                                      c message)))
                      (set found-percent? #f))
                 (if (== c #\%)
                     (set found-percent? #t)
                     (add! chars c))))
           message)
       (maybe-pack-chars))))
  (assert (not found-percent?) 
          "Incomplete msg directive in \"%s\"" message)
  `(let ((,port ,port-expr)) ,@exprs))

(ds msg* (,port ,message ,@args)
  (if (isa? message <str>)
      (pe-msg port message args)
      `(msg ,port ,message ,@args)))

;; (ds msg* (,port ,message ,@args)
;;   `(msg ,port ,message ,@args))

(df msg-to-str (message|<str> arguments|... => <str>)
  (with-port (port (open <str-out-port> "")) 
    (app msg port message arguments)
    (port-contents port)))

(df say (port|<out-port> args|...)
  ;; (puts port (fold cat "" (map to-str args)))
  ;; (for ((arg args))
  ;;   (puts port (to-str arg)))
  ;; TODO: MOVE UPWARD WHEN COMPILER SMARTER
  (def lim (len args))
  (rep loop ((i 0))
    (unless (== i lim)
      (puts port (to-str (low-elt args i)))
      (loop (+ i 1)))))

;; (set *debug-tables?* #t)

(export
  msg pe-msg msg*
  msg-to-str
  emit
  write
  write-type
  writeln
  post
  write-to-string
  recurring-write
  *max-print-length*
  *max-print-depth*
  say)
