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

Initial work on preserves-schema for Racket

This commit is contained in:
Tony Garnock-Jones 2021-05-21 21:44:05 +02:00
parent 1654ad4c80
commit 49cba14b4f
5 changed files with 366 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
implementations/racket/preserves/preserves-schema/main.rkt Normal file
View File

@ -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))))))

108
implementations/racket/preserves/preserves-schema/parser.rkt Normal file
View File

@ -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)))

18
implementations/racket/preserves/preserves-schema/support.rkt Normal file
View File

@ -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))]))

90
implementations/racket/preserves/preserves-schema/type.rkt Normal file
View File

@ -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))

81
implementations/racket/preserves/preserves-schema/unparser.rkt Normal file
View File

@ -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))]))