82 lines
3.5 KiB
Racket
82 lines
3.5 KiB
Racket
#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")
|
|
|
|
(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
|
|
[(record 'or (list named-alts))
|
|
`(match input
|
|
,@(for/list [(named-alt (in-list named-alts))
|
|
(alt-ty (in-list (map cadr (ty-union-variants ty))))]
|
|
(match-define (list variant-label-str pattern) named-alt)
|
|
`[,(deconstruct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)
|
|
,(pattern->unparser pattern 'src)]))]
|
|
[(record 'and (list named-pats))
|
|
`(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))))
|
|
named-pats))])]
|
|
[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 pattern
|
|
[(record 'named (list n p)) (pattern->unparser p (escape n))]
|
|
['any src-stx]
|
|
[(record 'atom (list _atom-kind)) src-stx]
|
|
[(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")]
|
|
[(record 'lit (list v)) `',v]
|
|
[(record 'ref (list '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
|
|
[(record 'ref (list module-path name))
|
|
(error 'pattern-parser "Ref with non-empty module path not yet implemented")]
|
|
[(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
|
|
`(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
|
|
[(record 'setof (list pat))
|
|
`(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
|
|
[(record 'dictof (list key-pat value-pat))
|
|
`(for/hash [((key value) (in-dict ,src-stx))]
|
|
(values ,(pattern->unparser key-pat 'key)
|
|
,(pattern->unparser value-pat 'value)))]
|
|
[(record 'rec (list label-pat fields-pat))
|
|
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
|
|
[(record 'tuple (list named-pats))
|
|
`(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))]
|
|
[(record 'tuple* (list fixed-named-pats (record 'named (list 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)))]
|
|
[(record 'dict (list (hash-table (keys pats) ...)))
|
|
`(hash ,@(append-map (lambda (key pat)
|
|
(list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
|
|
keys pats))]))
|