syndicate-lang
/
preserves
mirror of https://gitlab.com/preserves/preserves.git
1
0
Fork 1
Code Releases Activity

Switch to manipulating parsed form of metaschema

This commit is contained in:
Tony Garnock-Jones 2021-05-22 15:47:13 +02:00
parent ebab3fafc5
commit 43b776eb7f
4 changed files with 126 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
implementations/racket/preserves/preserves-schema/main.rkt
View File

@ -10,18 +10,14 @@
(require "type.rkt") (require "type.rkt")
(require "parser.rkt") (require "parser.rkt")
(require "unparser.rkt") (require "unparser.rkt")
(require "gen-schema.rkt")
(define (struct-stx name-pieces field-names) (define (struct-stx name-pieces field-names)
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab)) `(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) (define (struct-defs schema)
(reverse (for/fold [(acc '())] (reverse (for/fold [(acc '())]
[((name def) (in-hash (schema-definition-table schema)))] [((name def) (in-hash (Schema-definitions schema)))]
(match (definition-ty def) (match (definition-ty def)
[(ty-union variants) [(ty-union variants)
(for/fold [(acc acc)] (for/fold [(acc acc)]
@ -40,11 +36,11 @@
acc])))) acc]))))
(define (parser-defs schema) (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))) (definition-parser name def)))
(define (unparser-defs schema) (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))) (definition-unparser name def)))
(define (schema->module-stx name schema) (define (schema->module-stx name schema)
@ -55,15 +51,20 @@
(require racket/match) (require racket/match)
(require racket/set) (require racket/set)
(require racket/dict) (require racket/dict)
;; TODO: overall predicate for e.g. CompoundPattern, anything with an alternation
,@(struct-defs schema) ,@(struct-defs schema)
,@(parser-defs schema) ,@(parser-defs schema)
,@(unparser-defs schema))) ,@(unparser-defs schema)
))
(module+ main (module+ main
(require racket/pretty) (require racket/pretty)
(with-output-to-file "gen-schema.rkt" #:exists 'replace (define metaschema-module-source
(lambda () (schema->module-stx
(pretty-write 'gen-schema
(schema->module-stx (parse-Schema
'gen-schema (with-input-from-file "../../../../schema/schema.bin" read-preserve))))
(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)))

59
implementations/racket/preserves/preserves-schema/parser.rkt
View File

@ -7,25 +7,27 @@
(require (only-in racket/syntax format-symbol)) (require (only-in racket/syntax format-symbol))
(require "type.rkt") (require "type.rkt")
(require "gen-schema.rkt")
(define (definition-parser name def) (define (definition-parser name def)
(define ty (definition-ty def)) (define ty (definition-ty def))
`(define (,(format-symbol "parse-~a" name) input) `(define (,(format-symbol "parse-~a" name) input)
,(match def ,(match def
[(record 'or (list named-alts)) [(Definition-or p0 p1 pN)
`(match input `(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))))] (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) `[,(pattern->match-pattern pattern 'dest)
,(construct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)]) ,(construct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)])
[_ eof])] [_ eof])]
[(record 'and (list named-pats)) [(Definition-and p0 p1 pN)
`(match input `(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)] ,(construct name #f ty)]
[_ eof])] [_ eof])]
[pattern [(Definition-Pattern pattern)
`(match input `(match input
[,(pattern->match-pattern pattern 'dest) [,(pattern->match-pattern pattern 'dest)
,(construct name #f ty)] ,(construct name #f ty)]
@ -43,40 +45,40 @@
[_ `(and ,dest-pat-stx ,pat)])) [_ `(and ,dest-pat-stx ,pat)]))
(define (pattern->match-pattern pattern dest-pat-stx) (define (pattern->match-pattern pattern dest-pat-stx)
(match pattern (match (unwrap pattern)
[(record 'named (list n p)) (pattern->match-pattern p (maybe-dest dest-pat-stx (escape n)))] [(NamedSimplePattern_ n p) (pattern->match-pattern p (maybe-dest dest-pat-stx (escape n)))]
['any dest-pat-stx] [(SimplePattern-any) dest-pat-stx]
[(record 'atom (list atom-kind)) [(SimplePattern-atom atom-kind)
(maybe-dest dest-pat-stx (maybe-dest dest-pat-stx
`(? ,(match atom-kind `(? ,(match atom-kind
['Boolean 'boolean?] [(AtomKind-Boolean) 'boolean?]
['Float 'float?] [(AtomKind-Float) 'float?]
['Double 'flonum?] [(AtomKind-Double) 'flonum?]
['SignedInteger 'integer?] [(AtomKind-SignedInteger) 'integer?]
['String 'string?] [(AtomKind-String) 'string?]
['ByteString 'bytes?] [(AtomKind-ByteString) 'bytes?]
['Symbol 'symbol?])))] [(AtomKind-Symbol) 'symbol?])))]
[(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")] [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
[(record 'lit (list v)) (maybe-dest dest-pat-stx (literal->pattern v))] [(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))]
[(record 'ref (list '() name)) [(SimplePattern-Ref (Ref '() name))
`(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))] `(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")] (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? `(parse-sequence list?
values values
,(pattern->match-pattern variable-pat 'item) ,(pattern->match-pattern variable-pat 'item)
item item
values values
,dest-pat-stx)] ,dest-pat-stx)]
[(record 'setof (list pat)) [(CompoundPattern-setof pat)
`(parse-sequence set? `(parse-sequence set?
set->list set->list
,(pattern->match-pattern pat 'item) ,(pattern->match-pattern pat 'item)
item item
list->set list->set
,dest-pat-stx)] ,dest-pat-stx)]
[(record 'dictof (list key-pat value-pat)) [(CompoundPattern-dictof key-pat value-pat)
`(parse-sequence dict? `(parse-sequence dict?
dict->list dict->list
(cons ,(pattern->match-pattern key-pat 'key) (cons ,(pattern->match-pattern key-pat 'key)
@ -84,17 +86,18 @@
(cons key value) (cons key value)
make-immutable-hash make-immutable-hash
,dest-pat-stx)] ,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 '_) (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_)
,(pattern->match-pattern fields-pat '_)))] ,(pattern->match-pattern fields-pat '_)))]
[(record 'tuple (list named-pats)) [(CompoundPattern-tuple named-pats)
(maybe-dest dest-pat-stx (maybe-dest dest-pat-stx
`(list ,@(map (lambda (p) (pattern->match-pattern p '_)) named-pats)))] `(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 (maybe-dest dest-pat-stx
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats) `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
(list ,(pattern->match-pattern vpat (escape vname)) ...)))] (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 (maybe-dest dest-pat-stx
`(hash-table ,@(for/list [(key (in-list keys)) `(hash-table ,@(for/list [(key (in-list keys))
(pat (in-list pats))] (pat (in-list pats))]

82
implementations/racket/preserves/preserves-schema/type.rkt
View File

@ -9,6 +9,7 @@
(struct-out ty-dictionary) (struct-out ty-dictionary)
definition-ty definition-ty
unwrap
add-name-if-absent add-name-if-absent
escape) escape)
@ -16,6 +17,8 @@
(require racket/match) (require racket/match)
(require (only-in racket/syntax format-symbol)) (require (only-in racket/syntax format-symbol))
(require "gen-schema.rkt")
(struct ty-union (variants) #:transparent) (struct ty-union (variants) #:transparent)
(struct ty-unit () #:transparent) (struct ty-unit () #:transparent)
(struct ty-value () #:transparent) (struct ty-value () #:transparent)
@ -26,57 +29,84 @@
(define (definition-ty d) (define (definition-ty d)
(match d (match d
[(record 'or (list named-alts)) [(Definition-or p0 p1 pN)
(ty-union (map (match-lambda (ty-union (map (match-lambda
[(list variant-label-str pattern) [(NamedAlternative variant-label-str pattern)
(list (string->symbol variant-label-str) (pattern-ty pattern))]) (list (string->symbol variant-label-str) (pattern-ty pattern))])
named-alts))] (list* p0 p1 pN)))]
[(record 'and (list named-pats)) (product-ty named-pats)] [(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
[pattern (pattern-ty pattern)])) [(Definition-Pattern pattern) (pattern-ty pattern)]))
(define (product-ty named-pats) (define (product-ty named-pats)
(match (gather-fields* named-pats '()) (match (gather-fields* named-pats '())
['() (ty-unit)] ['() (ty-unit)]
[fields (ty-record fields)])) [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) (define (gather-fields* named-pats acc)
(foldr gather-fields acc named-pats)) (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) (define (gather-fields named-pat acc)
(match named-pat (match (unwrap named-pat)
[(record 'named (list n p)) [(NamedSimplePattern_ n p)
(match (pattern-ty p) (match (pattern-ty p)
[(ty-unit) acc] [(ty-unit) acc]
[ty (cons (list n ty) 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))] (gather-fields label-named-pat (gather-fields fields-named-pat acc))]
[(record 'tuple (list named-pats)) (gather-fields* named-pats acc)] [(CompoundPattern-tuple named-pats) (gather-fields* named-pats acc)]
[(record 'tuple* (list fixed-named-pats variable-named-pat)) [(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))] (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)] (gather-fields* (map add-name-if-absent keys pats) acc)]
[_ acc])) [(? SimplePattern?) acc]
[(? CompoundPattern?) acc]))
(define (pattern-ty p) (define (pattern-ty p)
(match p (match (unwrap p)
['any (ty-value)] [(SimplePattern-any) (ty-value)]
[(record 'atom (list _atom-kind)) (ty-value)] [(SimplePattern-atom _atomKind) (ty-value)]
[(record 'embedded '()) (ty-value)] [(SimplePattern-embedded) (ty-value)]
[(record 'lit (list _value)) (ty-unit)] [(SimplePattern-lit _value) (ty-unit)]
[(record 'ref (list _module-path _name)) (ty-value)] [(SimplePattern-Ref _r) (ty-value)]
[(record 'tuple* (list '() (and variable-pat (not (record 'named _))))) [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
(ty-array (pattern-ty variable-pat))] (ty-array (pattern-ty variable-pat))]
[(record 'setof (list pat)) (ty-set (pattern-ty pat))] [(CompoundPattern-setof pat) (ty-set (pattern-ty pat))]
[(record 'dictof (list key-pat value-pat)) [(CompoundPattern-dictof key-pat value-pat)
(ty-dictionary (pattern-ty key-pat) (pattern-ty 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) (define (add-name-if-absent k p)
(match p (match p
[(record 'named _) p] [(NamedSimplePattern-named _) p]
[_ (match (namelike k) [(NamedSimplePattern-anonymous _)
[#f p] (match (namelike k)
[s (record 'named (list s p))])])) [#f p]
[s (NamedSimplePattern-named (NamedSimplePattern_ s p))])]))
(define (namelike v) (define (namelike v)
(match v (match v

44
implementations/racket/preserves/preserves-schema/unparser.rkt
View File

@ -8,6 +8,7 @@
(require (only-in racket/list append-map)) (require (only-in racket/list append-map))
(require "type.rkt") (require "type.rkt")
(require "gen-schema.rkt")
(define (simple-pattern? p) (define (simple-pattern? p)
(match p (match p
@ -22,14 +23,14 @@
(define ty (definition-ty def)) (define ty (definition-ty def))
`(define (,(format-symbol "~a->preserves" name) input) `(define (,(format-symbol "~a->preserves" name) input)
,(match def ,(match def
[(record 'or (list named-alts)) [(Definition-or p0 p1 pN)
`(match input `(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))))] (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) `[,(deconstruct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)
,(pattern->unparser pattern 'src)]))] ,(pattern->unparser pattern 'src)]))]
[(record 'and (list named-pats)) [(Definition-and p0 p1 pN)
`(match input `(match input
[,(deconstruct name #f ty) [,(deconstruct name #f ty)
(merge-preserves (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge"))) (merge-preserves (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge")))
@ -38,8 +39,8 @@
(if (simple-pattern? named-pat) (if (simple-pattern? named-pat)
'() '()
(list (pattern->unparser named-pat 'src)))) (list (pattern->unparser named-pat 'src))))
named-pats))])] (list* p0 p1 pN)))])]
[pattern [(Definition-Pattern pattern)
`(match input `(match input
[,(deconstruct name #f ty) [,(deconstruct name #f ty)
,(pattern->unparser pattern 'src)])]))) ,(pattern->unparser pattern 'src)])])))
@ -51,31 +52,32 @@
[_ (if wrap? `(,name src) 'src)])) [_ (if wrap? `(,name src) 'src)]))
(define (pattern->unparser pattern src-stx) (define (pattern->unparser pattern src-stx)
(match pattern (match (unwrap pattern)
[(record 'named (list n p)) (pattern->unparser p (escape n))] [(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
['any src-stx] [(SimplePattern-any) src-stx]
[(record 'atom (list _atom-kind)) src-stx] [(SimplePattern-atom _) src-stx]
[(record 'embedded '()) (error 'pattern-parser "Embedded not yet implemented")] [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
[(record 'lit (list v)) `',v] [(SimplePattern-lit v) `',v]
[(record 'ref (list '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)] [(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
[(record 'ref (list module-path name)) [(SimplePattern-Ref (Ref module-path name))
(error 'pattern-parser "Ref with non-empty module path not yet implemented")] (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))] `(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))] `(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))] `(for/hash [((key value) (in-dict ,src-stx))]
(values ,(pattern->unparser key-pat 'key) (values ,(pattern->unparser key-pat 'key)
,(pattern->unparser value-pat 'value)))] ,(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 ,(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)))] `(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)) `(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)))] (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) `(hash ,@(append-map (lambda (key pat)
(list `',key (pattern->unparser (add-name-if-absent key pat) src-stx))) (list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))
keys pats))])) keys pats))]))