109 lines
4.4 KiB
Racket
109 lines
4.4 KiB
Racket
#lang racket/base
|
|
|
|
(provide definition-parser)
|
|
|
|
(require preserves)
|
|
(require racket/match)
|
|
(require (only-in racket/syntax format-symbol))
|
|
|
|
(require "type.rkt")
|
|
|
|
(define (definition-parser name def)
|
|
(define ty (definition-ty def))
|
|
`(define (,(format-symbol "parse-~a" 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)
|
|
`[,(pattern->match-pattern pattern 'dest)
|
|
,(construct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)])
|
|
[_ eof])]
|
|
[(record 'and (list named-pats))
|
|
`(match input
|
|
[(and ,@(for/list [(named-pat named-pats)] (pattern->match-pattern named-pat '_)))
|
|
,(construct name #f ty)]
|
|
[_ eof])]
|
|
[pattern
|
|
`(match input
|
|
[,(pattern->match-pattern pattern 'dest)
|
|
,(construct name #f ty)]
|
|
[_ eof])])))
|
|
|
|
(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 pattern
|
|
[(record 'named (list n p)) (pattern->match-pattern p (maybe-dest dest-pat-stx (escape n)))]
|
|
['any dest-pat-stx]
|
|
[(record 'atom (list atom-kind))
|
|
(maybe-dest dest-pat-stx
|
|
`(? ,(match atom-kind
|
|
['Boolean 'boolean?]
|
|
['Float 'float?]
|
|
['Double 'flonum?]
|
|
['SignedInteger 'integer?]
|
|
['String 'string?]
|
|
['ByteString 'bytes?]
|
|
['Symbol 'symbol?])))]
|
|
[(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")]
|
|
[(record 'lit (list v)) (maybe-dest dest-pat-stx (literal->pattern v))]
|
|
[(record 'ref (list '() name))
|
|
`(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))]
|
|
[(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 _)))))
|
|
`(parse-sequence list?
|
|
values
|
|
,(pattern->match-pattern variable-pat 'item)
|
|
item
|
|
values
|
|
,dest-pat-stx)]
|
|
[(record 'setof (list pat))
|
|
`(parse-sequence set?
|
|
set->list
|
|
,(pattern->match-pattern pat 'item)
|
|
item
|
|
list->set
|
|
,dest-pat-stx)]
|
|
[(record 'dictof (list 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)]
|
|
[(record 'rec (list label-pat fields-pat))
|
|
(maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_)
|
|
,(pattern->match-pattern fields-pat '_)))]
|
|
[(record 'tuple (list named-pats))
|
|
(maybe-dest dest-pat-stx
|
|
`(list ,@(map (lambda (p) (pattern->match-pattern p '_)) named-pats)))]
|
|
[(record 'tuple* (list fixed-named-pats (record 'named (list vname vpat))))
|
|
(maybe-dest dest-pat-stx
|
|
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
|
|
(list ,(pattern->match-pattern vpat (escape vname)) ...)))]
|
|
[(record 'dict (list (hash-table (keys pats) ...)))
|
|
(maybe-dest dest-pat-stx
|
|
`(hash-table ,@(for/list [(key (in-list keys))
|
|
(pat (in-list pats))]
|
|
`(,(literal->pattern key)
|
|
,(pattern->match-pattern (add-name-if-absent key pat) '_)))
|
|
(_ _) ...))]))
|
|
|
|
(define (literal->pattern v)
|
|
(if (symbol? v)
|
|
`',v
|
|
`(== ',v)))
|