Generic-method based unparsing; prelude to generic pattern-formation
This commit is contained in:
parent
0bcb4e64ec
commit
7acf7c5b40
|
@ -8,6 +8,7 @@
|
||||||
|
|
||||||
(require preserves)
|
(require preserves)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require (only-in racket/list append-map))
|
||||||
(require (only-in racket/string string-join))
|
(require (only-in racket/string string-join))
|
||||||
(require (only-in racket/format ~a))
|
(require (only-in racket/format ~a))
|
||||||
(require (only-in racket/syntax format-symbol))
|
(require (only-in racket/syntax format-symbol))
|
||||||
|
@ -29,8 +30,15 @@
|
||||||
relative-output-path)
|
relative-output-path)
|
||||||
#:transparent)
|
#:transparent)
|
||||||
|
|
||||||
(define (struct-stx name-pieces field-names)
|
(define (struct-stx name field-names more)
|
||||||
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
|
`(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)
|
(define (fold-Schema-definitions kc kn schema)
|
||||||
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
|
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
|
||||||
|
@ -91,40 +99,112 @@
|
||||||
[(EmbeddedTypeName-false) `((define :decode-embedded values)
|
[(EmbeddedTypeName-false) `((define :decode-embedded values)
|
||||||
(define :encode-embedded values))]
|
(define :encode-embedded values))]
|
||||||
[(EmbeddedTypeName-Ref r) `((define :decode-embedded ,(Ref-parser!-name r))
|
[(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)
|
(define (parse!-definition name)
|
||||||
(map-Schema-definitions definition-parsers schema))
|
`(define ,(format-symbol "parse-~a!" name)
|
||||||
|
(parse-success-or-error ',(format-symbol "parse-~a" name)
|
||||||
|
,(format-symbol "parse-~a" name))))
|
||||||
|
|
||||||
(define (unparser-defs schema)
|
(define ((compile-definition plugins) name def acc)
|
||||||
(map-Schema-definitions definition-unparser schema))
|
(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
|
(define (schema->module-stx name lookup-module-path schema
|
||||||
#:translation-paths [translation-paths #f]
|
#:translation-paths [translation-paths #f]
|
||||||
|
@ -136,17 +216,18 @@
|
||||||
(provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
|
(provide (except-out (all-defined-out) :decode-embedded :encode-embedded)
|
||||||
(rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
|
(rename-out [:decode-embedded ,(format-symbol "decode-embedded:~a" name)]
|
||||||
[:encode-embedded ,(format-symbol "encode-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)
|
||||||
|
(require preserves-schema/methods)
|
||||||
(require preserves-schema/support)
|
(require preserves-schema/support)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/dict)
|
(require racket/dict)
|
||||||
,@(struct-defs schema)
|
(require (only-in racket/generic define/generic))
|
||||||
,@(parser-defs schema)
|
,@(module-imports name schema lookup-module-path translation-paths)
|
||||||
,@(unparser-defs schema)
|
,@(embedded-defs schema)
|
||||||
,@(for/list [(plugin (in-list plugins))] (plugin schema options))
|
,@(fold-Schema-definitions (compile-definition plugins) '() schema)
|
||||||
|
,@(for/list [(plugin (in-list plugins))] ((plugin 'schema) schema options))
|
||||||
))
|
))
|
||||||
|
|
||||||
(module+ main
|
(module+ main
|
||||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -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))))]))
|
|
@ -1,6 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide definition-parsers
|
(provide pattern->match-pattern
|
||||||
Ref-parser-name
|
Ref-parser-name
|
||||||
Ref-parser!-name)
|
Ref-parser!-name)
|
||||||
|
|
||||||
|
@ -11,40 +11,6 @@
|
||||||
(require "type.rkt")
|
(require "type.rkt")
|
||||||
(require "gen/schema.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)
|
(define (maybe-dest dest-pat-stx pat)
|
||||||
(match dest-pat-stx
|
(match dest-pat-stx
|
||||||
['_ pat]
|
['_ pat]
|
||||||
|
|
|
@ -212,5 +212,6 @@
|
||||||
|
|
||||||
(module+ main
|
(module+ main
|
||||||
(require preserves)
|
(require preserves)
|
||||||
|
(require "methods.rkt")
|
||||||
(define expected (car (file->preserves "../../../../schema/schema.bin")))
|
(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"))))
|
||||||
|
|
|
@ -8,6 +8,7 @@
|
||||||
(struct-out ty-set)
|
(struct-out ty-set)
|
||||||
(struct-out ty-dictionary)
|
(struct-out ty-dictionary)
|
||||||
|
|
||||||
|
(struct-out ty-variant)
|
||||||
(struct-out ty-field)
|
(struct-out ty-field)
|
||||||
|
|
||||||
definition-ty
|
definition-ty
|
||||||
|
@ -32,14 +33,16 @@
|
||||||
(struct ty-set (type) #:transparent)
|
(struct ty-set (type) #:transparent)
|
||||||
(struct ty-dictionary (key-type value-type) #:transparent)
|
(struct ty-dictionary (key-type value-type) #:transparent)
|
||||||
|
|
||||||
|
(struct ty-variant (name type pattern) #:transparent)
|
||||||
(struct ty-field (name type pattern) #:transparent)
|
(struct ty-field (name type pattern) #:transparent)
|
||||||
|
|
||||||
(define (definition-ty d)
|
(define (definition-ty d)
|
||||||
(match d
|
(match d
|
||||||
[(Definition-or p0 p1 pN)
|
[(Definition-or p0 p1 pN)
|
||||||
(ty-union (map (match-lambda
|
(ty-union (map (match-lambda [(NamedAlternative variant-label-str pattern)
|
||||||
[(NamedAlternative variant-label-str pattern)
|
(ty-variant (string->symbol variant-label-str)
|
||||||
(list (string->symbol variant-label-str) (pattern-ty pattern))])
|
(pattern-ty pattern)
|
||||||
|
pattern)])
|
||||||
(list* p0 p1 pN)))]
|
(list* p0 p1 pN)))]
|
||||||
[(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
|
[(Definition-and p0 p1 pN) (product-ty (list* p0 p1 pN))]
|
||||||
[(Definition-Pattern pattern) (pattern-ty pattern)]))
|
[(Definition-Pattern pattern) (pattern-ty pattern)]))
|
||||||
|
|
|
@ -1,7 +1,6 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(provide definition-unparser
|
(provide pattern->unparser)
|
||||||
Ref-unparser-name)
|
|
||||||
|
|
||||||
(require preserves)
|
(require preserves)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
@ -11,38 +10,6 @@
|
||||||
(require "type.rkt")
|
(require "type.rkt")
|
||||||
(require "gen/schema.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)
|
(define (pattern->unparser pattern src-stx)
|
||||||
(match (unwrap pattern)
|
(match (unwrap pattern)
|
||||||
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
|
[(NamedSimplePattern_ n p) (pattern->unparser p (escape n))]
|
||||||
|
@ -59,7 +26,7 @@
|
||||||
(values ,(pattern->unparser key-pat 'key)
|
(values ,(pattern->unparser key-pat 'key)
|
||||||
,(pattern->unparser value-pat 'value)))]
|
,(pattern->unparser value-pat 'value)))]
|
||||||
[(SimplePattern-Ref r)
|
[(SimplePattern-Ref r)
|
||||||
`(,(Ref-unparser-name r) ,src-stx)]
|
`(*->preserve ,src-stx)]
|
||||||
[(CompoundPattern-rec 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))]
|
||||||
[(CompoundPattern-tuple named-pats)
|
[(CompoundPattern-tuple named-pats)
|
||||||
|
@ -72,7 +39,3 @@
|
||||||
(list `',(car entry)
|
(list `',(car entry)
|
||||||
(pattern->unparser (cdr entry) src-stx)))
|
(pattern->unparser (cdr entry) src-stx)))
|
||||||
(sorted-dict-entries entries)))]))
|
(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))
|
|
||||||
|
|
Loading…
Reference in New Issue