Switch to manipulating parsed form of metaschema
This commit is contained in:
parent
ebab3fafc5
commit
43b776eb7f
|
|
@ -10,18 +10,14 @@
|
|||
(require "type.rkt")
|
||||
(require "parser.rkt")
|
||||
(require "unparser.rkt")
|
||||
(require "gen-schema.rkt")
|
||||
|
||||
(define (struct-stx name-pieces field-names)
|
||||
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
|
||||
|
||||
(define (schema-definition-table schema)
|
||||
(match schema
|
||||
[(record 'schema (list (hash-table ('definitions definition-table) (_ _) ...)))
|
||||
definition-table]))
|
||||
|
||||
(define (struct-defs schema)
|
||||
(reverse (for/fold [(acc '())]
|
||||
[((name def) (in-hash (schema-definition-table schema)))]
|
||||
[((name def) (in-hash (Schema-definitions schema)))]
|
||||
(match (definition-ty def)
|
||||
[(ty-union variants)
|
||||
(for/fold [(acc acc)]
|
||||
|
|
@ -40,11 +36,11 @@
|
|||
acc]))))
|
||||
|
||||
(define (parser-defs schema)
|
||||
(for/list [((name def) (in-hash (schema-definition-table schema)))]
|
||||
(for/list [((name def) (in-hash (Schema-definitions schema)))]
|
||||
(definition-parser name def)))
|
||||
|
||||
(define (unparser-defs schema)
|
||||
(for/list [((name def) (in-hash (schema-definition-table schema)))]
|
||||
(for/list [((name def) (in-hash (Schema-definitions schema)))]
|
||||
(definition-unparser name def)))
|
||||
|
||||
(define (schema->module-stx name schema)
|
||||
|
|
@ -55,15 +51,20 @@
|
|||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require racket/dict)
|
||||
;; TODO: overall predicate for e.g. CompoundPattern, anything with an alternation
|
||||
,@(struct-defs schema)
|
||||
,@(parser-defs schema)
|
||||
,@(unparser-defs schema)))
|
||||
,@(unparser-defs schema)
|
||||
))
|
||||
|
||||
(module+ main
|
||||
(require racket/pretty)
|
||||
(with-output-to-file "gen-schema.rkt" #:exists 'replace
|
||||
(lambda ()
|
||||
(pretty-write
|
||||
(schema->module-stx
|
||||
'gen-schema
|
||||
(with-input-from-file "../../../../schema/schema.bin" read-preserve))))))
|
||||
(define metaschema-module-source
|
||||
(schema->module-stx
|
||||
'gen-schema
|
||||
(parse-Schema
|
||||
(with-input-from-file "../../../../schema/schema.bin" read-preserve))))
|
||||
(if #t
|
||||
(with-output-to-file "gen-schema.rkt" #:exists 'replace
|
||||
(lambda () (pretty-write metaschema-module-source)))
|
||||
(pretty-write metaschema-module-source)))
|
||||
|
|
|
|||
|
|
@ -7,25 +7,27 @@
|
|||
(require (only-in racket/syntax format-symbol))
|
||||
|
||||
(require "type.rkt")
|
||||
(require "gen-schema.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))
|
||||
[(Definition-or p0 p1 pN)
|
||||
`(match input
|
||||
,@(for/list [(named-alt (in-list named-alts))
|
||||
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
|
||||
(alt-ty (in-list (map cadr (ty-union-variants ty))))]
|
||||
(match-define (list variant-label-str pattern) named-alt)
|
||||
(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])]
|
||||
[(record 'and (list named-pats))
|
||||
[(Definition-and p0 p1 pN)
|
||||
`(match input
|
||||
[(and ,@(for/list [(named-pat named-pats)] (pattern->match-pattern named-pat '_)))
|
||||
[(and ,@(for/list [(named-pat (list* p0 p1 pN))]
|
||||
(pattern->match-pattern named-pat '_)))
|
||||
,(construct name #f ty)]
|
||||
[_ eof])]
|
||||
[pattern
|
||||
[(Definition-Pattern pattern)
|
||||
`(match input
|
||||
[,(pattern->match-pattern pattern 'dest)
|
||||
,(construct name #f ty)]
|
||||
|
|
@ -43,40 +45,40 @@
|
|||
[_ `(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))
|
||||
(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
|
||||
['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))
|
||||
[(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-Ref (Ref '() name))
|
||||
`(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))]
|
||||
[(record 'ref (list module-path name))
|
||||
[(SimplePattern-Ref (Ref module-path name))
|
||||
(error 'pattern-parser "Ref with non-empty module path not yet implemented")]
|
||||
[(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
|
||||
[(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
|
||||
`(parse-sequence list?
|
||||
values
|
||||
,(pattern->match-pattern variable-pat 'item)
|
||||
item
|
||||
values
|
||||
,dest-pat-stx)]
|
||||
[(record 'setof (list pat))
|
||||
[(CompoundPattern-setof pat)
|
||||
`(parse-sequence set?
|
||||
set->list
|
||||
,(pattern->match-pattern pat 'item)
|
||||
item
|
||||
list->set
|
||||
,dest-pat-stx)]
|
||||
[(record 'dictof (list key-pat value-pat))
|
||||
[(CompoundPattern-dictof key-pat value-pat)
|
||||
`(parse-sequence dict?
|
||||
dict->list
|
||||
(cons ,(pattern->match-pattern key-pat 'key)
|
||||
|
|
@ -84,17 +86,18 @@
|
|||
(cons key value)
|
||||
make-immutable-hash
|
||||
,dest-pat-stx)]
|
||||
[(record 'rec (list label-pat fields-pat))
|
||||
[(CompoundPattern-rec 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))
|
||||
[(CompoundPattern-tuple 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))))
|
||||
[(CompoundPattern-tuple* fixed-named-pats
|
||||
(NamedSimplePattern-named (NamedSimplePattern_ 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) ...)))
|
||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
||||
(maybe-dest dest-pat-stx
|
||||
`(hash-table ,@(for/list [(key (in-list keys))
|
||||
(pat (in-list pats))]
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
(struct-out ty-dictionary)
|
||||
|
||||
definition-ty
|
||||
unwrap
|
||||
add-name-if-absent
|
||||
escape)
|
||||
|
||||
|
|
@ -16,6 +17,8 @@
|
|||
(require racket/match)
|
||||
(require (only-in racket/syntax format-symbol))
|
||||
|
||||
(require "gen-schema.rkt")
|
||||
|
||||
(struct ty-union (variants) #:transparent)
|
||||
(struct ty-unit () #:transparent)
|
||||
(struct ty-value () #:transparent)
|
||||
|
|
@ -26,57 +29,84 @@
|
|||
|
||||
(define (definition-ty d)
|
||||
(match d
|
||||
[(record 'or (list named-alts))
|
||||
[(Definition-or p0 p1 pN)
|
||||
(ty-union (map (match-lambda
|
||||
[(list variant-label-str pattern)
|
||||
[(NamedAlternative variant-label-str pattern)
|
||||
(list (string->symbol variant-label-str) (pattern-ty pattern))])
|
||||
named-alts))]
|
||||
[(record 'and (list named-pats)) (product-ty named-pats)]
|
||||
[pattern (pattern-ty pattern)]))
|
||||
(list* p0 p1 pN)))]
|
||||
[(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
|
||||
[(Definition-Pattern pattern) (pattern-ty pattern)]))
|
||||
|
||||
(define (product-ty named-pats)
|
||||
(match (gather-fields* named-pats '())
|
||||
['() (ty-unit)]
|
||||
[fields (ty-record fields)]))
|
||||
|
||||
(define (unwrap p)
|
||||
(match p
|
||||
[(Pattern-SimplePattern p) (unwrap p)]
|
||||
[(Pattern-CompoundPattern p) (unwrap p)]
|
||||
[(NamedPattern-named p) (unwrap p)]
|
||||
[(NamedSimplePattern-named p) (unwrap p)]
|
||||
[(NamedPattern-anonymous p) (unwrap p)]
|
||||
[(NamedSimplePattern-anonymous p) (unwrap p)]
|
||||
[_ p]))
|
||||
|
||||
(define (gather-fields* named-pats acc)
|
||||
(foldr gather-fields acc named-pats))
|
||||
|
||||
(define (SimplePattern? p)
|
||||
(or (SimplePattern-any? p)
|
||||
(SimplePattern-atom? p)
|
||||
(SimplePattern-embedded? p)
|
||||
(SimplePattern-lit? p)
|
||||
(SimplePattern-Ref? p)))
|
||||
|
||||
(define (CompoundPattern? p)
|
||||
(or (CompoundPattern-rec? p)
|
||||
(CompoundPattern-tuple? p)
|
||||
(CompoundPattern-tuple*? p)
|
||||
(CompoundPattern-setof? p)
|
||||
(CompoundPattern-dictof? p)
|
||||
(CompoundPattern-dict? p)))
|
||||
|
||||
(define (gather-fields named-pat acc)
|
||||
(match named-pat
|
||||
[(record 'named (list n p))
|
||||
(match (unwrap named-pat)
|
||||
[(NamedSimplePattern_ n p)
|
||||
(match (pattern-ty p)
|
||||
[(ty-unit) acc]
|
||||
[ty (cons (list n ty) acc)])]
|
||||
[(record 'rec (list label-named-pat fields-named-pat))
|
||||
[(CompoundPattern-rec label-named-pat fields-named-pat)
|
||||
(gather-fields label-named-pat (gather-fields fields-named-pat acc))]
|
||||
[(record 'tuple (list named-pats)) (gather-fields* named-pats acc)]
|
||||
[(record 'tuple* (list fixed-named-pats variable-named-pat))
|
||||
[(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))]
|
||||
[(record 'dict (list (hash-table (keys pats) ...)))
|
||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
||||
(gather-fields* (map add-name-if-absent keys pats) acc)]
|
||||
[_ acc]))
|
||||
[(? SimplePattern?) acc]
|
||||
[(? CompoundPattern?) acc]))
|
||||
|
||||
(define (pattern-ty p)
|
||||
(match p
|
||||
['any (ty-value)]
|
||||
[(record 'atom (list _atom-kind)) (ty-value)]
|
||||
[(record 'embedded '()) (ty-value)]
|
||||
[(record 'lit (list _value)) (ty-unit)]
|
||||
[(record 'ref (list _module-path _name)) (ty-value)]
|
||||
[(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
|
||||
(match (unwrap p)
|
||||
[(SimplePattern-any) (ty-value)]
|
||||
[(SimplePattern-atom _atomKind) (ty-value)]
|
||||
[(SimplePattern-embedded) (ty-value)]
|
||||
[(SimplePattern-lit _value) (ty-unit)]
|
||||
[(SimplePattern-Ref _r) (ty-value)]
|
||||
[(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
|
||||
(ty-array (pattern-ty variable-pat))]
|
||||
[(record 'setof (list pat)) (ty-set (pattern-ty pat))]
|
||||
[(record 'dictof (list key-pat value-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))]
|
||||
[_ (product-ty (list p))]))
|
||||
[(? CompoundPattern?) (product-ty (list p))]))
|
||||
|
||||
(define (add-name-if-absent k p)
|
||||
(match p
|
||||
[(record 'named _) p]
|
||||
[_ (match (namelike k)
|
||||
[#f p]
|
||||
[s (record 'named (list s p))])]))
|
||||
[(NamedSimplePattern-named _) p]
|
||||
[(NamedSimplePattern-anonymous _)
|
||||
(match (namelike k)
|
||||
[#f p]
|
||||
[s (NamedSimplePattern-named (NamedSimplePattern_ s p))])]))
|
||||
|
||||
(define (namelike v)
|
||||
(match v
|
||||
|
|
|
|||
|
|
@ -8,6 +8,7 @@
|
|||
(require (only-in racket/list append-map))
|
||||
|
||||
(require "type.rkt")
|
||||
(require "gen-schema.rkt")
|
||||
|
||||
(define (simple-pattern? p)
|
||||
(match p
|
||||
|
|
@ -22,14 +23,14 @@
|
|||
(define ty (definition-ty def))
|
||||
`(define (,(format-symbol "~a->preserves" name) input)
|
||||
,(match def
|
||||
[(record 'or (list named-alts))
|
||||
[(Definition-or p0 p1 pN)
|
||||
`(match input
|
||||
,@(for/list [(named-alt (in-list named-alts))
|
||||
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
|
||||
(alt-ty (in-list (map cadr (ty-union-variants ty))))]
|
||||
(match-define (list variant-label-str pattern) named-alt)
|
||||
(match-define (NamedAlternative variant-label-str pattern) named-alt)
|
||||
`[,(deconstruct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)
|
||||
,(pattern->unparser pattern 'src)]))]
|
||||
[(record 'and (list named-pats))
|
||||
[(Definition-and p0 p1 pN)
|
||||
`(match input
|
||||
[,(deconstruct name #f ty)
|
||||
(merge-preserves (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge")))
|
||||
|
|
@ -38,8 +39,8 @@
|
|||
(if (simple-pattern? named-pat)
|
||||
'()
|
||||
(list (pattern->unparser named-pat 'src))))
|
||||
named-pats))])]
|
||||
[pattern
|
||||
(list* p0 p1 pN)))])]
|
||||
[(Definition-Pattern pattern)
|
||||
`(match input
|
||||
[,(deconstruct name #f ty)
|
||||
,(pattern->unparser pattern 'src)])])))
|
||||
|
|
@ -51,31 +52,32 @@
|
|||
[_ (if wrap? `(,name src) 'src)]))
|
||||
|
||||
(define (pattern->unparser pattern src-stx)
|
||||
(match pattern
|
||||
[(record 'named (list n p)) (pattern->unparser p (escape n))]
|
||||
['any src-stx]
|
||||
[(record 'atom (list _atom-kind)) src-stx]
|
||||
[(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")]
|
||||
[(record 'lit (list v)) `',v]
|
||||
[(record 'ref (list '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
|
||||
[(record 'ref (list module-path name))
|
||||
(match (unwrap pattern)
|
||||
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
|
||||
[(SimplePattern-any) src-stx]
|
||||
[(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")]
|
||||
[(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
|
||||
[(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
|
||||
`(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
|
||||
[(record 'setof (list pat))
|
||||
[(CompoundPattern-setof pat)
|
||||
`(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
|
||||
[(record 'dictof (list key-pat value-pat))
|
||||
[(CompoundPattern-dictof key-pat value-pat)
|
||||
`(for/hash [((key value) (in-dict ,src-stx))]
|
||||
(values ,(pattern->unparser key-pat 'key)
|
||||
,(pattern->unparser value-pat 'value)))]
|
||||
[(record 'rec (list label-pat fields-pat))
|
||||
[(CompoundPattern-rec label-pat fields-pat)
|
||||
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
|
||||
[(record 'tuple (list named-pats))
|
||||
[(CompoundPattern-tuple named-pats)
|
||||
`(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))]
|
||||
[(record 'tuple* (list fixed-named-pats (record 'named (list vname vpat))))
|
||||
[(CompoundPattern-tuple* fixed-named-pats
|
||||
(NamedSimplePattern-named (NamedSimplePattern_ vname vpat)))
|
||||
`(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)))]
|
||||
[(record 'dict (list (hash-table (keys pats) ...)))
|
||||
[(CompoundPattern-dict (hash-table (keys pats) ...))
|
||||
`(hash ,@(append-map (lambda (key pat)
|
||||
(list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
|
||||
keys pats))]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue