#lang scheme/base


(provide
 forth-tx
 macro-tx
 
 :-tx
 :forth-tx
 :macro-tx
 create-tx

 load-tx
 path-tx
 
 require-tx
 provide-tx
 open-paren-tx
 close-paren-tx

 open-sexp-tx

 ;; forth-toplevel-forms   NOW INTERNAL

 ;; forth-quoter
 forth->records
 forth-rules
 ;; forth->nested-dictionaries

 forth-search-path
 )

(require
 "../tools.ss"
 "../tools-tx.ss"
 "../scat-tx.ss"
 "locals-tx.ss"
 "lexer.ss"         ;; for load-tx
 scheme/control
 syntax/stx
 scheme/pretty
 (for-template
  (lib "match.ss")
  "../scat.ss"
  scheme/base))

;; Parsing words are defined in the transformer environment, and
;; implemented as binary function that behave similar to 'next' in
;; rpn-tx.ss. Delegate can be an expression. If it's an identifier
;; it's mapped.

;; NOTE: this is a bit of a mess: a mix of threaded state (the way the
;; rpn parser works) and some side effects to parameters to perform
;; Forth dictionary bookkeeping. Maintenance of the 'there is always a
;; current definition' invariant is not in a single point.

;; UTIL


;; Syntax-rules equivalent for forth code.
(define-sr (forth-rules (literals ...)
                        ((pattern ...) (template ...)) ...)
  (lambda (stx expr)
    (syntax-case stx (literals ...)
      ((pattern ... . code+)
       ((rpn-next) #`(template ... . code+) expr)) ...)))




;; MODES

;; The RPN transformers 'macro' and 'forth' will switch compilation
;; mode between macros and forth words. The latter are instantiated
;; macros. The mode information is used as a field in dictionary
;; records.

(define current-mode (make-parameter #f))

(define (forth-mode) 'forth)
(define (macro-mode) 'macro)
(define (variable-mode) 'variable)


(define (mode-tx mode)
  (lambda (code expr)
    (current-mode (mode))
    ;; Mode switch terminates a definition.
    ((finalize-current) expr)
    (init-record)
    (collect-next (stx-cdr code))))

(define macro-tx (mode-tx macro-mode))
(define forth-tx (mode-tx forth-mode))

(define (temp sym)
  (car (generate-temporaries (list sym))))


(define (stx-srcloc stx)
  #`(list #,(syntax-source stx)
          #,(syntax-line stx)
          #,(syntax-column stx)
          #,(syntax-position stx)
          #,(syntax-span stx)))

(define forth-search-path (make-parameter '()))

;; DEFINITIONS

;; Note: the scat parser is designed to parse delimited definitions:
;; one syntax list per code quotation. In Forth syntax however,
;; multiple definitions are encoded in a single syntax list. Therefore
;; a parameter is used to accumulate the definitions.


;; Record current definition information, waiting for an expression to
;; be completed. This is called at the start of a definition.
(define (new-record name mode loc)
  ;; (printf "N: ~a ~a ~a\n" name mode loc)
  (finalize-current
   (lambda (expr)
     (register-record
      #`(#,name #,mode #,loc
                #,(rpn-close-expression expr)))
     (finalize-current no-record))))

(define (no-record expr) (error 'no-current-record))
(define finalize-current (make-parameter no-record))

;; Start accumulating a nested expression.
(define (collect-next code)
  ((rpn-next) code (rpn-state)))

;; Definers terminate the previous definition and create a header for
;; the next one.
(define (definer mode)
  (lambda (code expr)
    ((finalize-current) expr)
    (syntax-case code ()
      ((_ name . code+)
       (new-record #'name
                   (mode)
                   (stx-srcloc #'name))
       (collect-next #'code+)))))


(define :-tx         (definer current-mode))

;; modeless
(define create-tx    (definer variable-mode))
(define :macro-tx    (definer macro-mode))
(define :forth-tx    (definer forth-mode))


;; Top driver for parsing forth syntax. Results are accumulated in
;; dynamic parameters: no threaded state here.

(define forth-toplevel-forms (make-parameter '()))
(define forth-records (make-parameter '()))

(define (register-toplevel x)
  (forth-toplevel-forms
   (cons x (forth-toplevel-forms))))

(define (register-record x)
  ;; (printf "R: ~a\n" (syntax->datum x))
  (forth-records
   (cons x (forth-records))))

;; START PARSING

(define (forth->records forth-definitions)
  (parameterize
      ((current-mode (forth-mode))
;;       (forth-search-path '()) ;; shield
       (forth-records '())
       (forth-toplevel-forms '()))
    

    ;; Start parsing effectively by calling represent directly
    ;; (effecitvely prefixing the code with ': #f'). This will
    ;; accumulate toplevel scheme forms and forth records in the
    ;; dynamic parameters.

    (rpn-init ;; We don't use rpn-compile but call rpn-next directly,
              ;; so have to call initializer manually upon entry.
     (lambda ()
       (init-record)
       (let-values
           (((_ last)  ;; _ should be empty
             (collect-next forth-definitions)))
         ((finalize-current) last))
       (let ((records (reverse (forth-records))))
         ;; (pretty-print (map syntax->datum records))
         (cons
          `(#f scheme #f (begin ,@(reverse (forth-toplevel-forms))))
          records))))))
           
(define (init-record [mode current-mode])
  (new-record #f (mode) #f))



;; NESTING

;; In Forth syntax without s-expressions, there is no nesting
;; mechanism: (rpn-next) only returns at the end of the input
;; stream. However, implementing parsers that use scheme function
;; nesting can be done using prompt tags.

(define abort/cc abort-current-continuation)
(define (make-until tag)
  (lambda (code expr)
    ;; (printf "UNTIL: ~a\n" tag)
    (abort/cc tag
              (lambda ()
                (values (stx-cdr code) expr)))))

(define (next-until tag code expr)
  (prompt-at tag
             ((rpn-next) code expr)
             ;; It's not legal to leave nested context by falling off
             ;; the end of a code list.
             (error 'non-terminated-parser-nesting "~a" tag)))


;; CODE QUOTATION

;; Flat code quotation. This is the same as using lists in the
;; s-expression syntax. The open paren relies on the close paren to
;; terminate the current expression, and quotes it as a program. Note
;; that because interpret-mode is not used, the square brackets can be
;; used to perform quotation.

(define code-quotation
  (make-continuation-prompt-tag 'code-quotation))

(define (open-paren-tx code exp)
  (let-values
      (((code+ body)
        (next-until code-quotation
                    (stx-cdr code) (rpn-state))))
    ((rpn-next)
     code+
     ((rpn-immediate)
      (rpn-close-expression body)
      exp))))

(define close-paren-tx (make-until code-quotation))


;; FILE INCLUDE

(define load-end (make-continuation-prompt-tag 'load))

(define (path-tx code expr)
  (syntax-case code ()
    ((_ path . code+)
     (begin
       (forth-search-path
        (cons (stx->string #'path)
              (forth-search-path)))
       ((rpn-next) #'code+ expr)))))

(define (stx->string stx)
  (let ((sym/str (syntax->datum stx)))
    (cond
     ((symbol? sym/str) (symbol->string sym/str))
     ((path? sym/str) (path->string sym/str))
     ((string? sym/str) sym/str)
     (else (error 'stx->string)))))

(define (load-tx code expr)
  (syntax-case code ()
    ((_ file . code+)
     (let* ((rel-file (stx->string #'file))
            (abs-file
             (resolve-path-list
              rel-file
              (cons
               (let ((dir (current-load-relative-directory)))
                 (or dir (current-directory)))
               (forth-search-path)))))
       (call-with-values
           (lambda ()
             (let-values (((path base _) (split-path abs-file)))
               (parameterize
                   ((current-load-relative-directory path))
                 (next-until
                  load-end
                  (append
                   (file->forth-syntax
                    #'file ;; make sure lexical context is right.
                    abs-file)  ;; relative resolved
                       
                   ;; FIXME: if the resolution picked another
                   ;; path, we need to cd to it!
                   (list (make-until load-end))
                   #'code+)
                  expr))))
         ;; When the 'load-end' marker is encountered, parsing escapes
         ;; the dynamic context entered by 'load-relative'.
         (rpn-next))))))


     

;; S-EXPRESSIONS

;; Scheme s-expressions are moved to toplevel.
(define (open-sexp-tx code exp)
  (define open (string->symbol "{"))
  (define close (string->symbol "}"))

  (define (collect stx-list)
    (let next ((l '())
               (s stx-list))
      (cond
       ((null? s)
        (error 'sexp-error))
       ((eq? open (syntax->datum (car s)))
        (let-values
            (((list rest) (collect (cdr s))))
          (next (cons list l)
                rest)))
       ((eq? close (syntax->datum (car s)))
        (values
         (reverse l)
         (cdr s)))
       (else
        (next (cons (car s) l)
              (cdr s))))))


  (let-values (((list code+)
                (collect (stx-cdr code))))
    (register-toplevel list)
    ((rpn-next) code+ exp)))



;; TOPLEVEL EXPRESIONS
              
(define (require-tx code expr)
  (syntax-case code ()
    ((_ module . code+)
     (register-toplevel
      `(require ,(symbol->string
                  (syntax->datum #'module))))
     ((rpn-next) #'code+ expr))))

(define (provide-tx code expr)
  (syntax-case code ()
    ((_ name . code+)
     (register-toplevel
      `(provide ,#'name))
     ((rpn-next) #'code+ expr))))