#lang racket
(require syntax/readerr)
(require "du-utility.scm")
(require "du-core.scm")
(require "du-environment.scm")
(provide read (rename-out (read-du read-syntax)))
 
(define (read in)
  (syntax->datum (read-du #f in)))
 
(define (option o1 o2)
  (or o1 o2))

(define (guard g1 g2)
  (and g1 g2))

(define (skip-whitespace in)
  (regexp-match #px"^[\\s\t\n]*" in))

(define (check-end in)
  (skip-whitespace in)
  (if (equal? ")" (string (peek-char in)))
      (regexp-match #rx"^[)]" in)
      #f))

(define (match-implementation-sub-type in)
  (regexp-match #px"^[\\s\t\n]*imp(?![^\\s\t\n()])" in))

(define (key-word? token)
  ; a key-word in the parse table
  (if (symbol? token)
      (get 'parse token)
      #f))
    
(define (read-du src in)
  (define (srcloc2 last-obj)
    ; source location from last-obj to here
    (define last-line (list-ref last-obj 1))
    (define last-col  (list-ref last-obj 2))
    (define last-pos  (list-ref last-obj 3))
    (define-values (line col pos) (port-next-location in))
    (guard line
           (vector src last-line last-col last-pos (- pos last-pos))))
  
  (define (sx prickly-pear last-pos)
    ; build syntax object
    (datum->syntax #f prickly-pear (srcloc2 last-pos)))
  
  (define (nx)
    ; read the next token, return as a symbol when posible: "("
    (define do-first# (skip-whitespace in))
    (define-values (line col pos) (port-next-location in))
    (define token-match
      (regexp-match
       ;TODO constrain the allowed tokens more, more compatible w/ scheme
       #px"^[()]|[^\\s\t\n()]+(?![^\\s\t\n()])"
       in))
     (unless token-match
      (raise-read-error "Syntax error - no token -- NX"
                        src line col pos
                        (guard pos (- (file-position in) pos))))
    (let* ((token (bytes->string/utf-8 (car token-match)))
           (s1 "and|or|not|is-equal-p|is-empty-p|is-less-p|is-greater-p")
           (s2 "|is-number-p|is-string-p|is-logic-p|index|name|ify|thaw")
           (s3 "|export|import|suggest|append|slice|length|state|freeze")
           (s4 "|number|add|subtract|multiply|divide|string|concat|sign")
           (s5 "|logic|is-list-p|boundary|expand|call|list1|call1|call2")
           (s6 "|function|call3|call4|help|is-name-p")
           (s7 (string-append s1 s2 s3 s4 s5 s6 "(?![^\\s\t\n()])")))
      ; non symbols stay strings : [^\\s\t\n()]+
      (list (option (guard (regexp-match (pregexp s7) token)
                           (string->symbol token))
                    token)
            line col pos)))


  (define (parse-expr sobj)
    ; parse an expression
    (define s (list-ref sobj 0))
    (define last-line (list-ref sobj 1))
    (define last-col  (list-ref sobj 2))
    (define last-pos  (list-ref sobj 3))
    (define (pexp) (parse-expr (nx)))
    
    (define (typeof sobj)
      ; the type of a syntax object
      (let ((token (guard (pair? sobj)
                          (car sobj)))
            (stringl (list 'string 'concat))
            (numberl (list 'number 'add 'subtract 'multiply 'divide 'length))
            (logicl  (list 'logic 'and 'or 'not 'is-equal-p 'is-empty-p
                           'is-less-p 'is-greater-p 'is-list-p 'is-number-p
                           'is-string-p 'is-logic-p 'is-name-p))
            (listl   (list "(" 'append 'slice 'state 'expand 'freeze 'list1))
            (othr-kw (list ")" 'index 'function 'ify 'thaw 'export 'import
                           'boundary 'suggest 'sign 'name 'call 'call1 'call2
                           'call3 'call4 'help))
            )
        (cond ((not token) (error "No token. -- TYPEOF" src last-line last-col last-pos))
              ((member token stringl) 'string)
              ((member token numberl) 'number)
              ((member token logicl)  'logic)
              ((member token listl)   'list)
              ((member token othr-kw) 'keyword)
              (else  'variable) )))
    
    (define (pstring)
      (let* ((sobj (nx))
             (typ (typeof sobj))
             (last-line (list-ref sobj 1))
             (last-col  (list-ref sobj 2))
             (last-pos  (list-ref sobj 3)))
        (cond ((eq? typ 'string)   (parse-expr sobj))
              ((eq? typ 'number)   (error "expected string not number"
                                          src last-line last-col last-pos))
              ((eq? typ 'logic)    (error "expected string not logic"
                                          src last-line last-col last-pos))
              ((eq? typ 'list)     (error "expected string not list"
                                          src last-line last-col last-pos))
              ((eq? typ 'keyword)  (parse-expr sobj))
              ((eq? typ 'variable) (parse-expr sobj))
              (else (error "Should not execute. -- PSTRING")) )))
    
    (define (pnumber)
      (let* ((sobj (nx))
             (typ (typeof sobj))
             (last-line (list-ref sobj 1))
             (last-col  (list-ref sobj 2))
             (last-pos  (list-ref sobj 3)))
        (cond ((eq? typ 'string)   (error "expected number not string"
                                          src last-line last-col last-pos))
              ((eq? typ 'number)   (parse-expr sobj))
              ((eq? typ 'logic)    (error "expected number not logic"
                                          src last-line last-col last-pos))
              ((eq? typ 'list)     (error "expected number not list"
                                          src last-line last-col last-pos))
              ((eq? typ 'keyword)  (parse-expr sobj))
              ((eq? typ 'variable) (parse-expr sobj))
              (else (error "Should not execute. -- PNUMBER")) )))
    
    (define (plogic)
      (let* ((sobj (nx))
             (typ (typeof sobj))
             (last-line (list-ref sobj 1))
             (last-col  (list-ref sobj 2))
             (last-pos  (list-ref sobj 3)))
        (cond ((eq? typ 'string)   (error "expected logic not string"
                                          src last-line last-col last-pos))
              ((eq? typ 'number)   (error "expected logic not number"
                                          src last-line last-col last-pos))
              ((eq? typ 'logic)    (parse-expr sobj))
              ((eq? typ 'list)     (error "expected logic not list"
                                          src last-line last-col last-pos))
              ((eq? typ 'keyword)  (parse-expr sobj))
              ((eq? typ 'variable) (parse-expr sobj))
              (else (error "Should not execute. -- PLOGIC")) )))
    
    (define (plist)
      (let* ((sobj (nx))
             (typ (typeof sobj))
             (last-line (list-ref sobj 1))
             (last-col  (list-ref sobj 2))
             (last-pos  (list-ref sobj 3)))
        (cond ((eq? typ 'string)   (error "expected list not string"
                                          src last-line last-col last-pos))
              ((eq? typ 'number)   (error "expected list not number"
                                          src last-line last-col last-pos))
              ((eq? typ 'logic)    (error "expected list not logic"
                                          src last-line last-col last-pos))
              ((eq? typ 'list)     (parse-expr sobj))
              ((eq? typ 'keyword)  (parse-expr sobj))
              ((eq? typ 'variable) (parse-expr sobj))
              (else (error "Should not execute. -- PLIST")) )))

    (define (pname)
      (let* ((sobj (nx))
             (typ (typeof sobj))
             (last-line (list-ref sobj 1))
             (last-col  (list-ref sobj 2))
             (last-pos  (list-ref sobj 3)))
        (cond ((eq? typ 'string)   (error "expected name not string"
                                          src last-line last-col last-pos))
              ((eq? typ 'number)   (error "expected name not number"
                                          src last-line last-col last-pos))
              ((eq? typ 'logic)    (error "expected name not logic"
                                          src last-line last-col last-pos))
              ((eq? typ 'list)     (error "expected name not list"
                                          src last-line last-col last-pos))
              ((eq? typ 'keyword)  (error "expected name not keyword"
                                          src last-line last-col last-pos))
              ((eq? typ 'variable) (parse-expr sobj))
              (else (error "Should not execute. -- PNAME")) )))

    (define (pstmseq)
      (parse-state-l1 (nx)))
    
    (define (parse-key-word token syntax-object)
      ; parse stuff from parse table
      (define (parse-sub-expressions exps-list)
        (cond
          ((eq? exps-list #f)
           (error "Not a list of parse symbols. -- PARSE-KEY-WORD"
                  src last-line last-col last-pos))
          ((null? exps-list)
           (list))
          ((not (pair? exps-list))
           (error "Not a list of parse symbols. -- PARSE-KEY-WORD"
                  src last-line last-col last-pos))
          ((eq? 'exp    (car exps-list))
           (cons (pexp)    (parse-sub-expressions (cdr exps-list))))
          ((eq? 'logic  (car exps-list))
           (cons (plogic)  (parse-sub-expressions (cdr exps-list))))
          ((eq? 'number (car exps-list))
           (cons (pnumber) (parse-sub-expressions (cdr exps-list))))
          ((eq? 'string (car exps-list))
           (cons (pstring) (parse-sub-expressions (cdr exps-list))))
          ((eq? 'list   (car exps-list))
           (cons (plist)   (parse-sub-expressions (cdr exps-list))))
          ((eq? 'stmseq (car exps-list))
           (cons (pstmseq) (parse-sub-expressions (cdr exps-list))))
          (else
           (error "Bad parse symbol. -- PARSE-KEY-WORD"
                  src last-line last-col last-pos))))
      (let ((parse-list (get 'parse token)))
        (sx (cons
             (sx token syntax-object)
             (parse-sub-expressions parse-list))
            syntax-object)))

  (define (parse-state sobj)
    ; top level for STATE
    (define s (list-ref sobj 0))
    (define last-pos  (list-ref sobj 3))
    (sx (list (sx 'state sobj) (parse-state-l1 (nx)) (pexp)) sobj))

  (define (parse-state-l1 s1)
    ; init state-statement-lists
    (define s (list-ref s1 0))
    (define last-line (list-ref s1 1))
    (define last-col  (list-ref s1 2))
    (define last-pos  (list-ref s1 3))
    (cond ((equal? s "(") (sx (parse-state-rem1) s1))
          ; just literal lists (no direct meta-programming of statement sequences) ?CHECK?
          (else (error "No list. -- PARSE-STATE-L1" src last-line last-col last-pos)) ))

  (define (parse-state-rem1)
    ; end state-statement-lists
    (if (check-end in)
        (list)
        (cons (parse-state-l2 (nx))
              (parse-state-rem1))))

  (define (parse-state-l2 s2)
    ; init statement-sub-lists
    (define s (list-ref s2 0))
    (define last-line (list-ref s2 1))
    (define last-col  (list-ref s2 2))
    (define last-pos  (list-ref s2 3))
    (define (match-label in)
      (regexp-match #px"^[\\s\t\n]*label(?![^\\s\t\n])" in))
    (if (and (equal? s "(") (match-label in))
        (sx (cons (pname) (parse-state-rem2)) s2)
        (error "Needs a sub-sequence of statements (a literal list). -- PARSE-STATE-L2"
               src last-line last-col last-pos))) ; just literal lists ?CHECK?

  (define (parse-state-rem2)
    ; end statement-sub-lists
    (if (check-end in)
        (list)
        (append
         (let* ((sobj (nx))
                (s (list-ref sobj 0))
                (last-line (list-ref sobj 1))
                (last-col  (list-ref sobj 2))
                (last-pos  (list-ref sobj 3)))
           (cond ((or (equal? s "load") (equal? s 'load))
                  (list (sx 'load sobj) (pexp) (pname)))
                 ((or (equal? s "store") (equal? s 'store))
                  (list (sx 'store sobj) (pname) (pname)))
                 ((or (equal? s "jump") (equal? s 'jump))
                  (list (sx 'jump sobj) (pstring)))
                 ((or (equal? s "event") (equal? s 'event))
                  (list (sx 'event sobj) (pname) (pname) (pexp)))
                 (else
                  (error "Not a statement. -- PARSE-STATE-REM2"
                         src last-line last-col last-pos)) ))
         (parse-state-rem2))))

    (cond ((key-word? s)   (parse-key-word s sobj))
          ((equal? s "(") (sx (cons (sx 'list sobj)
                                    (read-list-remainder)) sobj))
          ((equal? s ")")  (error "Too many parentheses. -- PARSE-EXPR"
                                 src last-line last-col sobj))
          ((eq? s 'logic)  (read-literal-logic sobj))
          ((eq? s 'number) (read-literal-number sobj))
          ((eq? s 'string) (read-literal-string sobj))
          (else (sx (cond ((string? s) (string->symbol s))
                          ((symbol? s) s)
                          (else
                           (error "Expected token to be a string or symbol. -- PARSE-EXPR" s)))
                    sobj)))) 


  (define (read-list-remainder)
    ; read to end of list
    (if (check-end in)
        (list) ; EOL
        (cons (parse-expr (nx))
              (read-list-remainder))))
  
  (define (read-literal-logic obj)
    (define-values (line col pos) (port-next-location in))
    (define (string->bool str)
      (cond ((equal? str "true") #t)
            ((equal? str "false") #f)
            (else (error "Not true or false. -- READ-LITERAL-LOGIC"
                         src line col pos))))
    (cond ((match-implementation-sub-type in)
           ; only one recognized subtype
           ; TODO external standard (outside the programming language standard)
           (sx (string->bool (car (nx))) obj))
          (else "Unrecognized logical subtype. -- READ-LITERAL-LOGIC"
                src line col pos) ))

  (define (read-literal-number obj)
    (define-values (line col pos) (port-next-location in))
    (cond ((match-implementation-sub-type in)
           ; only one recognized subtype
           (let ((token (nx)))
             (cond ((not (string->number (car token)))
                    (error "Bad number. -- READ-LITERAL-NUMBER"
                           src line col pos))
                   (else (sx (string->number (car token)) obj)) )))
          (else "Unrecognized number subtype. -- READ-LITERAL-NUMBER"
                src line col pos) ))

  (define (read-literal-string obj)
    (define-values (line col pos) (port-next-location in))
    (define (trim-quotes str)
      (if (regexp-match #rx"^\"([^\"]*)\"$" str)
          (cadr (regexp-match #rx"^\"([^\"]*)\"$" str))
          (error "not a string literal" str line)))
    (let ((re2 #px"^[\\s\t\n]+(\"[^\"]*\")|(quote)(?![^\\s\t\n()])"))
      (cond ((match-implementation-sub-type in)
             ; only one recognized subtype
             (let ((mtch1 (regexp-match re2 in)))
               (cond ((not mtch1)
                      (error "Not a string literal. -- READ-LITERAL-STRING"
                             src line col pos))
                     ((list-ref mtch1 2)
                      (sx "\"" obj))
                     (else (sx (bytes->string/utf-8
                                (trim-quotes (list-ref mtch1 1)))
                               obj)))) )
            (else "Unrecognized string subtype. -- READ-LITERAL-STRING"
                  src line col pos) )))


   (parse-expr (nx)))