;; Primitives for the base CAT language. This should bring the
;; language up to a point where it is useful to start writing
;; programs. It supports the BADNOP compiler.

(module base mzscheme

  (require

   ;; This module installs CAT language beef using the syntactic
   ;; skeleton and run time name space infrastructure defined in

   "primitive.ss"
   "composite.ss"
   "ns-base-stx.ss"
   "rep.ss"
   "ns.ss"
   
   ;; by creating primitives, and snarfing functionality from standard
   ;; scheme procedures and functionality defined in

   "binary-utils.ss"
   "list-utils.ss"
   "tree-utils.ss"
   "io-utils.ss"
   "dict.ss"
   "debug.ss"
   "rpn-eval.ss"

   (lib "pretty.ss") ;; .


   (lib "control.ss")
   
   )

  (provide base: !base:)


  ;; The namespace and base: anonymous compiler.

  ;; Note: it's a good thing to define anonymous compilers in the same
  ;; module where the namespace is created (and possibly
  ;; populated). For the reason that there is no other dependency
  ;; tracking available. The convention is that a xxx: macro and its
  ;; name space (xxx) is found in the module xxx.ss

  ;; (ns-new  '(base))
  (ns-base-stx (base:) ((base)))

  ;; For debugging convenience at the command line, this is a macro
  ;; for defining named code. It returns the value of the defined code
  ;; so it fits the normal 'language:' behaviour, though has a side
  ;; effect.

  ;; This is ONLY a notational shortcut to make life easier. Don't use it!

  (define-syntax !base:
    (syntax-rules ()
      ((_ name . body)
       (let ((word (base: . body)))
         (ns-set! '(base name) word)
         word))))
  

  ;; Code and data asserts.

  ;; These used to do automatic conversion, which is 'too smart'.

  ;; The reason why you would want that is for reflection: to be able
  ;; to modify code by processing it as data (like in Joy).

  ;; If there would be a single semantics, this could be made
  ;; possible. In that case compilation would be just a cache, and
  ;; code always looks like data, and vise versa.

  ;; However, i'm using at least 3 different languages: a base
  ;; functional language, a `state-threading' monadic language and a
  ;; postponed forth code language. This breaks the 1-1
  ;; correspondence so automatic conversion is not possible.

  ;; There is a module joy.ss which defines an interpreter for playing
  ;; with this kind of reflection. I'm embracing the abstract
  ;; representation, and define word 'compose' to reach the same goal.

  (define (code x)
    (unless (word? x)
      (error 'not-executable "~a" x))
    x)

  (define (data x)
    (when (word? x)
      (error 'not-data "~a" x))
    x)

  ;; Compose assumes you know what you're doing: it ignores
  ;; semantics. I'm not sure wether i want to see the source code
  ;; appended though...

  (define (compose f g)
    (make-word
     (word-semantics g)   ;; seems sanest
     (append
      (word-source f)     ;; maybe i should just concat...
      (word-source g))
     (lambda s
       (apply g (apply f s)))))

  ;; Partial application (conspose). The closest thing to closures. I
  ;; feel no need for 'quote' as in Joy. Just use "() cns". Here it is
  ;; possible to relativly unambiguously create a source rep.

  (define (cns a f)
    (make-word
     (word-semantics f)
     (cons a (word-source f))
     (lambda s
       (apply f (cons a s)))))


  ;; Direct stack access. Use these functions to give proper error
  ;; handling.

  (define (need-pair s)
    (unless (pair? s) (error 'stack-underflow)))

  (define (stack-car s) (need-pair s) (car s))
  (define (stack-cdr s) (need-pair s) (car s))
    

  ;; DEBUG
                                   
  (define-word ctrace s
    (cons
     (continuation-mark-set->list
      (current-continuation-marks)
      'word) s))
                                      
             


  ;; FIXME

  
  ;; PRIMITIVES

  ;; These are language primitives that can't be directly snarfed from
  ;; scheme functions. The implementation is exposed here: we map the
  ;; input argument list to an single output list value.

  (define-word run    (fn . s)     (apply (code fn) s))
  (define-word dip    (fn a . s)   (cons a (apply (code fn) s)))

  (define-word id     s            s)
  
  (define-word stack@ s            (pack s s))
  (define-word stack! (new . s)    new)
  (define-word stack  s            (list s))
  
  (define-word drop   (a . s)      s)
  (define-word dup    (a . s)      (pack  a a  s))
  (define-word swap   (a b . s)    (pack  b a  s))
  (define-word swap3  (a b c . s)  (pack  c b a  s))
  (define-word over   (a b . s)    (pack  b a b  s))
  (define-word rot    (a b c . s)  (pack  c a b  s))
  (define-word -rot   (a b c . s)  (pack  b c a  s))

  (define-word rot4   (a b c d . s) (pack d a b c  s))
  (define-word -rot4  (a b c d . s) (pack b c d a  s))
  
  
  (define-word uncons (pair . s)
    (let ((p (data pair)))
      (pack (cdr p) (car p) s)))

  
  (define-word cons   (kdr kar . s)   (pack (cons kar kdr) s))
  (define-word append (tail head . s) (pack (append (data head) (data tail)) s))
  
  
  (define-word union         (a b . s) (pack (lset-union eq? a b) s))
  (define-word intersection  (a b . s) (pack (lset-intersection eq? a b) s))
  (define-word difference    (a b . s) (pack (lset-difference eq? b a) s))

  (define-word and  (a b . s) (pack (if (number? a) (bitwise-and a b) (and a b)) s))
  (define-word or   (a b . s) (pack (if (number? a) (bitwise-ior a b) (or a b)) s))

  (define-word not  (a . s)   (pack (not a) s))  ;; use -1 xor for bitwise
  
  
  (define-word unlist (l . s)      (fold cons s (data l)))
  (define-word nil    s            (cons '() s))

  (define-word format (fmt l . s) (pack (apply format fmt l) s))
  (define-word read-byte   (p . s)   (cons (read-byte-timeout p 1) s))
  (define-word write-byte  (p b . s) (write-byte b p) s)


  ;; prefix list ops with 'data' call
  (define-syntax define-list-words
    (syntax-rules ()
      ((_) #f)
      ((_ name n+ ...)
       (begin
         (define-word name (l . s) (cons (name (data l)) s))
         (define-list-words n+ ...)))))

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

  
  ;; FILE SYSTEM
  (define-word with-output-to-file/safe (file fn . s)
    (with-output-to-file/safe
     file
     (lambda () (apply (code fn) s))))

  (define-word with-io-device (device fn . s)
    (with-io-device
     device
     (lambda () (apply (code fn) s))))               


  ;; call/cc     (fn -- )

  ;; Push the current continuation on the stack, and execute fn. The
  ;; continuation when invoked, passes the whole stack.

  (define-word call/cc (fn . stack)
    (call/cc
     (lambda (k)
       (apply fn
              (cons
               (pn-lambda-annotate
                '*continuation*
                s (k s))
               stack)))))
              
  

  ;; amb-choose  (now later save -- now/later)

  ;; It creates a continuation in the form of a primitive (bound to
  ;; 'backtrack') below, amnd executes the 'save' method to store the
  ;; continuation value somewhere. Then in will return with 'now'
  ;; pushed to the stack. When the backtrack primitive is invoked,
  ;; 'later' is pushed to the stack and the computation is restarted.

  (define-word amb-choose (save later now . stack)
    (call/cc
     (lambda (return)
       (let ((backtrack
              (pn-lambda-annotate
               '*continuation* ;; annotation
               _ignored_       ;; arguments ignored
               (return         ;; invokes stored continuation
                (cons later stack)))))
         (cons now
               (apply (code save)
                      (cons backtrack stack)))))))

  ;; Similar, but using escaping continuations: here the continuation
  ;; can be stored in a dynamic parameter, so it doesn't need to be
  ;; passed explicitly like with amb-choose.

  ;; FIXME: read up on general prompts. to me call/ec seems 'enough'.

  (define escape
    (make-parameter
     (lambda ()
       (error 'no-alternative))))

  ;; does it drop or not? -> no: it's usually a check inserted after
  ;; something that returns a value or false.
  (define-word check s
    (if (car s) s ((escape))))

  (define (attempts lst . s)
    (if (null? lst)
        (error 'attempt-clauses-exhausted)
        (call/ec
         (lambda (esc)
           (parameterize
               ((escape
                 (lambda ()
                   (esc
                    (apply attempts
                           (cdr lst) s)))))
             (apply (code (car lst))
                    s))))))
  
  (define (attempt alt pri . s)
    (apply attempts (list pri alt) s))
                 
  (define-word attempt s (apply attempt s))
  (define-word attempts s (apply attempts s))


     

  ;; Exception handling using 'catch'. If the 'body' code generates an
  ;; exception that is tagged with 'tag', the 'handler' code is
  ;; invoked with the exception value pushed to the stack.
  
  (define-word catch (tag handler body . s)
    (with-handlers
        (((lambda (ex)
            (or (eq? tag #t) ;; catch all
                (and (list? ex)
                     (eq? tag (car ex)))))
          (lambda (ex)
            (apply (code handler)
                   (cons (pretty-exn ex) s)))))
      (apply (code body) s)))


  ;; Toplevel (repl) run with error thranslation: this does not run in
  ;; tail position.

;;   (define (exn-print-stack-trace ex)
;;     (printf "TRACE:\n")
;;     (let ((stack
;;            (continuation-mark-set->list
;;             (exn-continuation-marks ex)
;;             'word)))
;;       (for-each
;;        (lambda (w)
;;          (pretty-print (word-source w)))
;;        stack)))


  ;; extract the (name . srcloc) list representing the stack frame
;;   (define (exn-print-stack-trace ex)
;;     (pretty-print
;;      (continuation-mark-set->context
;;       (exn-continuation-marks ex))))

;;   ;; use the default handler to print a stack trace
;;   (define (exn-print-stack-trace ex)
;;     ((error-display-handler)
;;      (exn-message ex)
;;      ex))

  
;;   (define *print-trace* #t)
;;   (define-word trace-on  s  (set! *print-trace* #t) s)
;;   (define-word trace-off s  (set! *print-trace* #f) s)

;;   (define-word run/error (fn . s)
;;     (with-handlers
;;         ((exn:fail?
;;           (lambda (ex)
;;             (if *print-trace*
;;                 (begin
;;                   (exn-print-stack-trace ex)
;;                   ;; don't propagate? return stack instead?
;;                   s)
;;                 ;; propagate error
;;                 (raise ex)))))
;;       (apply (code fn) s)))

  ;; FIXME: error capture disabled here: handle somewhere else.
  (define-word run/error (fn . s)
    (apply (code fn) s))
  
  
         
;;   (define-word run/error (fn . s)
;;     (let ((ret-s
;;            (begin
;;              (printf "with-prompt\n")
;;              (prompt
;;               (apply (code fn) s)))))
;;       (if (list? ret-s) ;; check return value
;;           ret-s
;;           (begin
;;             (printf "returning original stack\n")
;;             s))))
  
  ;; The combinators map and fold run in an isolated stack, and take
  ;; only the top element. This is a bit strange. Never just throw
  ;; away data, so the return type is checked.

  (define (just-one x)
    (when (or (null? x)
              (not (null? (cdr x))))
      (error 'multiple-return-values "~a" x))
    (car x))

  
  (define-word map (fn l . s)
    (let ((f (code fn)))
      (cons
       (map
        (lambda (x)
          (just-one (f x)))
        l)
       s)))


  ;; The universal fold. The prototype is analogous to that of
  ;; for-each, which is left fold.
  
  (define-word fold-right (fn l i . s)
    (let ((f (code fn)))
      (cons
       (fold-right
        (lambda (kar kdr)
          (just-one (f kdr kar)))
        i l)
       s)))

  ;; A function that behaves like 'map', but operates on a list of
  ;; stacks.

  (define-word stack-map (fn ss . s)
    (let ((f (code fn)))
      (cons (map (lambda (x) (apply f x)) ss) s)))
  

  ;; General state accumulation with proper tail recursion. Maybe this
  ;; should be called fold? Not really, since it can't express right
  ;; fold..

  ;; - abstract interpretation of an abstract list
  ;; - the last element is called in tail position

  ;; it's easier to test zero case up front

  ;; NOTE: symbols are used more than once, so best to use variables.
  
  (define-syntax interpret-list
    (syntax-rules ()
      ((_ interpret         ;; abstract code interpretation
          car cdr null?     ;; abstract list access
          lst               ;; code sequence
          state)            ;; state accumulator

       (if (null? lst)
           state                            ;; nop
           (let next ((l lst)
                      (s state))
             (let ((kar (car l))
                   (kdr (cdr l)))
               (if (null? kdr)
                   (interpret kar s)        ;; tail call
                   (next kdr                ;; recursive call
                         (interpret kar s)))))))))

  ;; for-each really is left fold. 
  
  (define-word for-each (fn l . s)
    (let ((fnc (code fn)))
      (define (interpret i s) (apply fnc (cons i s)))
      (interpret-list interpret
                      car cdr null?
                      l s)))

  (define-word for (fn n . s)
    (let ((fnc (code fn)))
      (define (interpret _ignored_ s) (apply fnc s))
      (define (car n)   '_ignored_)
      (define (cdr n)   (- n 1))
      (define (null? n) (< n 1)) 
      (interpret-list interpret
                      car cdr null?
                      n s)))

  (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))))))


  

  ;; SNARFS

  (define (->string x) (format "~a" x))
  

  ;; These get functionality straight from scheme with minimal
  ;; hassle. below '+' means define word '+' using scheme's '+' and
  ;; (choose if) means, define word 'choose' using scheme's 'if'.
  
  (snarf as-push (base)

     ((d t)    (dict-find dict-find/false dict-recursive-find))    
     ((d t i)  (dict-set dict-shadow dict-recursive-mute))

     
     ((a b)    (= < > >= <= + - * / modulo <<< >>>
                eq? eqv? equal?
                string-append list->table
                min max))

     ((a b)    ((xor bitwise-xor)))

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

     ((path)   (ns-ls ns-ref))


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

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

     ((symbol) (symbol->string))

     ((str)    (string->list string->symbol bytes->string/utf-8))
   
     ((fname)  (open-input-string open-input-file))
     ((port)   (read))     

     ((c a b)   ((choose if)))

     ((word)   (word-source))

     ;; For run time compilation to work, the appropriate modules need
     ;; to be loaded into the runtime compiler namespace using
     ;; 'rpn-modules'.
     
     ((code compiler) (rpn-compile))
     ((modules)       (rpn-modules))


     ((f s) (apply))

     ((f g) (compose))
     ((a f) (cns))       ;; partial application

     (()    (in current-process-milliseconds cpm-mark))

     
    )

  
  (define cpm-mark
    (let ((ms 0))
      (lambda ()
        (let*
            ((now   (current-process-milliseconds))
             (delta (- now ms)))
          (set! ms now)
          delta))))
  
  ;; Side-effecting words.
  
  (snarf as-void (base)

    ((datum)     (write display print write-tree pretty-print))
    ((s fmt)     (printf-stack))
    ((exception) ((throw raise)))
    ((filename)  (delete-file close-input-port close-output-port load))
    ((to from)   (rename-file-or-directory))

    ((byte)      (out)))


     
  
  ;; COMPOSITE CODE

  (compositions
   (base) base:


   ;; 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)
   
   (1-throw   ('() cons) dip swons throw)
   (2run      (run) dip run)

   ;; 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)
   (pp       pretty-print)
   
   ;; (p-error  "\nERROR:" d d cr)
   (pl       (p cr) for-each)

   (hs       stack@ print-stack) ;; host stack

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

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


   

   ;; CODE / DATA


   (:base     'base: rpn-compile)   ;; source -> program
   (source    word-source)          ;; get source code, discard semantics
   (semantics word-semantics)


   ;; MONADS

   ;; The 'lift' operation (a.k.a. the 'map' operation) is the only
   ;; one that can be made ignorant of the monad type, given that
   ;; monad state is always implemented as the top of the data stack.

   ;; The other operations: 'join' and 'return' need to be
   ;; monad-specific. Since I don't have type classes, i'm stuck with
   ;; name tagging. But, I didn't run into uses for this.


   ;; This will only work for base syntax.
   (lift   unrun:base (dip) compose)
   

   
   
   )

  
  )