;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.
;;  Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

(use goo/boot)
(use goo/fun)
(use goo/class)
(use goo/macros)
(use goo/conditions)
(use goo/types)
(use goo/any)
(use goo/log)
(use goo/chr)
(use goo/math)
(use goo/io/port)
(use goo/cols)
(use goo/cols/lst)

;; READ

(dm read (port|<in-port> => <any>)
  ;; (put out #\a) (newline out)
  (rep loop ()
    (def form (sub-read port))
    (if (not (reader-token? form))
        form
        (if (== form $close-paren)
            (warn "discarding extraneous right parenthesis")
            (loop))
        ;; (reading-error port (tail form))
        )))

(dm read-from-string (x|<str> => <any>)
  (with-port (port (open <str-in-port> x)) (read port)))

(dm sub-read-carefully (port|<port> => <any>)
  ;; (put out #\b) (newline out)
  (def form (sub-read port))
  (if (eof-object? form)
      (reading-error port "unexpected end of file")
      (if (reader-token? form)
          (reading-error port (tail form))
          form)))

(dc <reader-token> (<any>))
  (dp token-message (<reader-token> => <str>))

(dm make-reader-token (message => <any>)
  (new <reader-token> token-message message))

(dm reader-token? (form => <log>)
  (isa? form <reader-token>))

(dv $close-paren   (make-reader-token "unexpected right parenthesis"))
(dv $close-bracket (make-reader-token "unexpected right bracket"))
(dv $close-curly   (make-reader-token "unexpected right curly"))

;;  Main dispatch

(dm sub-read (port|<port> => <any>)
  ;; (put out #\c) (newline out)
  (def c (get port))
  (if (eof-object? c)
      (seq;; (put out #\m) (put out c) (newline out) 
       c
       )
      ((elt *read-dispatch-vector* (char->ascii c)) c port)))

(dv *read-dispatch-vector* 
  (fill! (fab <vec> ascii-limit)
	 (fun (c port) (reading-error port "illegal character read" c))))

(dv *read-terminating?-vector* (fill! (fab <vec> ascii-limit) #t))

(dm set-standard-syntax! (char|<chr> terminating? reader)
  (set (elt *read-dispatch-vector* (char->ascii char)) reader)
  (set (elt *read-terminating?-vector* (char->ascii char)) terminating?))

(let ((sub-read-whitespace (fun (c port) (sub-read port))))
  (do (fun (c) (set (elt *read-dispatch-vector* c) sub-read-whitespace))
      ascii-whitespaces))

(df flush-whitespace (port|<port>)
  (def c (peek port))
  (if (mem? ascii-whitespaces (char->ascii c))
      (seq
        (get port)
        (flush-whitespace port))
      c))

(df read-delimited-list (endchar|<chr> port|<port>)
  (def retlist nil)  
  (rep loop ((c (flush-whitespace port)))    
    (if (== c endchar)
        (seq (get port) (rev retlist))
        (seq (opf retlist (pair (read port) _))
             (loop (flush-whitespace port))))))

(df sub-read-constituent (c port)
  ;; (put out #\h) (newline out)
  (parse-token (sub-read-token c port) port))

(let ((str10496
       (cat "!$%&*+-./0123456789:<=>?@^_~ABCDEFGHIJKLM"
            "NOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")))
  (do (fun (c) (set-standard-syntax! c #f sub-read-constituent))
      str10496))

;; Usual read macros

(dm set-standard-read-macro! (char|<chr> terminating? proc|<fun>)
  (set-standard-syntax! char terminating? proc))

(dm get-standard-read-macro (char|<chr>)
  (elt *read-dispatch-vector* (char->ascii char)))

(dm sub-read-vertical (c|<chr> port|<port> => <any>)
  (parse-token "|" port))

(set-standard-read-macro! #\| #t sub-read-vertical)

(dm sub-read-backslash (c|<chr> port|<port> => <any>)
  (parse-token "\\" port))

(set-standard-read-macro! #\\ #t sub-read-backslash)

(dv $vert-sym   (as <sym> "|"))
(dv $vert-proxy (lst "vert-proxy"))

(df sub-read-list-eof-error (port|<port>)
  (reading-error port "end of file inside list -- unbalanced parentheses"))

(dm sub-read-list (c|<chr> p|<port> => <any>)
  ;; (put out #\d) (newline out)
  (def line (port-line p))
  (def form (sub-read p))
  (cond ((eof-object? form)     (sub-read-list-eof-error p))
        ((== form $close-paren) '())
        (#t
         (rep read-next 
             ((c|<chr> c) (prev form) (line line) (form (sub-read p)))
           (def prev (if (== prev $vert-proxy) $vert-sym prev))
           (cond ((eof-object? form)
                  (sub-read-list-eof-error p))
                 ((== form $close-paren) 
                  (line-list line prev))
                 ((== form $vert-sym)    
                  (let ((next (sub-read-carefully p)))
                    (line-pair (line-pair prev (line-list line next) line) 
                               (sub-read-list c p)
                               line)))
                 (#t
                  (line-pair prev
                             (read-next c form (port-line p) (sub-read p))
                             line)))))))

(dm sub-read-seq (c|<chr> e port|<port> => <any>)
  (def form (sub-read port))
  (if (eof-object? form)
      (reading-error 
       port "end of file inside list -- unbalanced parentheses")
      (if (== form e)
          '()
          (pair form (sub-read-seq c e port)))))

(dm sub-read-brackets (c|<chr> port|<port> => <any>)
  (def form (sub-read-seq c $close-bracket port))
  (case (len form)
    ((2) `(elt ,(1st form) ,(2nd form)))
    ((3) (if (== (3rd form) '*)
             `(sub* ,(1st form) ,(2nd form))
             `(sub ,(1st form) ,(2nd form) ,(3rd form))))
    (#t (reading-error port "invalid [ ... ] form"))))

(dv bs-sym (as <sym> "\\"))

(dm sub-read-curlies (c|<chr> port|<port> => <any>)
  (def forms       (sub-read-seq c $close-curly port))
  (def slash-index (pos forms bs-sym))
  (if slash-index
      `(fun ,(sub forms 0 slash-index) ,@(sub* forms (+ slash-index 1)))
      `(seq ,@forms)))

(set-standard-read-macro! #\( #t sub-read-list)

(set-standard-read-macro! #\) #t (fun (c port) $close-paren))

(set-standard-read-macro! #\{ #t sub-read-curlies)

(set-standard-read-macro! #\} #t (fun (c port) $close-curly))

(set-standard-read-macro! #\[ #t sub-read-brackets)

(set-standard-read-macro! #\] #t (fun (c port) $close-bracket))

(set-standard-read-macro!
  #\' #t (fun (c port) (lst 'quote (sub-read-carefully port))))

(set-standard-read-macro!
  #\` #t (fun (c port) (lst 'quasiquote (sub-read-carefully port))))

(set-standard-read-macro!
  #\, #t
  (fun (c port)
    (def next    (peek port))
    (def keyword (if (eof-object? next)
                     (reading-error port "end of file after ,")
                     (if (= next #\@)
                         (seq (get port)
                              'unquote-splicing)
                         'unquote)))
    (lst keyword (sub-read-carefully port))))

(dv $string-escape-chars
  (let ((vec (fill! (fab <vec> ascii-limit) #f)))
    (set (elt vec (as <int> #\t)) #\tab)
    (set (elt vec (as <int> #\f)) #\page)
    (set (elt vec (as <int> #\r)) #\return)
    (set (elt vec (as <int> #\n)) #\newline)
    (as <tup> vec)))

(df read-string-literal (c port)
  ;; (put out #\g) (newline out)
  (rep loop ((l '()) (i 0))
    (def c (get port))
    (if (eof-object? c)
	(reading-error port "end of file within a string")
	(if (= c #\\)
	    (let ((c (get port)))
	      (if (eof-object? c)
		  (reading-error port "end of file within a string")
		  (if (or (= c #\\) (= c #\"))
		      (loop (pair c l) (+ i 1))
		      (let ((ec (elt $string-escape-chars (as <int> c))))
			(if ec
			    (loop (pair ec l) (+ i 1))
			    (reading-error
			     port "invalid escaped character in string" 
			     c))))))
	    (if (= c #\")
		(reverse-list->string l i)
		(loop (pair c l) (+ i 1)))))))

(set-standard-read-macro!
  #\" #t read-string-literal)

(set-standard-read-macro!
  #\; #t (fun (c port) (gobble-line port) (sub-read port)))

(dm gobble-line (port|<port>)
  (rep loop ()
    (def c (get port))
    (if (eof-object? c) c (if (= c #\newline) #f (loop)))))

(dv *sharp-macros* '())

(dm define-sharp-macro (c proc)
  (set *sharp-macros* (pair (lst c proc) *sharp-macros*)))

(set-standard-read-macro!
  #\# #f
  (fun (c port)
    (def c (peek port))
    (def c (if (eof-object? c)
               (reading-error port "end of file after #")
               (to-lower c)))
    (def probe (assq c *sharp-macros*))
    (if probe
        ((head (tail probe)) c port)
        (reading-error port "unknown # syntax" c))))

(define-sharp-macro #\f (fun (c port) (get port) #f))

(define-sharp-macro #\t (fun (c port) (get port) #t))

(define-sharp-macro #\| (fun (c port) (get port) $vert-proxy))

(df gobble-nested-comment (port|<port>)
  (rep loop ((found-slash? #f))
    (def c (get port))
    (if (eof-object? c) 
        c
        (case c
          ((#\/) (loop #t))
          ((#\#) (if found-slash? #f (loop #f)))
          (#t    (loop #f))))))

(define-sharp-macro #\/
  (fun (c port) (gobble-nested-comment port) (sub-read port)))

(df read-long-string-literal (c port|<port>)
  (get port) ;; skip double quote
  (rep loop ((l '()) (i 0) (q? #f))
    (def c (get port))
    (if (eof-object? c)
        (reading-error port "end of file within a long string")
	(case c
	  ((#\") (loop (pair c l) (+ i 1) #t))
	  ((#\#) (if q? (reverse-list->string (tail l) (- i 1))
	                (loop (pair c l) (+ i 1) #f)))
	  (#t    (loop (pair c l) (+ i 1) #f))))))

(define-sharp-macro #\" read-long-string-literal)

(dm parse-c-inline (s|<str>)
  (def port (open <str-in-port> s))
  (def buf  (fab <vec> 0))
  (rep loop ((str '()) (res '()))
    (def c (get port))
    (if (eof-object? c)
	(rev! (add res (as <str> (rev! str))))
        (case c
          ((#\$ #\@) 
           (def val (if (= c #\$) (read port) `(to-c ,(read port))))
           (loop '() (add (add res (as <str> (rev! str))) val)))
          (#t
           (loop (add str c) res))))))

(df read-c-inline-literal (start end form port|<port>)
  (get port) ;; skip curly
  (rep loop ((l '()) (i 0) (d 1))
    (def c (get port))
    (if (eof-object? c)
        (reading-error port "end of file within c-inline")
	(case c
	  ((start) (loop (pair c l) (+ i 1) (+ d 1)))
	  ((end)   (if (= d 1) 
                       `(,form ,@(parse-c-inline (reverse-list->string l i)))
                       (loop (pair c l) (+ i 1) (- d 1))))
	  (#t       (loop (pair c l) (+ i 1) d))))))

(df read-c-statement-literal (c port|<port>) 
  (read-c-inline-literal #\{ #\} 'c-ment port))

(define-sharp-macro #\{ read-c-statement-literal)

(df read-c-expression-literal (ce port|<port>)
  (get port)
  (def c (get port))
  (def inline (read-c-inline-literal #\{ #\} 'c-expr port))
  (if (= c #\g)
      inline
      `(,(cat-sym '% (fabs <str> c) 'b) ,inline)))

(define-sharp-macro #\e read-c-expression-literal)

;; TODO: ASSQ

(dv $char-long-names
  '((tab #\tab) (page #\page)
    (return #\return) (newline #\newline)
    (space #\space)))

(define-sharp-macro
  #\\
  (fun (c port)
    (get port)
    (def c (peek port))
    (if (eof-object? c)
        (reading-error port "end of file after #\\")
        (if (alpha? c)
            (let ((name (sub-read-carefully port)))
              (if (= (len (as <str> name)) 1)
                  c
                  (let ((temp (assq name $char-long-names)))
                    (if temp
                        (head (tail temp));; Goo => syntax
                        (reading-error port "unknown #\\ name" name)))))
            (get port)))))

(define-sharp-macro
  #\(
  (fun (c port)
    (get port)
    (as <tup> (sub-read-list c port))))

(define-sharp-macro
  #\[
  (fun (c port)
    (get port)
    (as <vec> (sub-read-seq c $close-bracket port))))

(let ((number-sharp-macro
        (fun (c port)
          (def string (sub-read-token #\# port))
          (or (str-to-num string)
              (reading-error port "unsupported number syntax" string)))))
  (do (fun (c) (define-sharp-macro c number-sharp-macro))
      '(#\b #\o #\d #\x #/ #\i #\e /#)))

;; Tokens

(dm sub-read-token (c|<chr> port|<port> => <any>)
  ;; (put out #\e) (put out c) (newline out)
  (rep loop ((l (lst (preferred-case c))) (n 1))
    (def c (peek port))
    (if (or (eof-object? c)
            (elt *read-terminating?-vector* (char->ascii c)))
        (reverse-list->string l n)
        (loop (pair (preferred-case (get port)) l) (+ n 1)))))

;; TODO: MEM? WITH TEST

(dm parse-token (string|<str> port|<port> => <any>)
  ;; (put out #\f) (newline out)
  (if (let ((c (elt string 0)))
        (or (digit? c)
            (= c #\+)
            (= c #\-)
            (= c #\.)))
      (let ((maybe-number (str-to-num string)))
        (if maybe-number
            maybe-number
            (if (any? (fun (x) (= string x)) $strange-symbol-names)
                (as <sym> string)
                (if (= string ".")
                    (as <sym> string)
                    (reading-error port "unsupported number syntax" string)))))
      (seq ;; (put out #\n) (newline out)
       (as <sym> string))))
;;       (let ((vert-pos (pos string #\|)))
;;      (if (and vert-pos (> (len string) 1)) ;; typed variable?
;;          (if (= vert-pos 0)
;;              (reading-error port "Vertical bar at beginning of symbol" string)
;;              `(,(as <sym> (sub string 0 vert-pos)) 
;;                ,(as <sym> (sub string (+ vert-pos 1) (len string)))))
;;          (seq ;; (put out #\n) (newline out)
;;           (as <sym> string))))

(dv $strange-symbol-names 
  '("+" "-" "..."
    "1st" "2nd" "3rd" ;; Seq Support
    "1+" "1-"         ;; Only for S&ICP support
    "->"))            ;; Only for JAR's thesis

(dv preferred-case 
  (if (= (elt (as <str> 't) 0) #\T) to-upper to-lower))

;; Reader errors

(dm reading-error (port|<port> message|<str> irritants|...)
  (error (cat message ": %=")  ;; was: app(...)
         (cat irritants (lst port))))

(dm warn (string|<str> irritants-and-port|...)
  ;; TODO: TURN BACK ON
  ;; (app sig string irritants-and-port)
  #f
  )
  ;; msg-string: string,
  ;;  msg-arguments: irritants-and-port

(dm reverse-list->string (l|<lst> n|<int> => <str>)
  (as <str> (rev! l)))

(export
  read-delimited-list
  set-standard-read-macro!
  get-standard-read-macro
  $char-long-names
  read
  read-from-string)
