;; the CAT language. modeled after the one in brood.

;; TODO:
;; - control structures: for each?
;; - bring over library code



(module catlib mzscheme

  (require-for-syntax
   (lib "match.ss"))
  
  (require
   (lib "match.ss")

   "list-utils.ss"
   "tree-utils.ss"
   "binary-utils.ss"
   "io-utils.ss"
   "word.ss"
   "dict.ss"
   "vm.ss"
   "writer.ss"
   "catcomp.ss"
   )

  (provide (all-defined))


  ;; enter CAT from scheme. this saves the continuation.

  (define (run-source source stack)
    (run-program (cat-parse-default source) stack))



  ;; manually defined primitives

  (define-word drop     (a . stack) stack)
  (define-word dup      (a . stack) (pack a a stack))
  (define-word swap     (a b . stack) (pack b a stack))
  (define-word over     (a b . stack) (pack b a b stack))

  (define-word rot      (a b c . stack) (pack c a b stack))
  (define-word -rot     (a b c . stack) (pack b c a stack))

  (define-word choose (false true condition . stack)
    (pack (if condition true false) stack))

  ;; i'm not sure wether this is right, or i should reverse it..
  (define-word stack    stack        (list stack))
  (define-word stack@   stack        (cons stack stack))
  (define-word stack!   (s . stack)  s)

  
  (define-word swap     (a b   . stack) (pack b a stack))
  (define-word uncons   (l     . stack) (pack (cdr l) (car l) stack))

  (define-word unlist   (l . stack) (fold cons stack l))

  (define-word nop stack stack)

  (define-word union         (a b . stack) (pack (lset-union eq? a b) stack))
  (define-word intersection  (a b . stack) (pack (lset-intersection eq? a b)
                                                 stack))
  (define-word difference    (a b . stack) (pack (lset-difference eq? b a) stack))

  (define-syntax number/logic
    (syntax-rules ()
      ((_ name number logic)
       (define-word name (a b . stack)
         (pack (if (number? a)
                   (number a b)
                   (logic a b)) stack)))))

  (number/logic or  bitwise-ior or)
  (number/logic and bitwise-and and)

  (define-word xor (a b . stack) (pack (bitwise-xor a b) stack))
  ;; (number/logic xor bitwise-xor xor)

  (define-word not (a . stack)
    (cons
     (if (number? a)
         (bitwise-xor -1 a)
         (not a))
     stack))

  (define-word max (a b . stack) (cons (if (> a b) a b) stack))
  (define-word min (a b . stack) (cons (if (< a b) a b) stack))

  ;; control 
  (define-word dip (code thing . stack)  ;; called 'dip' in Joy
    (pack thing (run-program code stack)))


  ;; maybe use fold instead?
  (define-word map (code lst . stack)
    (pack
     (map (lambda stack-1
            (car (run-program code stack-1))) lst) stack))

  ;; i'm separating fold and iterate. i think fold is not tail-call
  ;; safe. ???

  (define (make-fold fn)
    (lambda (head tail)
      (car (run-program fn (list tail head)))))

  (define-word fold (fn init lst . stack)
    (pack (fold (make-fold fn) init lst) stack))

  (define-word fold-right (fn init lst . stack)
    (pack (fold-right (make-fold fn) init lst) stack))




  (define-word for-each (code lst . stack)
    (interpret-list (lambda (item stack)
                      (run-program code (pack item stack)))
                    car cdr null?
                    lst stack))

  (define-word for (code times . stack)
    
    (interpret-list (lambda (n stack) (run-program code stack))
                    (lambda (n) #f)      ;; car (ignored)
                    (lambda (n) (- n 1)) ;; cdr
                    (lambda (n) (< n 1)) ;; null?
                    times stack))



  ;; infra: execute a function in an isolated stack
  (define-word reverse-infra (code tempstack . stack)
    (pack (run-program code tempstack) stack))


  ;; error logging
;;   (define *cat-log* "cat.log")
;;   (define (cat-log thing)
;;     ;; log it if its a scheme error
;;     (let ((port (open-output-file *cat-log* 'append)))
;;       (file-stream-buffer-mode port 'line)
;;       (display
;;        (if (exn? thing)
;;            (exn-message thing)
;;            thing) port)
;;       (newline port)
;;       (close-output-port port)))

  (define (cat-log thing) #f) ;; disabled

  ;; error handling
  (define-word catch (tag handler code . stack)
    (with-handlers
        (((lambda (ex)
            (or (eq? tag #t) ;; catch all
                (and (list? ex)
                     (eq? tag (car ex)))))
          (lambda (ex)

            (cat-log ex)
            
            ;; translate it
            (run-program handler
                         (pack
                          (cond
                           ((exn:fail:contract:arity? ex) (exn-message ex))
                           ((exn:fail:contract? ex)       (exn-message ex))
                           ((exn:break? ex) '(user-break))
                           ((exn? ex) (list ex (exn-message ex)))
                           ((not (list? ex)) (list ex))
                           (else ex))
                          stack)))))
      (run-program code stack)))

  (define-word format (fmt lst . stack)
    (pack
     (apply format (cons fmt lst)) stack))


  ;; create a list of n elements
  (define-word list (elements . stack)
    (let next ((n elements)
               (s stack)
               (l '()))

      (if (zero? n)
          (pack l s)
          (next (- n 1)
                (cdr s)
                (cons (car s) l)))))

  (define-word list->vector (lst . stack)
    (pack (apply vector lst) stack))


  ;; dictionary
  (define-word dict-find  (dict tag . stack)
    (pack (dict-find dict tag) stack))
  (define-word dict-find-recursive  (dict tag . stack)
    (pack (dict-find-recursive dict tag) stack))

  (define-word dict-mute   (dict tag item . stack)
    (pack (dict-mute dict tag item) stack))
  (define-word dict-mute-recursive   (dict tag item . stack)
    (pack (dict-mute-recursive dict tag item) stack))


  (define-word dict-shadow (dict tag item . stack)
    (pack (dict-shadow dict tag item) stack))

  (define-word dict-remove (dict tag . stack)
    (pack (dict-remove dict tag) stack))



  ;; special
  (define-word run     (code . stack) (run-program code stack))
  (define-word execute (code . stack) (run-word      code stack))

  ;; universal compilation binder routine. translate source + syntax +
  ;; semantics to executable code.

  (define-word parse-cat (lst . stack)
    (pack (cat-parse cat-find lst) stack))

  ;; uncompile. strip a parsed/compiled program from all meta information.
  (define-word data (lst . stack)
    (pack (program->list lst) stack))


  (define-word load (filename . stack)
    (load filename) stack)


  (define-word nil     stack (pack '() stack))
  
;;   (define-word cat!    (code . stack)
;;     (let ((name (car code))
;;           (body (cdr code)))
;;       (cat-register! name
;;                      (atom->word code
;;                                  cat-parse-default)))
;;     stack)
  
  (define-word throw   (e . stack) (raise e))

  (define-word with-output-to-file (filename code . stack)
    (if (file-exists? filename)
        (delete-file filename))
    (with-output-to-file filename
      (lambda ()
        (run-program code stack))))
  


  (define-word read-byte  (port . stack)
    (cons (read-byte-progress port 1 progress) stack))

  (define-word write-byte (port byte . stack) 
    (write-byte byte port)
    stack)




  (define-word amb-choose (save later now . stack)
    (call/cc
     (lambda (return)
       (let ((backtrack
              (list
               (procedure->word '*continuation*
                                (lambda _ignored_
                                  (return (pack later stack)))))))
         (pack now
               (run-program save
                            (pack backtrack stack)))))))
  

                                        ; I/O
  (define-word display (thing . stack) (display thing) stack)
  (define-word print   (thing . stack) (print thing) stack)

  (define-word lex-stream (p . stack)
    (let next ((l '()))
      (let ((thing (read p)))
        (if (eof-object? thing)
            (pack (reverse l) stack)
            (next (cons thing l))))))


  (define-word read-line stack
    (cons (read-line) stack))


  ;;   (let* ((c (current-output-port))
  ;;          (p (port-display-handler c)))
  ;;     (port-display-handler
  ;;      c
  ;;      (lambda (thing port)
  ;;        (p 
  ;;         (if (word? thing)
  ;;             (format "w:~s" (word-source thing))
  ;;             thing) c))))
  

  ;; hmm.. no special handler, but do it in print-stack..

  ;; recurse down the hierarchy
  (define (unparse tree)
    (let down ((thing tree))
      (cond
       ((word? thing) (unparse (word-source thing)))
       ((list? thing) (map down thing))
       (else thing))))
  

  (define-word printf-stack (fmt s . stack)
    (printf "<~s>" (length s))
    (for-each
     (lambda (item)
       (printf fmt ;; " ~s"
               (unparse item)))
     (reverse s))
    (printf "\n")
    stack)
    

  (define-word write-tree (tree . stack)
    (write-tree tree) stack)

  (define-word stdin stack (pack (current-input-port) stack))

  (define-word exit (code . stack) (exit code))    
  
                                        ; snarfed primitives
  (cat-snarfs
   
   ((a b)    (= < > >= <= + - * / modulo <<< >>>
                eq? eqv? equal? cons append
                string-append list->table))

   ((a)      (exp log sin cos tan 2/ <<))


   ((thing)  (symbol? number? null? procedure? string? list? pair?
                      vector? eof-object?))

   ((lst)    (reverse flatten car caar caaar cdr cadr cddr
                      list->string list->bytes eval))

   ((number) (round floor ceiling inexact->exact exact->inexact
                    integer->char))

   ((symbol) (symbol->string))

   ((str)    (string->list string->symbol))
   
   ((fname)  (open-io-device open-input-string open-input-file))
   ((port)   (read))

   )

  (define-word delete-file (filename . stack)
    (delete-file filename)
    stack)

  (define-word rename-file-or-directory (to from . stack)
    (rename-file-or-directory from to)
    stack)

  (define-word close-input-port (port . stack)
    (close-input-port port) stack)

  (define-word close-output-port (port . stack)
    (close-output-port port) stack)

  ;; COMPOSITE CODE

  (compositions
   cat!

   ;; flow control
   (ifte      choose run)
   (if        () ifte)
   (unless    () swap ifte)
   (try       #t catch)        ;; catch all exceptions
   (forever   dup dip forever) ;; loop forever (until exception)
   (need      over (drop) (throw) ifte)
   

   ;; file
   (try-delete-file  (delete-file) (drop drop) try)

   (2dip      (cons) dip dip uncons)
   (infra     reverse-infra reverse)

   ;; constants
   (true      #t)
   (false     #f)

   ;; math
   (pow       log * exp)
   
   ;; stacks & lists & vectors
   (swons     swap cons)
   (unswons   uncons swap)
   (2dup      over over)
   (nip       swap drop)
   (vector    list list->vector)
   (cycle     uncons reverse cons reverse)
   (sd        stack drop)

   ;; printing
   (cr       "\n" display)
   (space    " "  display)
   (tab      "\t" display)
   (p        print space)
   (d        display space)
   
   (p-error  "\nERROR:" d d cr)
   (pl       (p cr) for-each)
   (ps       stack@ print-stack)

   (print-stack " ~s" printf-stack)

   ;; files
   (read-file  open-input-file   lex-stream)
   (lex-line   open-input-string lex-stream)


   ;; toplevel interpreter. need CPS because catch is not proper tail
   ;; recursive.
   
   ;; (bye   '(bye) throw)

   (bye    1 exit) ;; FIXME: toplevel error never returns exit error
   (go-cat (stdin read command (go-cat)) ;; ok? -> go again
           (dup car 'bye eq?
                ((drop))            ;; bye? -> done
                (p-error (go-cat))  ;; other -> print + go again
                ifte)
           #t catch  ;; perform one read/execute loop
           run)      ;; execute continuation  (go-cat) or (drop)
   
   ;; introspection and interpretation: it's possible to construct cat
   ;; programs on the fly. however, compared to joy, code does need to
   ;; be parsed from data -> code before it can be 'run'.
   
   (parse     parse-cat)               ;; source -> program
   (postpone  () cons parse)           ;; source atom -> program
   (compose   append)                  ;; programs are lists
   (curry     (postpone) dip compose)  ;; (source atom, program) -> program
   (interpret parse run)               ;; execute source code
   (command   postpone run)            ;; execute source code atom

   ;; 'postpone' means what it means in forth, but more general:
   ;; convert a source atom to something that when invoked causes the
   ;; referred behaviour. since cat doesn't handle #<word> structures,
   ;; the result is wrapped in a list.
   
   ;; symbolic interpretation (Joy). this is different from
   ;; 'interpret' in that data never gets parsed. (wrapped in a
   ;; #<word>)
   
   (i (dup symbol? (command) if) for-each)

   ;; for joy, the smallest quine is '((dup cons) dup cons)'
   ;; for cat, it is '((dup curry) dup curry)'
   ;; note that 'curry' is equivalent to 'cons parse'


   )

)