112 lines
4.7 KiB
Racket
112 lines
4.7 KiB
Racket
#lang racket/base
|
|
|
|
(provide definition-parsers)
|
|
|
|
(require preserves)
|
|
(require racket/match)
|
|
(require (only-in racket/syntax format-symbol))
|
|
|
|
(require "type.rkt")
|
|
(require "gen/schema.rkt")
|
|
|
|
(define (definition-parsers name def)
|
|
(define ty (definition-ty def))
|
|
`(begin
|
|
(define (,(format-symbol "parse-~a" 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)
|
|
`[,(pattern->match-pattern pattern 'dest)
|
|
,(construct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)])
|
|
[_ eof])]
|
|
[(Definition-and p0 p1 pN)
|
|
`(match input
|
|
[(and ,@(for/list [(named-pat (list* p0 p1 pN))]
|
|
(pattern->match-pattern named-pat '_)))
|
|
,(construct name #f ty)]
|
|
[_ eof])]
|
|
[(Definition-Pattern pattern)
|
|
`(match input
|
|
[,(pattern->match-pattern pattern 'dest)
|
|
,(construct name #f ty)]
|
|
[_ eof])]))
|
|
(define ,(format-symbol "parse-~a!" name)
|
|
(parse-success-or-error ',(format-symbol "parse-~a" name)
|
|
,(format-symbol "parse-~a" name)))))
|
|
|
|
(define (construct name wrap? ty)
|
|
(match ty
|
|
[(ty-record fields) `(,name ,@(map escape (map car fields)))]
|
|
[(ty-unit) (if wrap? `(,name) `(void))]
|
|
[_ (if wrap? `(,name dest) 'dest)]))
|
|
|
|
(define (maybe-dest dest-pat-stx pat)
|
|
(match dest-pat-stx
|
|
['_ pat]
|
|
[_ `(and ,dest-pat-stx ,pat)]))
|
|
|
|
(define (pattern->match-pattern pattern dest-pat-stx)
|
|
(match (unwrap pattern)
|
|
[(NamedSimplePattern_ 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) 'integer?]
|
|
[(AtomKind-String) 'string?]
|
|
[(AtomKind-ByteString) 'bytes?]
|
|
[(AtomKind-Symbol) 'symbol?])))]
|
|
[(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
|
|
[(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 (Ref '() name))
|
|
`(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))]
|
|
[(SimplePattern-Ref (Ref module-path name))
|
|
(error 'pattern-parser "Ref with non-empty module path not yet implemented")]
|
|
[(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-tuple* 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 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 (literal->pattern v)
|
|
(if (symbol? v)
|
|
`',v
|
|
`(== ',v)))
|