#lang racket/base

(provide pattern->match-pattern
         Ref-parser-name
         Ref-parser!-name)

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

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

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

(define (pattern->match-pattern pattern dest-pat-stx)
  (match (unwrap pattern)
    [(Binding 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-Double) 'flonum?]
                        [(AtomKind-SignedInteger) 'exact-integer?]
                        [(AtomKind-String) 'string?]
                        [(AtomKind-ByteString) 'bytes?]
                        [(AtomKind-Symbol) 'symbol?])))]
    [(SimplePattern-embedded _interface)
     `(embedded ,(maybe-dest dest-pat-stx `_))]
    [(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))]
    [(SimplePattern-seqof variable-pat)
     `(list ,(pattern->match-pattern variable-pat dest-pat-stx) ...)]
    [(SimplePattern-setof pat)
     `(parse-sequence set?
                      set->list
                      ,(pattern->match-pattern pat 'item)
                      item
                      list->set
                      ,dest-pat-stx)]
    [(SimplePattern-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)]
    [(SimplePattern-Ref r)
     `(app ,(Ref-parser-name r) ,(maybe-dest dest-pat-stx `(not (== eof))))]
    [(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-tuplePrefix fixed-named-pats variable-named-pat)
     (maybe-dest dest-pat-stx
                 (if (null? fixed-named-pats)
                     (pattern->match-pattern variable-named-pat '_)
                     `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
                             ,(pattern->match-pattern variable-named-pat '_))))]
    [(CompoundPattern-dict (DictionaryEntries entries))
     (maybe-dest dest-pat-stx
                 `(hash-table ,@(map (lambda (entry)
                                       `(,(literal->pattern (car entry))
                                         ,(pattern->match-pattern (cdr entry) '_)))
                                     (sorted-dict-entries entries))
                              (_ _) ...))]))

(define (Ref-parser-name r)
  (match-define (Ref (ModulePath module-path) name) r)
  (format-symbol "~aparse-~a" (module-path-prefix module-path) name))

(define (Ref-parser!-name r)
  (match-define (Ref (ModulePath module-path) name) r)
  (format-symbol "~aparse-~a!" (module-path-prefix module-path) name))

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