#lang racket
(require parser-tools/lex)
(require parser-tools/yacc)
(require parser-tools/lex-sre)

(define-empty-tokens core/empty-tokens
  (CASE OF IN LAM PACK ASSN ARROW LPAREN RPAREN LBRAC RBRAC LBRAK
        RBRAK SEMICOLON EOF MULT DIV ADD MINUS AND OR COMMA DOT))

(define-tokens core/tokens
  (NUM VAR RELOP LET))

(define core/lexer
  (lexer
   [(eof) (token-EOF)]
   ["." (token-DOT)]
   ["," (token-COMMA)]
   ["let" (token-LET 'let)]
   ["letrec" (token-LET 'letrec)]
   ["case" (token-CASE)]
   ["of" (token-OF)]
   ["in" (token-IN)]
   ["\\" (token-LAM)]
   ["Pack" (token-PACK)]
   ["=" (token-ASSN)]
   ["->" (token-ARROW)]
   ["+" (token-ADD)]
   ["-" (token-MINUS)]
   ["*" (token-MULT)]
   ["/" (token-DIV)]
   ["&" (token-AND)]
   ["|" (token-OR)]
   ["<" (token-LBRAK)]
   [">" (token-RBRAK)]
   [(or "<=" "==" "~=" ">=") (token-RELOP (string->symbol lexeme))]
   ["(" (token-LPAREN)]
   [")" (token-RPAREN)]
   ["{" (token-LBRAC)]
   ["}" (token-RBRAC)]
   [";" (token-SEMICOLON)]
   [(+ numeric) (token-NUM (string->number  lexeme))]
   [(: alphabetic (* (or alphabetic numeric #\_))) (token-VAR (string->symbol lexeme))]
   [whitespace (core/lexer input-port)]))

(define core/parser
  (parser
   [start program]
   [end EOF]
   [tokens core/empty-tokens core/tokens]
   [precs
    (nonassoc IN DOT OF ARROW)
    (nonassoc SEMICOLON)
    (right OR)
    (right AND)
    (right RELOP LBRAK RBRAK)
    (left ADD MINUS)
    (left MULT DIV)]
   [error (λ (tok-ok? tok-name tok-value)
            (error (format "Token Ok?: ~a\nToken name: ~a\nToken value: ~a" tok-ok? tok-name tok-value)))]
   [grammar
    [program [(sc) (list $1)]
             [(program SEMICOLON sc) (cons $3 $1)]]
    [sc [(VAR vars ASSN expr) (list 'define (cons $1 (reverse $2)) $4)]]
    [expr [(expr ADD expr) (list (list '+ $1) $3)]
          [(expr MINUS expr) (list (list '- $1) $3)]
          [(LET defns IN expr) (list $1 (reverse $2) $4)]
          [(expr MULT expr) (list (list '* $1) $3)]
          [(expr OR expr) (list (list 'or $1) $3)]
          [(expr AND expr) (list (list 'and $1) $3)]
          [(expr RELOP expr) (list (list $2 $1) $3)]
          [(expr LBRAK expr) (list (list '< $1) $3)]
          [(expr RBRAK expr) (list (list '> $1) $3)]
          [(expr DIV expr) (list (list '/ $1) $3)]
          [(LAM vars1 DOT expr) (list 'λ (reverse $2) $4)]
          [(CASE expr OF alts) (list 'case $2 (reverse $4))]
          [(expr0) $1]]
    [expr0 [(expr0 aexpr) (list $1 $2)]
           [(aexpr) $1]]
    [aexpr [(NUM) $1]
           [(VAR) $1]
           [(LPAREN expr RPAREN) $2]
           [(PACK LBRAC NUM COMMA NUM RBRAC) (list 'pack $3 $5)]]
    [defns [(defns SEMICOLON defn) (cons $3 $1)]
           [(defn) (list $1)]]
    [defn [(VAR ASSN expr) (list $1 $3)]]
    [vars [() (list)]
          [(vars VAR) (cons $2 $1)]]
    [vars1 [(vars VAR) (cons $2 $1)]]
    [alt [(LBRAK NUM RBRAK vars ARROW expr) (list $2 (reverse $4) $6)]]
    [alts [(alt) (list $1)]
          [(alts SEMICOLON alt) (cons $3 $1)]]]))

(define (parse-from-port p)
  (reverse (core/parser (λ () (core/lexer p)))))

(define (parse-from-string s)
  (parse-from-port (open-input-string s)))

(provide parse-from-port parse-from-string)