2021-05-21 19:44:05 +00:00
|
|
|
#lang racket/base
|
|
|
|
|
2021-06-08 13:26:32 +00:00
|
|
|
(provide pattern->unparser)
|
2021-05-21 19:44:05 +00:00
|
|
|
|
|
|
|
(require preserves)
|
|
|
|
(require racket/match)
|
|
|
|
(require (only-in racket/syntax format-symbol))
|
|
|
|
(require (only-in racket/list append-map))
|
|
|
|
|
|
|
|
(require "type.rkt")
|
2021-05-22 13:52:12 +00:00
|
|
|
(require "gen/schema.rkt")
|
2021-05-21 19:44:05 +00:00
|
|
|
|
|
|
|
(define (pattern->unparser pattern src-stx)
|
2021-05-22 13:47:13 +00:00
|
|
|
(match (unwrap pattern)
|
|
|
|
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
|
|
|
|
[(SimplePattern-any) src-stx]
|
2021-06-09 18:02:06 +00:00
|
|
|
[(SimplePattern-atom (AtomKind-Float)) `(->float ,src-stx)]
|
|
|
|
[(SimplePattern-atom (AtomKind-Double)) `(exact->inexact ,src-stx)]
|
2021-05-22 13:47:13 +00:00
|
|
|
[(SimplePattern-atom _) src-stx]
|
2021-06-08 07:27:03 +00:00
|
|
|
[(SimplePattern-embedded _interface) `(embedded ,src-stx)]
|
2021-05-22 13:47:13 +00:00
|
|
|
[(SimplePattern-lit v) `',v]
|
2021-05-24 08:09:17 +00:00
|
|
|
[(SimplePattern-seqof variable-pat)
|
2021-05-21 19:44:05 +00:00
|
|
|
`(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
|
2021-05-24 08:09:17 +00:00
|
|
|
[(SimplePattern-setof pat)
|
2021-05-21 19:44:05 +00:00
|
|
|
`(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
|
2021-05-24 08:09:17 +00:00
|
|
|
[(SimplePattern-dictof key-pat value-pat)
|
2021-05-21 19:44:05 +00:00
|
|
|
`(for/hash [((key value) (in-dict ,src-stx))]
|
|
|
|
(values ,(pattern->unparser key-pat 'key)
|
|
|
|
,(pattern->unparser value-pat 'value)))]
|
2021-05-27 07:53:55 +00:00
|
|
|
[(SimplePattern-Ref r)
|
2021-06-08 13:26:32 +00:00
|
|
|
`(*->preserve ,src-stx)]
|
2021-05-22 13:47:13 +00:00
|
|
|
[(CompoundPattern-rec label-pat fields-pat)
|
2021-05-21 19:44:05 +00:00
|
|
|
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
|
2021-05-22 13:47:13 +00:00
|
|
|
[(CompoundPattern-tuple named-pats)
|
2021-05-21 19:44:05 +00:00
|
|
|
`(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))]
|
2021-05-24 08:09:17 +00:00
|
|
|
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
2021-05-21 19:44:05 +00:00
|
|
|
`(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
|
2021-05-24 08:09:17 +00:00
|
|
|
,(pattern->unparser variable-named-pat src-stx))]
|
2021-06-08 13:49:27 +00:00
|
|
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
2021-05-24 15:46:50 +00:00
|
|
|
`(hash ,@(append-map (lambda (entry)
|
|
|
|
(list `',(car entry)
|
2021-05-25 09:04:29 +00:00
|
|
|
(pattern->unparser (cdr entry) src-stx)))
|
2021-05-24 15:46:50 +00:00
|
|
|
(sorted-dict-entries entries)))]))
|