#lang racket/base

(provide definition-unparser)

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

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

(define (simple-pattern? p)
  (match p
    ['any #t]
    [(record 'atom _) #t]
    [(record 'embedded _) #t]
    [(record 'lit _) #t]
    [(record 'ref _) #t]
    [_ #f]))

(define (definition-unparser name def)
  (define ty (definition-ty def))
  `(define (,(format-symbol "~a->preserves" 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)
                `[,(deconstruct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)
                  ,(pattern->unparser pattern 'src)]))]
        [(Definition-and p0 p1 pN)
         `(match input
            [,(deconstruct name #f ty)
             (merge-preserves (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge")))
                              ,@(append-map
                                 (lambda (named-pat)
                                   (if (simple-pattern? named-pat)
                                       '()
                                       (list (pattern->unparser named-pat 'src))))
                                 (list* p0 p1 pN)))])]
        [(Definition-Pattern pattern)
         `(match input
            [,(deconstruct name #f ty)
             ,(pattern->unparser pattern 'src)])])))

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

(define (pattern->unparser pattern src-stx)
  (match (unwrap pattern)
    [(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
    [(SimplePattern-any) src-stx]
    [(SimplePattern-atom _) src-stx]
    [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
    [(SimplePattern-lit v) `',v]
    [(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
    [(SimplePattern-Ref (Ref module-path name))
     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
    [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
     `(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
    [(CompoundPattern-setof pat)
     `(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
    [(CompoundPattern-dictof key-pat value-pat)
     `(for/hash [((key value) (in-dict ,src-stx))]
        (values ,(pattern->unparser key-pat 'key)
                ,(pattern->unparser value-pat 'value)))]
    [(CompoundPattern-rec label-pat fields-pat)
     `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
    [(CompoundPattern-tuple named-pats)
     `(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))]
    [(CompoundPattern-tuple* fixed-named-pats
                             (NamedSimplePattern-named (NamedSimplePattern_ vname vpat)))
     `(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
             (for/list [(item (in-list ,(escape vname)))] ,(pattern->unparser vpat 'item)))]
    [(CompoundPattern-dict (hash-table (keys pats) ...))
     `(hash ,@(append-map (lambda (key pat)
                            (list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
                          keys pats))]))