Initial work on preserves-schema for Racket
This commit is contained in:
parent
1654ad4c80
commit
49cba14b4f
|
@ -0,0 +1,69 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide schema->module-stx)
|
||||||
|
|
||||||
|
(require preserves)
|
||||||
|
(require racket/match)
|
||||||
|
(require (only-in racket/string string-join))
|
||||||
|
(require (only-in racket/format ~a))
|
||||||
|
|
||||||
|
(require "type.rkt")
|
||||||
|
(require "parser.rkt")
|
||||||
|
(require "unparser.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)))]
|
||||||
|
(match (definition-ty def)
|
||||||
|
[(ty-union variants)
|
||||||
|
(for/fold [(acc acc)]
|
||||||
|
[(variant (in-list variants))]
|
||||||
|
(match-define (list variant-name variant-ty) variant)
|
||||||
|
(match variant-ty
|
||||||
|
[(ty-record fields)
|
||||||
|
(cons (struct-stx (list name variant-name) (map car fields)) acc)]
|
||||||
|
[(ty-unit)
|
||||||
|
(cons (struct-stx (list name variant-name) '()) acc)]
|
||||||
|
[_
|
||||||
|
(cons (struct-stx (list name variant-name) '(value)) acc)]))]
|
||||||
|
[(ty-record fields)
|
||||||
|
(cons (struct-stx (list name) (map car fields)) acc)]
|
||||||
|
[_
|
||||||
|
acc]))))
|
||||||
|
|
||||||
|
(define (parser-defs schema)
|
||||||
|
(for/list [((name def) (in-hash (schema-definition-table schema)))]
|
||||||
|
(definition-parser name def)))
|
||||||
|
|
||||||
|
(define (unparser-defs schema)
|
||||||
|
(for/list [((name def) (in-hash (schema-definition-table schema)))]
|
||||||
|
(definition-unparser name def)))
|
||||||
|
|
||||||
|
(define (schema->module-stx name schema)
|
||||||
|
`(module ,name racket/base
|
||||||
|
(provide (all-defined-out))
|
||||||
|
(require preserves)
|
||||||
|
(require preserves-schema/support)
|
||||||
|
(require racket/match)
|
||||||
|
(require racket/set)
|
||||||
|
(require racket/dict)
|
||||||
|
,@(struct-defs schema)
|
||||||
|
,@(parser-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))))))
|
|
@ -0,0 +1,108 @@
|
||||||
|
#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)))
|
|
@ -0,0 +1,18 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide parse-sequence)
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
|
||||||
|
(define-match-expander parse-sequence
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ predicate? to-list item-pat item-expr from-list target-pat)
|
||||||
|
(? predicate? (app (lambda (v)
|
||||||
|
(let loop ((inputs (to-list v)) (acc-rev '()))
|
||||||
|
(match inputs
|
||||||
|
['() (values #t (from-list (reverse acc-rev)))]
|
||||||
|
[(cons untransformed remainder)
|
||||||
|
(match untransformed
|
||||||
|
[item-pat (loop remainder (cons item-expr acc-rev))]
|
||||||
|
[_ (values #f #f)])])))
|
||||||
|
#t target-pat))]))
|
|
@ -0,0 +1,90 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide (struct-out ty-union)
|
||||||
|
(struct-out ty-unit)
|
||||||
|
(struct-out ty-value)
|
||||||
|
(struct-out ty-record)
|
||||||
|
(struct-out ty-array)
|
||||||
|
(struct-out ty-set)
|
||||||
|
(struct-out ty-dictionary)
|
||||||
|
|
||||||
|
definition-ty
|
||||||
|
add-name-if-absent
|
||||||
|
escape)
|
||||||
|
|
||||||
|
(require preserves/record)
|
||||||
|
(require racket/match)
|
||||||
|
(require (only-in racket/syntax format-symbol))
|
||||||
|
|
||||||
|
(struct ty-union (variants) #:transparent)
|
||||||
|
(struct ty-unit () #:transparent)
|
||||||
|
(struct ty-value () #:transparent)
|
||||||
|
(struct ty-record (fields) #:transparent)
|
||||||
|
(struct ty-array (type) #:transparent)
|
||||||
|
(struct ty-set (type) #:transparent)
|
||||||
|
(struct ty-dictionary (key-type value-type) #:transparent)
|
||||||
|
|
||||||
|
(define (definition-ty d)
|
||||||
|
(match d
|
||||||
|
[(record 'or (list named-alts))
|
||||||
|
(ty-union (map (match-lambda
|
||||||
|
[(list 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)]))
|
||||||
|
|
||||||
|
(define (product-ty named-pats)
|
||||||
|
(match (gather-fields* named-pats '())
|
||||||
|
['() (ty-unit)]
|
||||||
|
[fields (ty-record fields)]))
|
||||||
|
|
||||||
|
(define (gather-fields* named-pats acc)
|
||||||
|
(foldr gather-fields acc named-pats))
|
||||||
|
|
||||||
|
(define (gather-fields named-pat acc)
|
||||||
|
(match named-pat
|
||||||
|
[(record 'named (list n p))
|
||||||
|
(match (pattern-ty p)
|
||||||
|
[(ty-unit) acc]
|
||||||
|
[ty (cons (list n ty) acc)])]
|
||||||
|
[(record 'rec (list 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))
|
||||||
|
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
|
||||||
|
[(record 'dict (list (hash-table (keys pats) ...)))
|
||||||
|
(gather-fields* (map add-name-if-absent keys pats) acc)]
|
||||||
|
[_ 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 _)))))
|
||||||
|
(ty-array (pattern-ty variable-pat))]
|
||||||
|
[(record 'setof (list pat)) (ty-set (pattern-ty pat))]
|
||||||
|
[(record 'dictof (list key-pat value-pat))
|
||||||
|
(ty-dictionary (pattern-ty key-pat) (pattern-ty value-pat))]
|
||||||
|
[_ (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))])]))
|
||||||
|
|
||||||
|
(define (namelike v)
|
||||||
|
(match v
|
||||||
|
[(? string? s) (string->symbol s)]
|
||||||
|
[(? symbol? s) s]
|
||||||
|
[(? number? n) (string->symbol (number->string n))]
|
||||||
|
[(? boolean? b) (if b 'true 'false)]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
|
(define (escape s)
|
||||||
|
(format-symbol "$~a" s))
|
|
@ -0,0 +1,81 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide definition-unparser)
|
||||||
|
|
||||||
|
(require preserves)
|
||||||
|
(require racket/match)
|
||||||
|
(require (only-in racket/syntax format-symbol))
|
||||||
|
(require (only-in racket/list append-map))
|
||||||
|
|
||||||
|
(require "type.rkt")
|
||||||
|
|
||||||
|
(define (simple-pattern? p)
|
||||||
|
(match p
|
||||||
|
['any #t]
|
||||||
|
[(record 'atom _) #t]
|
||||||
|
[(record 'embedded _) #t]
|
||||||
|
[(record 'lit _) #t]
|
||||||
|
[(record 'ref _) #t]
|
||||||
|
[_ #f]))
|
||||||
|
|
||||||
|
(define (definition-unparser name def)
|
||||||
|
(define ty (definition-ty def))
|
||||||
|
`(define (,(format-symbol "~a->preserves" 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)
|
||||||
|
`[,(deconstruct (format-symbol "~a-~a" name variant-label-str) #t alt-ty)
|
||||||
|
,(pattern->unparser pattern 'src)]))]
|
||||||
|
[(record 'and (list named-pats))
|
||||||
|
`(match input
|
||||||
|
[,(deconstruct name #f ty)
|
||||||
|
(merge-preserves (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge")))
|
||||||
|
,@(append-map
|
||||||
|
(lambda (named-pat)
|
||||||
|
(if (simple-pattern? named-pat)
|
||||||
|
'()
|
||||||
|
(list (pattern->unparser named-pat 'src))))
|
||||||
|
named-pats))])]
|
||||||
|
[pattern
|
||||||
|
`(match input
|
||||||
|
[,(deconstruct name #f ty)
|
||||||
|
,(pattern->unparser pattern 'src)])])))
|
||||||
|
|
||||||
|
(define (deconstruct name wrap? ty)
|
||||||
|
(match ty
|
||||||
|
[(ty-record fields) `(,name ,@(map escape (map car fields)))]
|
||||||
|
[(ty-unit) (if wrap? `(,name) '(? void?))]
|
||||||
|
[_ (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))
|
||||||
|
(error 'pattern-parser "Ref with non-empty module path not yet implemented")]
|
||||||
|
[(record 'tuple* (list '() (and variable-pat (not (record 'named _)))))
|
||||||
|
`(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
|
||||||
|
[(record 'setof (list pat))
|
||||||
|
`(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
|
||||||
|
[(record 'dictof (list 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))
|
||||||
|
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
|
||||||
|
[(record 'tuple (list 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))))
|
||||||
|
`(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) ...)))
|
||||||
|
`(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