#lang scheme/base

(require (for-syntax scheme/base)
         scheme/list)

;; Returns the module (as a syntax string, an absolute path) of the
;; caller's lexical context
(define-syntax (current-module-path stx)
  (let ([src  (syntax-source stx)])
    (if (path? src)
        (with-syntax ([path  (path->string src)])
          (syntax/loc stx path))
        (raise-syntax-error
         'current-module-path
         "could not determine the current module path (is the file unsaved?)"
         stx))))

(define module-path (current-module-path))

;; Skips whitespace characters using the current readtable's definition
;; of whitespace
(define (skip-whitespace port)
  (let ([ch (peek-char port)])
    (unless (eof-object? ch)
      (let-values ([(like-ch/sym proc dispatch-proc)
                    (readtable-mapping (current-readtable) ch)])
        (when (and (char? like-ch/sym)
                   (char-whitespace? like-ch/sym))
          (read-char port)
          (skip-whitespace port))))))

;; Returns true if reading terms after $ should stop
(define (is-end? port)
  (and (member (peek-char port) (list #\) #\] #\} eof)) #t))

;; Reads a datum from the input port
(define (read-rest-datum port)
  (skip-whitespace port)
  (if (is-end? port)
      empty
      (let* ([datum       (read/recursive port #f (current-readtable))]
             [rest-datum  (read-rest-datum port)])
        (if (special-comment? datum)
            rest-datum
            (append (list datum) rest-datum)))))

;; Creates a syntax object from datum using the input port's position to
;; compute its span
(define (dtm->stx datum port src line col pos)
  (let-values ([(l c p)  (port-next-location port)])
    (datum->syntax #f datum (list src line col pos (and pos (- p pos))))))

;; Reads a syntax object from the input port
(define (read-rest-syntax port src)
  (skip-whitespace port)
  (let-values ([(line col pos)  (port-next-location port)])
    (if (is-end? port)
        empty
        (let* ([stx       (read-syntax/recursive src port #f (current-readtable))]
               [rest-stx  (read-rest-syntax port src)])
          (if (special-comment? stx)
              rest-stx
              (dtm->stx (cons stx rest-stx) port src line col pos))))))

;; Returns the current readtable extended with a handler for $
(define (make-rest-readtable)
  (make-readtable
   (current-readtable)
   #\$ 'non-terminating-macro (case-lambda
                                [(ch port)  (read-rest-datum port)]
                                [(ch port src line col pos)
                                 (read-rest-syntax port src)])))

;; Reads a datum from the input port, handles $
(define (*read port)
  (parameterize ([current-readtable  (make-rest-readtable)])
    (read port)))

;; Reads a syntax object from the input port, handles $
;; If the result is recognizable as a module form, inserts a require for
;; this module's make-rest-readtable and an expression that sets the
;; current readtable
;; Without this, calls to 'read' at evaluation time (like in the REPL!)
;; wouldn't handle $ properly
(define (*read-syntax src port)
  (parameterize ([current-readtable  (make-rest-readtable)])
    (define stx (read-syntax src port))
    (with-syntax ([module-path  module-path])
      (syntax-case stx ()
        ; already has #%module-begin
        [(module name lang (#%module-begin body ...))
         (and (eq? (syntax->datum #'module) 'module)
              (eq? (syntax->datum #'#%module-begin) '#%module-begin))
         (syntax/loc stx
           (module name lang
             (#%module-begin
              (require (only-in (file module-path) make-rest-readtable))
              (current-readtable (make-rest-readtable))
              body ...)))]
        ; doesn't have #%module-begin yet
        [(module name lang body ...)
         (eq? (syntax->datum #'module) 'module)
         (syntax/loc stx
           (module name lang
             (require (only-in (file module-path) make-rest-readtable))
             (current-readtable (make-rest-readtable))
             body ...))]
        ; module is probably broken anyway...
        [_  stx]))))

(provide make-rest-readtable
         (rename-out [*read read] [*read-syntax read-syntax]))