Follow improvements through Racket schema impl
This commit is contained in:
parent
2559a4713f
commit
c4bfc0eefc
|
@ -14,11 +14,17 @@
|
|||
(SimplePattern-atom? p)
|
||||
(SimplePattern-embedded? p)
|
||||
(SimplePattern-lit? p)
|
||||
(SimplePattern-seqof? p)
|
||||
(SimplePattern-setof? p)
|
||||
(SimplePattern-dictof? p)
|
||||
(SimplePattern-Ref? p)))
|
||||
(struct SimplePattern-any () #:prefab)
|
||||
(struct SimplePattern-atom (atomKind) #:prefab)
|
||||
(struct SimplePattern-embedded () #:prefab)
|
||||
(struct SimplePattern-lit (value) #:prefab)
|
||||
(struct SimplePattern-seqof (pattern) #:prefab)
|
||||
(struct SimplePattern-setof (pattern) #:prefab)
|
||||
(struct SimplePattern-dictof (key value) #:prefab)
|
||||
(struct SimplePattern-Ref (value) #:prefab)
|
||||
(struct NamedAlternative (variantLabel pattern) #:prefab)
|
||||
(struct Schema (version embeddedType definitions) #:prefab)
|
||||
|
@ -30,14 +36,10 @@
|
|||
(or (CompoundPattern-rec? p)
|
||||
(CompoundPattern-tuple? p)
|
||||
(CompoundPattern-tuple*? p)
|
||||
(CompoundPattern-setof? p)
|
||||
(CompoundPattern-dictof? p)
|
||||
(CompoundPattern-dict? p)))
|
||||
(struct CompoundPattern-rec (label fields) #:prefab)
|
||||
(struct CompoundPattern-tuple (patterns) #:prefab)
|
||||
(struct CompoundPattern-tuple* (fixed variable) #:prefab)
|
||||
(struct CompoundPattern-setof (pattern) #:prefab)
|
||||
(struct CompoundPattern-dictof (key value) #:prefab)
|
||||
(struct CompoundPattern-dict (entries) #:prefab)
|
||||
(struct Ref (module name) #:prefab)
|
||||
(struct Bundle (modules) #:prefab)
|
||||
|
@ -89,6 +91,23 @@
|
|||
(SimplePattern-atom $atomKind))
|
||||
((and dest (record 'embedded (list))) (SimplePattern-embedded))
|
||||
((and dest (record 'lit (list $value))) (SimplePattern-lit $value))
|
||||
((and dest
|
||||
(record
|
||||
'seqof
|
||||
(list (app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(SimplePattern-seqof $pattern))
|
||||
((and dest
|
||||
(record
|
||||
'setof
|
||||
(list (app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(SimplePattern-setof $pattern))
|
||||
((and dest
|
||||
(record
|
||||
'dictof
|
||||
(list
|
||||
(app parse-SimplePattern (and $key (not (== eof))))
|
||||
(app parse-SimplePattern (and $value (not (== eof)))))))
|
||||
(SimplePattern-dictof $key $value))
|
||||
((app parse-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest))
|
||||
(_ eof)))
|
||||
(define (parse-NamedAlternative input)
|
||||
|
@ -153,31 +172,17 @@
|
|||
(record
|
||||
'tuple
|
||||
(list
|
||||
(list*
|
||||
(list
|
||||
(app parse-NamedPattern (and $patterns (not (== eof))))
|
||||
...)))))
|
||||
(list
|
||||
(app parse-NamedPattern (and $patterns (not (== eof))))
|
||||
...))))
|
||||
(CompoundPattern-tuple $patterns))
|
||||
((and dest
|
||||
(record
|
||||
'tuple*
|
||||
(list
|
||||
(list*
|
||||
(list (app parse-NamedPattern (and $fixed (not (== eof)))) ...))
|
||||
(list (app parse-NamedPattern (and $fixed (not (== eof)))) ...)
|
||||
(app parse-NamedSimplePattern (and $variable (not (== eof)))))))
|
||||
(CompoundPattern-tuple* $fixed $variable))
|
||||
((and dest
|
||||
(record
|
||||
'setof
|
||||
(list (app parse-SimplePattern (and $pattern (not (== eof)))))))
|
||||
(CompoundPattern-setof $pattern))
|
||||
((and dest
|
||||
(record
|
||||
'dictof
|
||||
(list
|
||||
(app parse-SimplePattern (and $key (not (== eof))))
|
||||
(app parse-SimplePattern (and $value (not (== eof)))))))
|
||||
(CompoundPattern-dictof $key $value))
|
||||
((and dest
|
||||
(record
|
||||
'dict
|
||||
|
@ -272,11 +277,7 @@
|
|||
((and dest (== '#f)) (EmbeddedTypeName-false))
|
||||
(_ eof)))
|
||||
(define (parse-ModulePath input)
|
||||
(match
|
||||
input
|
||||
((parse-sequence list? values (and item (? symbol?)) item values dest)
|
||||
dest)
|
||||
(_ eof)))
|
||||
(match input ((list (and dest (? symbol?)) ...) dest) (_ eof)))
|
||||
(define (parse-AtomKind input)
|
||||
(match
|
||||
input
|
||||
|
@ -315,6 +316,16 @@
|
|||
(record 'atom (list (AtomKind->preserves $atomKind))))
|
||||
((SimplePattern-embedded) (record 'embedded (list)))
|
||||
((SimplePattern-lit $value) (record 'lit (list $value)))
|
||||
((SimplePattern-seqof $pattern)
|
||||
(record 'seqof (list (SimplePattern->preserves $pattern))))
|
||||
((SimplePattern-setof $pattern)
|
||||
(record 'setof (list (SimplePattern->preserves $pattern))))
|
||||
((SimplePattern-dictof $key $value)
|
||||
(record
|
||||
'dictof
|
||||
(list
|
||||
(SimplePattern->preserves $key)
|
||||
(SimplePattern->preserves $value))))
|
||||
((SimplePattern-Ref src) (Ref->preserves src))))
|
||||
(define (NamedAlternative->preserves input)
|
||||
(match
|
||||
|
@ -360,25 +371,15 @@
|
|||
(record
|
||||
'tuple
|
||||
(list
|
||||
(list*
|
||||
(for/list
|
||||
((item (in-list $patterns)))
|
||||
(NamedPattern->preserves item))))))
|
||||
(for/list
|
||||
((item (in-list $patterns)))
|
||||
(NamedPattern->preserves item)))))
|
||||
((CompoundPattern-tuple* $fixed $variable)
|
||||
(record
|
||||
'tuple*
|
||||
(list
|
||||
(list*
|
||||
(for/list ((item (in-list $fixed))) (NamedPattern->preserves item)))
|
||||
(for/list ((item (in-list $fixed))) (NamedPattern->preserves item))
|
||||
(NamedSimplePattern->preserves $variable))))
|
||||
((CompoundPattern-setof $pattern)
|
||||
(record 'setof (list (SimplePattern->preserves $pattern))))
|
||||
((CompoundPattern-dictof $key $value)
|
||||
(record
|
||||
'dictof
|
||||
(list
|
||||
(SimplePattern->preserves $key)
|
||||
(SimplePattern->preserves $value))))
|
||||
((CompoundPattern-dict $entries)
|
||||
(record 'dict (list (DictionaryEntries->preserves $entries))))))
|
||||
(define (Modules->preserves input)
|
||||
|
|
|
@ -60,25 +60,16 @@
|
|||
[(AtomKind-Symbol) 'symbol?])))]
|
||||
[(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
|
||||
[(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))]
|
||||
[(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-tuple* '() (NamedSimplePattern-anonymous variable-pat))
|
||||
`(parse-sequence list?
|
||||
values
|
||||
,(pattern->match-pattern variable-pat 'item)
|
||||
item
|
||||
values
|
||||
,dest-pat-stx)]
|
||||
[(CompoundPattern-setof pat)
|
||||
[(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)]
|
||||
[(CompoundPattern-dictof key-pat value-pat)
|
||||
[(SimplePattern-dictof key-pat value-pat)
|
||||
`(parse-sequence dict?
|
||||
dict->list
|
||||
(cons ,(pattern->match-pattern key-pat 'key)
|
||||
|
@ -86,17 +77,22 @@
|
|||
(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
|
||||
(NamedSimplePattern-named (NamedSimplePattern_ vname vpat)))
|
||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||
(maybe-dest dest-pat-stx
|
||||
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
|
||||
(list ,(pattern->match-pattern vpat (escape vname)) ...)))]
|
||||
(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 (hash-table (keys pats) ...))
|
||||
(maybe-dest dest-pat-stx
|
||||
`(hash-table ,@(for/list [(key (in-list keys))
|
||||
|
|
|
@ -61,15 +61,15 @@
|
|||
(match (pattern-ty p)
|
||||
[(ty-unit) acc]
|
||||
[ty (cons (list n ty) acc)])]
|
||||
[(? SimplePattern?) acc]
|
||||
[(CompoundPattern-rec label-named-pat fields-named-pat)
|
||||
(gather-fields label-named-pat (gather-fields fields-named-pat acc))]
|
||||
[(CompoundPattern-tuple named-pats) (gather-fields* named-pats acc)]
|
||||
[(CompoundPattern-tuple named-pats)
|
||||
(gather-fields* named-pats acc)]
|
||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
|
||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
||||
(gather-fields* (map add-name-if-absent keys pats) acc)]
|
||||
[(? SimplePattern?) acc]
|
||||
[(? CompoundPattern?) acc]))
|
||||
(gather-fields* (map add-name-if-absent keys pats) acc)]))
|
||||
|
||||
(define (pattern-ty p)
|
||||
(match (unwrap p)
|
||||
|
@ -77,12 +77,10 @@
|
|||
[(SimplePattern-atom _atomKind) (ty-value)]
|
||||
[(SimplePattern-embedded) (ty-value)]
|
||||
[(SimplePattern-lit _value) (ty-unit)]
|
||||
[(SimplePattern-seqof pat) (ty-array (pattern-ty pat))]
|
||||
[(SimplePattern-setof pat) (ty-set (pattern-ty pat))]
|
||||
[(SimplePattern-dictof kp vp) (ty-dictionary (pattern-ty kp) (pattern-ty vp))]
|
||||
[(SimplePattern-Ref _r) (ty-value)]
|
||||
[(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
|
||||
(ty-array (pattern-ty variable-pat))]
|
||||
[(CompoundPattern-setof pat) (ty-set (pattern-ty pat))]
|
||||
[(CompoundPattern-dictof key-pat value-pat)
|
||||
(ty-dictionary (pattern-ty key-pat) (pattern-ty value-pat))]
|
||||
[(? CompoundPattern?) (product-ty (list p))]))
|
||||
|
||||
(define (add-name-if-absent k p)
|
||||
|
|
|
@ -58,25 +58,24 @@
|
|||
[(SimplePattern-atom _) src-stx]
|
||||
[(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
|
||||
[(SimplePattern-lit v) `',v]
|
||||
[(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
|
||||
[(SimplePattern-Ref (Ref module-path name))
|
||||
(error 'pattern-parser "Ref with non-empty module path not yet implemented")]
|
||||
[(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
|
||||
[(SimplePattern-seqof variable-pat)
|
||||
`(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
|
||||
[(CompoundPattern-setof pat)
|
||||
[(SimplePattern-setof pat)
|
||||
`(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
|
||||
[(CompoundPattern-dictof key-pat value-pat)
|
||||
[(SimplePattern-dictof key-pat value-pat)
|
||||
`(for/hash [((key value) (in-dict ,src-stx))]
|
||||
(values ,(pattern->unparser key-pat 'key)
|
||||
,(pattern->unparser value-pat 'value)))]
|
||||
[(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
|
||||
[(SimplePattern-Ref (Ref module-path name))
|
||||
(error 'pattern-parser "Ref with non-empty module path not yet implemented")]
|
||||
[(CompoundPattern-rec label-pat fields-pat)
|
||||
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
|
||||
[(CompoundPattern-tuple named-pats)
|
||||
`(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))]
|
||||
[(CompoundPattern-tuple* fixed-named-pats
|
||||
(NamedSimplePattern-named (NamedSimplePattern_ vname vpat)))
|
||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||
`(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)))]
|
||||
,(pattern->unparser variable-named-pat src-stx))]
|
||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
||||
`(hash ,@(append-map (lambda (key pat)
|
||||
(list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
|
||||
|
|
Loading…
Reference in New Issue