#lang racket/base

(provide definition-parser)

(require preserves)
(require racket/match)
(require (only-in racket/syntax format-symbol))

(require "type.rkt")
(require "gen/schema.rkt")

(define (definition-parser name def)
  (define ty (definition-ty def))
  `(define (,(format-symbol "parse-~a" name) input)
     ,(match def
        [(Definition-or p0 p1 pN)
         `(match input
            ,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
                         (alt-ty (in-list (map cadr (ty-union-variants ty))))]
                (match-define (NamedAlternative variant-label-str pattern) named-alt)
                `[,(pattern->match-pattern pattern 'dest)
                  ,(construct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)])
            [_ eof])]
        [(Definition-and p0 p1 pN)
         `(match input
            [(and ,@(for/list [(named-pat (list* p0 p1 pN))]
                      (pattern->match-pattern named-pat '_)))
             ,(construct name #f ty)]
            [_ eof])]
        [(Definition-Pattern pattern)
         `(match input
            [,(pattern->match-pattern pattern 'dest)
             ,(construct name #f ty)]
            [_ eof])])))

(define (construct name wrap? ty)
  (match ty
    [(ty-record fields) `(,name ,@(map escape (map car fields)))]
    [(ty-unit) (if wrap? `(,name) `(void))]
    [_ (if wrap? `(,name dest) 'dest)]))

(define (maybe-dest dest-pat-stx pat)
  (match dest-pat-stx
    ['_ pat]
    [_ `(and ,dest-pat-stx ,pat)]))

(define (pattern->match-pattern pattern dest-pat-stx)
  (match (unwrap pattern)
    [(NamedSimplePattern_ n p) (pattern->match-pattern p (maybe-dest dest-pat-stx (escape n)))]
    [(SimplePattern-any) dest-pat-stx]
    [(SimplePattern-atom atom-kind)
     (maybe-dest dest-pat-stx
                 `(? ,(match atom-kind
                        [(AtomKind-Boolean) 'boolean?]
                        [(AtomKind-Float) 'float?]
                        [(AtomKind-Double) 'flonum?]
                        [(AtomKind-SignedInteger) 'integer?]
                        [(AtomKind-String) 'string?]
                        [(AtomKind-ByteString) 'bytes?]
                        [(AtomKind-Symbol) 'symbol?])))]
    [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
    [(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))]
    [(SimplePattern-Ref (Ref '() name))
     `(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))]
    [(SimplePattern-Ref (Ref module-path name))
     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
    [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
     `(parse-sequence list?
                      values
                      ,(pattern->match-pattern variable-pat 'item)
                      item
                      values
                      ,dest-pat-stx)]
    [(CompoundPattern-setof pat)
     `(parse-sequence set?
                      set->list
                      ,(pattern->match-pattern pat 'item)
                      item
                      list->set
                      ,dest-pat-stx)]
    [(CompoundPattern-dictof key-pat value-pat)
     `(parse-sequence dict?
                      dict->list
                      (cons ,(pattern->match-pattern key-pat 'key)
                            ,(pattern->match-pattern value-pat 'value))
                      (cons key value)
                      make-immutable-hash
                      ,dest-pat-stx)]
    [(CompoundPattern-rec label-pat fields-pat)
     (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_)
                                       ,(pattern->match-pattern fields-pat '_)))]
    [(CompoundPattern-tuple named-pats)
     (maybe-dest dest-pat-stx
                 `(list ,@(map (lambda (p) (pattern->match-pattern p '_)) named-pats)))]
    [(CompoundPattern-tuple* fixed-named-pats
                             (NamedSimplePattern-named (NamedSimplePattern_ vname vpat)))
     (maybe-dest dest-pat-stx
                 `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
                         (list ,(pattern->match-pattern vpat (escape vname)) ...)))]
    [(CompoundPattern-dict (hash-table (keys pats) ...))
     (maybe-dest dest-pat-stx
                 `(hash-table ,@(for/list [(key (in-list keys))
                                           (pat (in-list pats))]
                                  `(,(literal->pattern key)
                                    ,(pattern->match-pattern (add-name-if-absent key pat) '_)))
                              (_ _) ...))]))

(define (literal->pattern v)
  (if (symbol? v)
      `',v
      `(== ',v)))