;; Forth source lexer

;; This is built on top of read-forth to provide:
;;   forth-string->list     :: string -> list
;;   forth-load-in-path     :: file,path -> syntax stream


(module lex mzscheme

  (require
   (lib "match.ss")
   "list-utils.ss"
   "io-utils.ss"
   "stream.ss"
   "read-forth.ss"    ;; port (syntax) reader
   "tx-utils.ss"
   "stx-stream.ss"
   (lib "pretty.ss")

   )
   

  (provide forth-load-in-path
           forth-string->syntax
           path/file->syntax-stream
           )

  
  ;; Forth lexer. All hierarchical structures are built on top of a
  ;; flat Forth layer, so we don't need a parser.

  (define (port->syntax-stream name port)
    (lazy
     (let next ()
       (let ((head (read-forth-syntax
                    name
                    port))) ;; FIXME: read-syntax
         (if (eof-object? head)
             @null
             (@cons head (next)))))))

  ;; Non-stream string entry point
  ;; FIXME: delimiter is added here
  (define (forth-string->syntax string)
    (->syntax #f
              (@unfold ;; produces a list of syntax objects
               (port->syntax-stream
                "<string>"
                (open-input-string
                 (string-append string "\n"))))))
  
  (define (forth-string->list string)
    (printf "forth-string->list DEPRECATED\n")
    (->datum (forth-string->syntax string)))
    
  
  ;; Convert a path spec into a function that converts a filename to a
  ;; syntax stream.
  
  (define (make-file->atoms path port->stream)
    (lambda (filename)
      ;; (printf "loading ~a\n" filename)
      (port->stream
       filename
       (open-input-file
        (file-in-path path filename)))))

  ;; Reader for s-expressions. What we generate here will be passed to
  ;; the forth parser, so just generate 'scheme' modifiers for each
  ;; expression.

  ;; FIXME: figure out how to do this a bit cleaner..
  (define (s-port->syntax-stream name port)
    (@fold/lazy
     (lambda (head tail)
       (@list* #'scheme head tail))
     @null 
     (read-syntax/port->stream read-syntax name port)))



  ;; Non--stream entry point.
  ;; produces a syntax object.
  
  (define (forth-load-in-path filename path)
    (->syntax #f
              (@unfold
               (path/file->syntax-stream
                filename path))))

      
  ;; Convert path + toplevel file into an atom stream.

  ;; I want compilation to be separated from file system access.

  ;; However, for convenience, Forth code can include the 'load' word
  ;; which loads a file in the system path. To implement this, the
  ;; "file system dereference" needs to include path expansion AND
  ;; recursive inlining.

  ;; As a result, 'load' will only work in files, not in lexed
  ;; strings. Another consequence is that project path needs to be
  ;; defined outside of the forth source file.

  ;; This function generates a stream of syntax objects which have the
  ;; source location recorded.
  
  (define (path/file->syntax-stream top-file path)

    ;; Open a file in path.
    (define f->atoms   (make-file->atoms path port->syntax-stream))
    (define s->atoms   (make-file->atoms path s-port->syntax-stream))

    ;; Flatten the 'load' tree into a single token stream.
    (define (@flatten stream)
      (lazy
       (if (@null? stream)
           @null
           (let ((word (->datum (@car stream))))
             (case word
               ((load load-ss)
                (let ((file (symbol->string (->datum (@cadr stream))))
                      (tail (@cddr stream)))
                  (case word
                    ((load)
                     (@append (@flatten (f->atoms file))
                              (@flatten tail)))
                    ((load-ss)
                     (@append (s->atoms file)
                              (@flatten tail))))))
               (else
                (@cons (@car stream)
                       (@flatten (@cdr stream)))))))))


    (@flatten (f->atoms top-file)))  ;; top file is forth syntax


;; FIXME: this code chokes on the identifier 'load'.  i have no idea
;; why. replacing it with i.e. 'load-ff' or 'loa' seems to make it
;; work again..  the code above is a workaround for this.

  
;;    (define (path/file->syntax-stream top-file path)

;;     ;; Open a file in path.
;;     (define f->atoms   (make-file->atoms path port->syntax-stream))
;;     (define s->atoms   (make-file->atoms path s-port->syntax-stream))

;;     (define (stx->string stx) (symbol->string (->datum stx)))

;;     ;; Flatten the 'load' tree into a single token stream.
;;     (define (@flatten stream)
;;       (@syntax-case
;;           stream tail (load-ss load)
          
;;           ;; Inline forth file
;;           ((load name)
;;            (begin
;;              (printf "load\n")
;;              (@append (@flatten (f->atoms (stx->string #'name)))
;;                       (@flatten tail))))
          
;;           ;; Inline s-expr file : doesn't recurse
;;           ((load-ss name)
;;            (begin
;;              (printf "load-ss\n")
;;              (@append (s->atoms (stx->string #'name))
;;                       (@flatten tail))))


;;           ;; Cons
;;           ((word)
;;            (@cons #'word
;;                   (@flatten tail)))

;;           ;; End
;;           (()
;;            stream)))

;;     (@flatten (f->atoms top-file)))  ;; top file is forth syntax
  
      
  
  

  )