89 lines
3.6 KiB
Racket
89 lines
3.6 KiB
Racket
#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-Float) 'float?]
|
|
[(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)))
|