(module composite mzscheme

  ;; This module contains code to define composite words using the
  ;; 'composite' macro, parameterized by language syntax and
  ;; source/destination symbol semantics.

  (require "rpn.ss"  ;; low level rpn compositional syntax compiler
           "ns.ss")  ;; global hierarchical name space

  (provide compositions
           cat-stx               ;; compositional syntax with global names
           state-stx             ;; lifting syntax for monads
           state-constant        ;; 'apply' a constant in state syntax
           with-default-ns-ref   ;; export only the macro, not the parameter
           )
 ; (provide (all-defined))         


  ;; This implements lowlevel representation interpreter for namespace
  ;; lookup. I can't get my head around putting CAT functions in
  ;; modules, so name -> storage association is just done once at
  ;; runtime using 'force'.

  (define (interpret promise expr)
    (apply (force promise) expr))


  ;; The compile time part which transforms a symbol into a structure
  ;; that can be interpreted by the function above. The search spec is
  ;; a list of possible path names.

  (define (find-paths paths false/nf-thunk)
    (let next ((p paths))
      (if (null? p)
          (if false/nf-thunk (false/nf-thunk) #f)
          (or (ns-ref (car p) #f)
              (next (cdr p))))))

  (define (base-find paths)
    (find-paths paths
                (not-found-in paths)))
          
  (define-syntax find
    (syntax-rules ()
      ((_ paths)
       (delay (base-find 'paths)))))
    


  ;; The compile and runtime behaviour can be combined in a (interpret
  ;; (find ...) ...)  construct to extend the most basic rpn compile
  ;; macro.
  
  (define-syntax ns-compile
    (syntax-rules ()
      ((_ compile ((path ...) ...))
       (define-syntax compile
         (syntax-rules (global)
           ((_ c global s e)   (interpret (find ((path ... s) ...)) e))
           ((_ . msg)          (rpn-compile . msg)))))))
   

  ;; The mechanism for handling undefined symbols is left as a
  ;; parameter. The default raises an exception.

  (define default-ns-ref
    (make-parameter
     (lambda paths
       (raise `(not-found ,paths)))))

  (define (not-found-in . paths)
    (lambda ()
      (apply (default-ns-ref) paths)))


  
  ;; The most common alternative is to replace all undefined symbols
  ;; with some default behaviour.

  (define-syntax with-default-ns-ref
    (syntax-rules ()
      ((_ default expr ...)
       (parameterize
           ((default-ns-ref default))
         expr ...))))
         



  
  ;; The representative of the basic compositional syntax, which used
  ;; in the 'compositions' macro. It uses the macro above to extend
  ;; the basic rpn syntax with global symbols. This macro generates an
  ;; anonymous function compiler macro.

  (define-syntax cat-stx
    (syntax-rules ()
      ((_ anon-fn: . compile-spec)
       (begin
         (ns-compile COMPILE . compile-spec)
         (rpn-transformer anon-fn: COMPILE)))))
  

  ;; The 'compositions' macro is the entry point to the expansion and
  ;; registration code. It takes a destination namespace and either an
  ;; anonymous function compiler as an argument.
  
  (define-syntax compositions
    (syntax-rules ()
      ((_ dst-ns fn: def ...)
       (begin
         (composition dst-ns fn: def)
         ...))))
  
  (define-syntax composition
    (syntax-rules (local)
      
      ((_ dst-ns fn:
          (local ((name . body) ...)
                 (global-defs ...)))
       (letrec ((name (fn: . body)) ...)
         (compositions dst-ns fn:
                       global-defs ...)))
       
      ((_ (ns ...) fn: (name . body))
       (ns-set! '(ns ... name) (fn: . body)))))



  ;; LIFTED SYNTAX AND SEMANTICS

  ;; The brood project makes heavy use of a lifted monadic syntax,
  ;; where 2 namespaces are combined: functions in the monad are
  ;; compiled as before, but functions outside the monad and all
  ;; constants will be lifted, so they ignore the monad state on the
  ;; top of the stack.

  ;; This behaviour is split into 2 parts:

  ;; * perform lifting of global symbols at run time, because that's
  ;;   when the information is available.

  ;; * lift all the constants


  ;; This is the 'map' function from the map/join/unit monad
  ;; formulation, which creates an M a -> M b type from an a -> b
  ;; type.
  
  (define (state-lift word)
    (lambda (state . stack)
      (cons state (apply word stack))))

  ;; The same is done for constants, which are treated separatedly
  ;; from functions in the compiler, and can use a pre-bound method.

  (define (state-constant thing stack)
    (cons (car stack)
          (cons thing (cdr stack))))


  ;; Functions that operate on the state are stored in the
  ;; dictionary. This includes operations like 'join' and 'unit'. All
  ;; the rest is automaticly lifted to just pass the state.

  (define (state/lifted-find state lifted)
    (or (find-paths state
                    #f)
        (state-lift
         (find-paths lifted
                     (not-found-in state
                                   lifted)))))

  (define-syntax state-find
    (syntax-rules ()
      ((_ state lifted)
       (delay
         (state/lifted-find 'state 'lifted)))))
  

  ;; Lexical identifiers always refer to raw state functions, so the
  ;; default rpn-compile semantics is used. Quoted programs are always
  ;; non-lifted default semantics because the default control words
  ;; that expect quoted code are automaticly lifted.
  
  (define-syntax ns-state-compile
    (syntax-rules ()
      ((_ compile ((state ...) ...) ((lifted ...) ...))
       (begin
         (cat-stx default: ((lifted ...) ...))
         (define-syntax compile
           (syntax-rules (global constant program)
             ((_ c constant s e) (state-constant s e))
             ((_ c program l e)  (state-constant (default: . l) e))
             ((_ c global s e)   (interpret
                                  (state-find ((state ... s) ...)
                                              ((lifted ... s) ...)) e))
             
             ((_ . msg)          (rpn-compile . msg))))))))
  

  ;; Create a cat language with lifting using the compile macro
  ;; generated by the macro above.
  
  (define-syntax state-stx
    (syntax-rules ()
      ((_ name . compile-spec)
       (begin
         (ns-state-compile COMPILE . compile-spec)
         (rpn-transformer name COMPILE)))))

  

  
  )