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

Generic-method based unparsing; prelude to generic pattern-formation

This commit is contained in:
Tony Garnock-Jones 2021-06-08 15:26:32 +02:00
parent 0bcb4e64ec
commit 7acf7c5b40
7 changed files with 894 additions and 599 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

159
implementations/racket/preserves/preserves-schema/compiler.rkt
View File

@ -8,6 +8,7 @@
(require preserves)
(require racket/match)
(require (only-in racket/list append-map))
(require (only-in racket/string string-join))
(require (only-in racket/format ~a))
(require (only-in racket/syntax format-symbol))
@ -29,8 +30,15 @@
relative-output-path)
#:transparent)
(define (struct-stx name-pieces field-names)
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
(define (struct-stx name field-names more)
`(struct ,name ,field-names #:transparent
,@more))
(define (ty->struct-field-names ty)
(match ty
[(ty-record fields) (map ty-field-name fields)] ;; not escaped here
[(ty-unit) '()]
[_ '(value)]))
(define (fold-Schema-definitions kc kn schema)
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
@ -91,40 +99,112 @@
[(EmbeddedTypeName-false) `((define :decode-embedded values)
(define :encode-embedded values))]
[(EmbeddedTypeName-Ref r) `((define :decode-embedded ,(Ref-parser!-name r))
(define :encode-embedded ,(Ref-unparser-name r)))]))
(define :encode-embedded ->preserve))]))
(define (struct-defs schema)
(fold-Schema-definitions
(lambda (name def acc)
(match (definition-ty def)
[(ty-union variants)
(for/fold [(acc (cons `(define (,(format-symbol "~a?" name) p)
(or ,@(for/list [(variant (in-list variants))]
`(,(format-symbol "~a-~a?" name (car variant)) p))))
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 ty-field-name fields)) acc)]
[(ty-unit)
(cons (struct-stx (list name variant-name) '()) acc)]
[_
(cons (struct-stx (list name variant-name) '(value)) acc)]))]
[(ty-unit)
(cons (struct-stx (list name) '()) acc)]
[(ty-record fields)
(cons (struct-stx (list name) (map ty-field-name fields)) acc)]
[_
acc]))
'()
schema))
(define (parser-defs schema)
(map-Schema-definitions definition-parsers schema))
(define (parse!-definition name)
`(define ,(format-symbol "parse-~a!" name)
(parse-success-or-error ',(format-symbol "parse-~a" name)
,(format-symbol "parse-~a" name))))
(define (unparser-defs schema)
(map-Schema-definitions definition-unparser schema))
(define ((compile-definition plugins) name def acc)
(define ty (definition-ty def))
(match def
[(? Definition-or?)
(define variants (ty-union-variants ty))
`[ (define (,(format-symbol "~a?" name) p)
(or ,@(for/list [(variant (in-list variants))]
`(,(format-symbol "~a-~a?" name (ty-variant-name variant)) p))))
,@(for/list [(variant (in-list variants))]
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
(define full-name (format-symbol "~a-~a" name variant-name))
(struct-stx full-name
(ty->struct-field-names variant-ty)
`[ #:methods gen:preservable
[(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(match preservable
[,(deconstruct full-name #t variant-ty)
,(pattern->unparser variant-pat 'src)]))]
]))
(define (,(format-symbol "parse-~a" name) input)
(match input
,@(for/list [(variant (in-list variants))]
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
`[,(pattern->match-pattern variant-pat 'dest)
,(construct (format-symbol "~a-~a" name variant-name) #t variant-ty)])
[_ eof]))
,(parse!-definition name)
,@acc ]]
[(Definition-and p0 p1 pN)
(define facets (list* p0 p1 pN))
`[ ,(struct-stx name
(ty->struct-field-names ty)
`[ #:methods gen:preservable
[(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(match preservable
[,(deconstruct name #f ty)
(merge-preserves
(lambda (a b) (if (equal? a b)
a
(error 'merge-preserves "Cannot merge")))
,@(append-map
(lambda (named-pat)
(match named-pat
[(NamedPattern-anonymous (Pattern-SimplePattern _)) '()]
[_ (list (pattern->unparser named-pat 'src))]))
facets))]))]
])
(define (,(format-symbol "parse-~a" name) input)
(match input
[(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_)))
,(construct name #f ty)]
[_ eof]))
,(parse!-definition name)
,@acc ]]
[(Definition-Pattern pattern)
`[ ,(struct-stx name
(ty->struct-field-names ty)
`[ #:methods gen:preservable
[(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(match preservable
[,(deconstruct name #f ty)
,(pattern->unparser pattern 'src)]))]
])
(define (,(format-symbol "parse-~a" name) input)
(match input
[,(pattern->match-pattern pattern 'dest)
,(construct name #f ty)]
[_ eof]))
,(parse!-definition name)
,@acc ]]))
(define (deconstruct name wrap? ty)
(match ty
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
[(ty-unit) `(,name)]
[_ (if wrap? `(,name src) 'src)]))
(define (construct name wrap? ty)
(match ty
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
[(ty-unit) `(,name)]
[_ (if wrap? `(,name dest) 'dest)]))
(define (schema->module-stx name lookup-module-path schema
#:translation-paths [translation-paths #f]
@ -136,17 +216,18 @@
(provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
(rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
[:encode-embedded ,(format-symbol "encode-embedded:~a" name)]))
,@(module-imports name schema lookup-module-path translation-paths)
,@(embedded-defs schema)
(require preserves)
(require preserves-schema/methods)
(require preserves-schema/support)
(require racket/match)
(require racket/set)
(require racket/dict)
,@(struct-defs schema)
,@(parser-defs schema)
,@(unparser-defs schema)
,@(for/list [(plugin (in-list plugins))] (plugin schema options))
(require (only-in racket/generic define/generic))
,@(module-imports name schema lookup-module-path translation-paths)
,@(embedded-defs schema)
,@(fold-Schema-definitions (compile-definition plugins) '() schema)
,@(for/list [(plugin (in-list plugins))] ((plugin 'schema) schema options))
))
(module+ main

1201
implementations/racket/preserves/preserves-schema/gen/schema.rkt
View File

File diff suppressed because it is too large Load Diff

44
implementations/racket/preserves/preserves-schema/methods.rkt Normal file
View File

@ -0,0 +1,44 @@
#lang racket/base
(provide gen:preservable
preservable?
->preserve
preservable/c)
(require preserves)
(require racket/generic)
(require racket/set)
(require racket/dict)
(define-generics preservable
(->preserve preservable)
#:fast-defaults ([boolean? (define (->preserve preservable) preservable)]
[number? (define (->preserve preservable) preservable)]
[string? (define (->preserve preservable) preservable)]
[bytes? (define (->preserve preservable) preservable)]
[symbol? (define (->preserve preservable) preservable)]
[null? (define (->preserve preservable) preservable)]
[pair?
(define/generic *->preserve ->preserve)
(define (->preserve preservable) (map *->preserve preservable))]
[hash?
(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(for/hash [((k v) (in-hash preservable))]
(values (*->preserve k) (*->preserve v))))])
#:defaults ([float? (define (->preserve preservable) preservable)]
[record?
(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(record (*->preserve (record-label preservable))
(map *->preserve (record-fields preservable))))]
[set?
(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(for/set [(v (in-set preservable))]
(*->preserve v)))]
[dict?
(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(for/hash [((k v) (in-dict preservable))]
(values (*->preserve k) (*->preserve v))))]))

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

@ -1,6 +1,6 @@
#lang racket/base
(provide definition-parsers
(provide pattern->match-pattern
Ref-parser-name
Ref-parser!-name)
@ -11,40 +11,6 @@
(require "type.rkt")
(require "gen/schema.rkt")
(define (definition-parsers name def)
(define ty (definition-ty def))
`(begin
(define (,(format-symbol "parse-~a" name) input)
,(match def
[(Definition-or p0 p1 pN)
`(match input
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
(alt-ty (in-list (map cadr (ty-union-variants ty))))]
(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])]
[(Definition-and p0 p1 pN)
`(match input
[(and ,@(for/list [(named-pat (list* p0 p1 pN))]
(pattern->match-pattern named-pat '_)))
,(construct name #f ty)]
[_ eof])]
[(Definition-Pattern pattern)
`(match input
[,(pattern->match-pattern pattern 'dest)
,(construct name #f ty)]
[_ eof])]))
(define ,(format-symbol "parse-~a!" name)
(parse-success-or-error ',(format-symbol "parse-~a" name)
,(format-symbol "parse-~a" name)))))
(define (construct name wrap? ty)
(match ty
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
[(ty-unit) `(,name)]
[_ (if wrap? `(,name dest) 'dest)]))
(define (maybe-dest dest-pat-stx pat)
(match dest-pat-stx
['_ pat]

3
implementations/racket/preserves/preserves-schema/reader.rkt
View File

@ -212,5 +212,6 @@
(module+ main
(require preserves)
(require "methods.rkt")
(define expected (car (file->preserves "../../../../schema/schema.bin")))
(equal? expected (Schema->preserves (file->schema "../../../../schema/schema.prs"))))
(equal? expected (->preserve (file->schema "../../../../schema/schema.prs"))))

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

@ -8,6 +8,7 @@
(struct-out ty-set)
(struct-out ty-dictionary)
(struct-out ty-variant)
(struct-out ty-field)
definition-ty
@ -32,14 +33,16 @@
(struct ty-set (type) #:transparent)
(struct ty-dictionary (key-type value-type) #:transparent)
(struct ty-variant (name type pattern) #:transparent)
(struct ty-field (name type pattern) #:transparent)
(define (definition-ty d)
(match d
[(Definition-or p0 p1 pN)
(ty-union (map (match-lambda
[(NamedAlternative variant-label-str pattern)
(list (string->symbol variant-label-str) (pattern-ty pattern))])
(ty-union (map (match-lambda [(NamedAlternative variant-label-str pattern)
(ty-variant (string->symbol variant-label-str)
(pattern-ty pattern)
pattern)])
(list* p0 p1 pN)))]
[(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
[(Definition-Pattern pattern) (pattern-ty pattern)]))

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

@ -1,7 +1,6 @@
#lang racket/base
(provide definition-unparser
Ref-unparser-name)
(provide pattern->unparser)
(require preserves)
(require racket/match)
@ -11,38 +10,6 @@
(require "type.rkt")
(require "gen/schema.rkt")
(define (definition-unparser name def)
(define ty (definition-ty def))
`(define (,(format-symbol "~a->preserves" name) input)
,(match def
[(Definition-or p0 p1 pN)
`(match input
,@(for/list [(named-alt (in-list (list* p0 p1 pN)))
(alt-ty (in-list (map cadr (ty-union-variants ty))))]
(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)]))]
[(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")))
,@(append-map (lambda (named-pat)
(match named-pat
[(NamedPattern-anonymous (Pattern-SimplePattern _)) '()]
[_ (list (pattern->unparser named-pat 'src))]))
(list* p0 p1 pN)))])]
[(Definition-Pattern 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 ty-field-name fields)))]
[(ty-unit) `(,name)]
[_ (if wrap? `(,name src) 'src)]))
(define (pattern->unparser pattern src-stx)
(match (unwrap pattern)
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
@ -59,7 +26,7 @@
(values ,(pattern->unparser key-pat 'key)
,(pattern->unparser value-pat 'value)))]
[(SimplePattern-Ref r)
`(,(Ref-unparser-name r) ,src-stx)]
`(*->preserve ,src-stx)]
[(CompoundPattern-rec label-pat fields-pat)
`(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
[(CompoundPattern-tuple named-pats)
@ -72,7 +39,3 @@
(list `',(car entry)
(pattern->unparser (cdr entry) src-stx)))
(sorted-dict-entries entries)))]))
(define (Ref-unparser-name r)
(match-define (Ref module-path name) r)
(format-symbol "~a~a->preserves" (module-path-prefix module-path) name))