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

Always use wrapper struct

This commit is contained in:
Tony Garnock-Jones 2021-06-08 15:49:27 +02:00
parent e5b6c46169
commit 27002dfe7f
7 changed files with 42 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
implementations/racket/preserves/preserves-schema/checker.rkt
View File

@ -36,7 +36,7 @@
[(CompoundPattern-tuple* ps v)
(for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))
(check-named-pattern (cons "tail" context) scope v)]
[(CompoundPattern-dict entries)
[(CompoundPattern-dict (DictionaryEntries entries))
(for [(entry (in-list (sorted-dict-entries entries)))]
(check-named-pattern (cons (car entry) context) scope (cdr entry)))]))
@ -47,7 +47,7 @@
(check-pattern (cons n context) scope p #t)]
[p (check-pattern context scope p #f)]))
(for [((name def) (in-hash (Schema-definitions schema)))]
(for [((name def) (in-hash (Definitions-value (Schema-definitions schema))))]
(define context (list name))
(match def
[(Definition-or p0 p1 pN)

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

@ -43,7 +43,7 @@
(define (fold-Schema-definitions kc kn schema)
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
kn
(sorted-dict-entries (Schema-definitions schema))))
(sorted-dict-entries (Definitions-value (Schema-definitions schema)))))
(define (map-Schema-definitions proc schema)
(fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema))
@ -51,7 +51,7 @@
(define (module-imports name schema lookup-module-path translation-paths)
(define imports (make-hash))
(define (import-ref! r)
(match-define (Ref module-path _name) r)
(match-define (Ref (ModulePath module-path) _name) r)
(when (not (null? module-path))
(hash-set! imports module-path #t)))
(define (walk x)
@ -76,7 +76,7 @@
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
(for-each walk fixed-named-pats)
(walk variable-named-pat)]
[(CompoundPattern-dict entries)
[(CompoundPattern-dict (DictionaryEntries entries))
(for-each walk (map cdr (sorted-dict-entries entries)))]
[x (error 'module-imports "Unimplemented: ~v" x)]))
(match (Schema-embeddedType schema)
@ -127,7 +127,7 @@
[(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(match preservable
[,(deconstruct full-name #t variant-ty)
[,(deconstruct full-name variant-ty)
,(pattern->unparser variant-pat 'src)]))]
]))
@ -137,7 +137,7 @@
,@(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)])
,(construct (format-symbol "~a-~a" name variant-name) variant-ty)])
[_ eof]))
,(parse!-definition name)
@ -152,7 +152,7 @@
[(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(match preservable
[,(deconstruct name #f ty)
[,(deconstruct name ty)
(merge-preserves
(lambda (a b) (if (equal? a b)
a
@ -168,7 +168,7 @@
(define (,(format-symbol "parse-~a" name) input)
(match input
[(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_)))
,(construct name #f ty)]
,(construct name ty)]
[_ eof]))
,(parse!-definition name)
@ -181,30 +181,30 @@
[(define/generic *->preserve ->preserve)
(define (->preserve preservable)
(match preservable
[,(deconstruct name #f ty)
[,(deconstruct name ty)
,(pattern->unparser pattern 'src)]))]
])
(define (,(format-symbol "parse-~a" name) input)
(match input
[,(pattern->match-pattern pattern 'dest)
,(construct name #f ty)]
,(construct name ty)]
[_ eof]))
,(parse!-definition name)
,@acc ]]))
(define (deconstruct name wrap? ty)
(define (deconstruct name ty)
(match ty
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
[(ty-unit) `(,name)]
[_ (if wrap? `(,name src) 'src)]))
[_ `(,name src)]))
(define (construct name wrap? ty)
(define (construct name ty)
(match ty
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
[(ty-unit) `(,name)]
[_ (if wrap? `(,name dest) 'dest)]))
[_ `(,name dest)]))
(define (schema->module-stx name lookup-module-path schema
#:translation-paths [translation-paths #f]

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

@ -297,7 +297,7 @@
(define (->preserve preservable)
(match
preservable
(src
((Definitions src)
(for/hash
(((key value) (in-dict src)))
(values key (*->preserve value))))))))
@ -313,7 +313,7 @@
(cons key value)
make-immutable-hash
dest)
dest)
(Definitions dest))
(_ eof)))
(define parse-Definitions!
(parse-success-or-error 'parse-Definitions parse-Definitions))
@ -327,7 +327,7 @@
(define (->preserve preservable)
(match
preservable
(src
((DictionaryEntries src)
(for/hash
(((key value) (in-dict src)))
(values key (*->preserve value))))))))
@ -341,7 +341,7 @@
(cons key value)
make-immutable-hash
dest)
dest)
(DictionaryEntries dest))
(_ eof)))
(define parse-DictionaryEntries!
(parse-success-or-error 'parse-DictionaryEntries parse-DictionaryEntries))
@ -381,9 +381,14 @@
gen:preservable
((define/generic *->preserve ->preserve)
(define (->preserve preservable)
(match preservable (src (for/list ((item (in-list src))) item))))))
(match
preservable
((ModulePath src) (for/list ((item (in-list src))) item))))))
(define (parse-ModulePath input)
(match input ((list (and dest (? symbol?)) ...) dest) (_ eof)))
(match
input
((list (and dest (? symbol?)) ...) (ModulePath dest))
(_ eof)))
(define parse-ModulePath!
(parse-success-or-error 'parse-ModulePath parse-ModulePath))
(struct
@ -396,7 +401,7 @@
(define (->preserve preservable)
(match
preservable
(src
((Modules src)
(for/hash
(((key value) (in-dict src)))
(values (*->preserve key) (*->preserve value))))))))
@ -412,7 +417,7 @@
(cons key value)
make-immutable-hash
dest)
dest)
(Modules dest))
(_ eof)))
(define parse-Modules! (parse-success-or-error 'parse-Modules parse-Modules))
(struct

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

@ -66,7 +66,7 @@
(pattern->match-pattern variable-named-pat '_)
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
,(pattern->match-pattern variable-named-pat '_))))]
[(CompoundPattern-dict entries)
[(CompoundPattern-dict (DictionaryEntries entries))
(maybe-dest dest-pat-stx
`(hash-table ,@(map (lambda (entry)
`(,(literal->pattern (car entry))
@ -75,11 +75,11 @@
(_ _) ...))]))
(define (Ref-parser-name r)
(match-define (Ref module-path name) r)
(match-define (Ref (ModulePath module-path) name) r)
(format-symbol "~aparse-~a" (module-path-prefix module-path) name))
(define (Ref-parser!-name r)
(match-define (Ref module-path name) r)
(match-define (Ref (ModulePath module-path) name) r)
(format-symbol "~aparse-~a!" (module-path-prefix module-path) name))
(define (literal->pattern v)

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

@ -62,12 +62,12 @@
(process toplevel-tokens source)
(when (not version) (error 'parse-schema "Missing version declaration"))
(Schema definitions embeddedType version))
(Schema (Definitions definitions) embeddedType version))
(define (parse-ref-dsl s)
(match-define (list module-path ... final-id)
(map string->symbol (string-split (symbol->string s) ".")))
(Ref module-path final-id))
(Ref (ModulePath module-path) final-id))
(define (parse-def-dsl name def-stx)
(define (and-branch input)
@ -158,12 +158,13 @@
[(list item ...)
(CompoundPattern-tuple (map maybe-named item))]
[(? dict? d) #:when (not (dict-has-key? (strip-annotations d) '...))
(CompoundPattern-dict (for/hash [((k0 vp) (in-dict d))]
(define k (strip-annotations k0))
(values k ((maybe-named* NamedSimplePattern-named
NamedSimplePattern-anonymous
walk-simple
k) vp))))]
(CompoundPattern-dict (DictionaryEntries
(for/hash [((k0 vp) (in-dict d))]
(define k (strip-annotations k0))
(values k ((maybe-named* NamedSimplePattern-named
NamedSimplePattern-anonymous
walk-simple
k) vp)))))]
[_ (error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))]))
(define (walk stx) (parse-pattern-dsl name (list stx)))

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

@ -78,7 +78,7 @@
(gather-fields* named-pats acc)]
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
[(CompoundPattern-dict entries)
[(CompoundPattern-dict (DictionaryEntries entries))
(gather-fields* (map cdr (sorted-dict-entries entries)) acc)]))
(define (pattern-ty p)

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

@ -34,7 +34,7 @@
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
`(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
,(pattern->unparser variable-named-pat src-stx))]
[(CompoundPattern-dict entries)
[(CompoundPattern-dict (DictionaryEntries entries))
`(hash ,@(append-map (lambda (entry)
(list `',(car entry)
(pattern->unparser (cdr entry) src-stx)))