Always use wrapper struct
This commit is contained in:
parent
e5b6c46169
commit
27002dfe7f
|
@ -36,7 +36,7 @@
|
||||||
[(CompoundPattern-tuple* ps v)
|
[(CompoundPattern-tuple* ps v)
|
||||||
(for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))
|
(for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))
|
||||||
(check-named-pattern (cons "tail" context) scope v)]
|
(check-named-pattern (cons "tail" context) scope v)]
|
||||||
[(CompoundPattern-dict entries)
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
||||||
(for [(entry (in-list (sorted-dict-entries entries)))]
|
(for [(entry (in-list (sorted-dict-entries entries)))]
|
||||||
(check-named-pattern (cons (car entry) context) scope (cdr entry)))]))
|
(check-named-pattern (cons (car entry) context) scope (cdr entry)))]))
|
||||||
|
|
||||||
|
@ -47,7 +47,7 @@
|
||||||
(check-pattern (cons n context) scope p #t)]
|
(check-pattern (cons n context) scope p #t)]
|
||||||
[p (check-pattern context scope p #f)]))
|
[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))
|
(define context (list name))
|
||||||
(match def
|
(match def
|
||||||
[(Definition-or p0 p1 pN)
|
[(Definition-or p0 p1 pN)
|
||||||
|
|
|
@ -43,7 +43,7 @@
|
||||||
(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))
|
||||||
kn
|
kn
|
||||||
(sorted-dict-entries (Schema-definitions schema))))
|
(sorted-dict-entries (Definitions-value (Schema-definitions schema)))))
|
||||||
|
|
||||||
(define (map-Schema-definitions proc schema)
|
(define (map-Schema-definitions proc schema)
|
||||||
(fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() 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 (module-imports name schema lookup-module-path translation-paths)
|
||||||
(define imports (make-hash))
|
(define imports (make-hash))
|
||||||
(define (import-ref! r)
|
(define (import-ref! r)
|
||||||
(match-define (Ref module-path _name) r)
|
(match-define (Ref (ModulePath module-path) _name) r)
|
||||||
(when (not (null? module-path))
|
(when (not (null? module-path))
|
||||||
(hash-set! imports module-path #t)))
|
(hash-set! imports module-path #t)))
|
||||||
(define (walk x)
|
(define (walk x)
|
||||||
|
@ -76,7 +76,7 @@
|
||||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||||
(for-each walk fixed-named-pats)
|
(for-each walk fixed-named-pats)
|
||||||
(walk variable-named-pat)]
|
(walk variable-named-pat)]
|
||||||
[(CompoundPattern-dict entries)
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
||||||
(for-each walk (map cdr (sorted-dict-entries entries)))]
|
(for-each walk (map cdr (sorted-dict-entries entries)))]
|
||||||
[x (error 'module-imports "Unimplemented: ~v" x)]))
|
[x (error 'module-imports "Unimplemented: ~v" x)]))
|
||||||
(match (Schema-embeddedType schema)
|
(match (Schema-embeddedType schema)
|
||||||
|
@ -127,7 +127,7 @@
|
||||||
[(define/generic *->preserve ->preserve)
|
[(define/generic *->preserve ->preserve)
|
||||||
(define (->preserve preservable)
|
(define (->preserve preservable)
|
||||||
(match preservable
|
(match preservable
|
||||||
[,(deconstruct full-name #t variant-ty)
|
[,(deconstruct full-name variant-ty)
|
||||||
,(pattern->unparser variant-pat 'src)]))]
|
,(pattern->unparser variant-pat 'src)]))]
|
||||||
|
|
||||||
]))
|
]))
|
||||||
|
@ -137,7 +137,7 @@
|
||||||
,@(for/list [(variant (in-list variants))]
|
,@(for/list [(variant (in-list variants))]
|
||||||
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
|
(match-define (ty-variant variant-name variant-ty variant-pat) variant)
|
||||||
`[,(pattern->match-pattern variant-pat 'dest)
|
`[,(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]))
|
[_ eof]))
|
||||||
,(parse!-definition name)
|
,(parse!-definition name)
|
||||||
|
|
||||||
|
@ -152,7 +152,7 @@
|
||||||
[(define/generic *->preserve ->preserve)
|
[(define/generic *->preserve ->preserve)
|
||||||
(define (->preserve preservable)
|
(define (->preserve preservable)
|
||||||
(match preservable
|
(match preservable
|
||||||
[,(deconstruct name #f ty)
|
[,(deconstruct name ty)
|
||||||
(merge-preserves
|
(merge-preserves
|
||||||
(lambda (a b) (if (equal? a b)
|
(lambda (a b) (if (equal? a b)
|
||||||
a
|
a
|
||||||
|
@ -168,7 +168,7 @@
|
||||||
(define (,(format-symbol "parse-~a" name) input)
|
(define (,(format-symbol "parse-~a" name) input)
|
||||||
(match input
|
(match input
|
||||||
[(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_)))
|
[(and ,@(for/list [(named-pat facets)] (pattern->match-pattern named-pat '_)))
|
||||||
,(construct name #f ty)]
|
,(construct name ty)]
|
||||||
[_ eof]))
|
[_ eof]))
|
||||||
,(parse!-definition name)
|
,(parse!-definition name)
|
||||||
|
|
||||||
|
@ -181,30 +181,30 @@
|
||||||
[(define/generic *->preserve ->preserve)
|
[(define/generic *->preserve ->preserve)
|
||||||
(define (->preserve preservable)
|
(define (->preserve preservable)
|
||||||
(match preservable
|
(match preservable
|
||||||
[,(deconstruct name #f ty)
|
[,(deconstruct name ty)
|
||||||
,(pattern->unparser pattern 'src)]))]
|
,(pattern->unparser pattern 'src)]))]
|
||||||
])
|
])
|
||||||
|
|
||||||
(define (,(format-symbol "parse-~a" name) input)
|
(define (,(format-symbol "parse-~a" name) input)
|
||||||
(match input
|
(match input
|
||||||
[,(pattern->match-pattern pattern 'dest)
|
[,(pattern->match-pattern pattern 'dest)
|
||||||
,(construct name #f ty)]
|
,(construct name ty)]
|
||||||
[_ eof]))
|
[_ eof]))
|
||||||
,(parse!-definition name)
|
,(parse!-definition name)
|
||||||
|
|
||||||
,@acc ]]))
|
,@acc ]]))
|
||||||
|
|
||||||
(define (deconstruct name wrap? ty)
|
(define (deconstruct name ty)
|
||||||
(match ty
|
(match ty
|
||||||
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
||||||
[(ty-unit) `(,name)]
|
[(ty-unit) `(,name)]
|
||||||
[_ (if wrap? `(,name src) 'src)]))
|
[_ `(,name src)]))
|
||||||
|
|
||||||
(define (construct name wrap? ty)
|
(define (construct name ty)
|
||||||
(match ty
|
(match ty
|
||||||
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
[(ty-record fields) `(,name ,@(map escape (map ty-field-name fields)))]
|
||||||
[(ty-unit) `(,name)]
|
[(ty-unit) `(,name)]
|
||||||
[_ (if wrap? `(,name dest) 'dest)]))
|
[_ `(,name 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]
|
||||||
|
|
|
@ -297,7 +297,7 @@
|
||||||
(define (->preserve preservable)
|
(define (->preserve preservable)
|
||||||
(match
|
(match
|
||||||
preservable
|
preservable
|
||||||
(src
|
((Definitions src)
|
||||||
(for/hash
|
(for/hash
|
||||||
(((key value) (in-dict src)))
|
(((key value) (in-dict src)))
|
||||||
(values key (*->preserve value))))))))
|
(values key (*->preserve value))))))))
|
||||||
|
@ -313,7 +313,7 @@
|
||||||
(cons key value)
|
(cons key value)
|
||||||
make-immutable-hash
|
make-immutable-hash
|
||||||
dest)
|
dest)
|
||||||
dest)
|
(Definitions dest))
|
||||||
(_ eof)))
|
(_ eof)))
|
||||||
(define parse-Definitions!
|
(define parse-Definitions!
|
||||||
(parse-success-or-error 'parse-Definitions parse-Definitions))
|
(parse-success-or-error 'parse-Definitions parse-Definitions))
|
||||||
|
@ -327,7 +327,7 @@
|
||||||
(define (->preserve preservable)
|
(define (->preserve preservable)
|
||||||
(match
|
(match
|
||||||
preservable
|
preservable
|
||||||
(src
|
((DictionaryEntries src)
|
||||||
(for/hash
|
(for/hash
|
||||||
(((key value) (in-dict src)))
|
(((key value) (in-dict src)))
|
||||||
(values key (*->preserve value))))))))
|
(values key (*->preserve value))))))))
|
||||||
|
@ -341,7 +341,7 @@
|
||||||
(cons key value)
|
(cons key value)
|
||||||
make-immutable-hash
|
make-immutable-hash
|
||||||
dest)
|
dest)
|
||||||
dest)
|
(DictionaryEntries dest))
|
||||||
(_ eof)))
|
(_ eof)))
|
||||||
(define parse-DictionaryEntries!
|
(define parse-DictionaryEntries!
|
||||||
(parse-success-or-error 'parse-DictionaryEntries parse-DictionaryEntries))
|
(parse-success-or-error 'parse-DictionaryEntries parse-DictionaryEntries))
|
||||||
|
@ -381,9 +381,14 @@
|
||||||
gen:preservable
|
gen:preservable
|
||||||
((define/generic *->preserve ->preserve)
|
((define/generic *->preserve ->preserve)
|
||||||
(define (->preserve preservable)
|
(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)
|
(define (parse-ModulePath input)
|
||||||
(match input ((list (and dest (? symbol?)) ...) dest) (_ eof)))
|
(match
|
||||||
|
input
|
||||||
|
((list (and dest (? symbol?)) ...) (ModulePath dest))
|
||||||
|
(_ eof)))
|
||||||
(define parse-ModulePath!
|
(define parse-ModulePath!
|
||||||
(parse-success-or-error 'parse-ModulePath parse-ModulePath))
|
(parse-success-or-error 'parse-ModulePath parse-ModulePath))
|
||||||
(struct
|
(struct
|
||||||
|
@ -396,7 +401,7 @@
|
||||||
(define (->preserve preservable)
|
(define (->preserve preservable)
|
||||||
(match
|
(match
|
||||||
preservable
|
preservable
|
||||||
(src
|
((Modules src)
|
||||||
(for/hash
|
(for/hash
|
||||||
(((key value) (in-dict src)))
|
(((key value) (in-dict src)))
|
||||||
(values (*->preserve key) (*->preserve value))))))))
|
(values (*->preserve key) (*->preserve value))))))))
|
||||||
|
@ -412,7 +417,7 @@
|
||||||
(cons key value)
|
(cons key value)
|
||||||
make-immutable-hash
|
make-immutable-hash
|
||||||
dest)
|
dest)
|
||||||
dest)
|
(Modules dest))
|
||||||
(_ eof)))
|
(_ eof)))
|
||||||
(define parse-Modules! (parse-success-or-error 'parse-Modules parse-Modules))
|
(define parse-Modules! (parse-success-or-error 'parse-Modules parse-Modules))
|
||||||
(struct
|
(struct
|
||||||
|
|
|
@ -66,7 +66,7 @@
|
||||||
(pattern->match-pattern variable-named-pat '_)
|
(pattern->match-pattern variable-named-pat '_)
|
||||||
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
|
`(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
|
||||||
,(pattern->match-pattern variable-named-pat '_))))]
|
,(pattern->match-pattern variable-named-pat '_))))]
|
||||||
[(CompoundPattern-dict entries)
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
||||||
(maybe-dest dest-pat-stx
|
(maybe-dest dest-pat-stx
|
||||||
`(hash-table ,@(map (lambda (entry)
|
`(hash-table ,@(map (lambda (entry)
|
||||||
`(,(literal->pattern (car entry))
|
`(,(literal->pattern (car entry))
|
||||||
|
@ -75,11 +75,11 @@
|
||||||
(_ _) ...))]))
|
(_ _) ...))]))
|
||||||
|
|
||||||
(define (Ref-parser-name r)
|
(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))
|
(format-symbol "~aparse-~a" (module-path-prefix module-path) name))
|
||||||
|
|
||||||
(define (Ref-parser!-name r)
|
(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))
|
(format-symbol "~aparse-~a!" (module-path-prefix module-path) name))
|
||||||
|
|
||||||
(define (literal->pattern v)
|
(define (literal->pattern v)
|
||||||
|
|
|
@ -62,12 +62,12 @@
|
||||||
|
|
||||||
(process toplevel-tokens source)
|
(process toplevel-tokens source)
|
||||||
(when (not version) (error 'parse-schema "Missing version declaration"))
|
(when (not version) (error 'parse-schema "Missing version declaration"))
|
||||||
(Schema definitions embeddedType version))
|
(Schema (Definitions definitions) embeddedType version))
|
||||||
|
|
||||||
(define (parse-ref-dsl s)
|
(define (parse-ref-dsl s)
|
||||||
(match-define (list module-path ... final-id)
|
(match-define (list module-path ... final-id)
|
||||||
(map string->symbol (string-split (symbol->string s) ".")))
|
(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 (parse-def-dsl name def-stx)
|
||||||
(define (and-branch input)
|
(define (and-branch input)
|
||||||
|
@ -158,12 +158,13 @@
|
||||||
[(list item ...)
|
[(list item ...)
|
||||||
(CompoundPattern-tuple (map maybe-named item))]
|
(CompoundPattern-tuple (map maybe-named item))]
|
||||||
[(? dict? d) #:when (not (dict-has-key? (strip-annotations d) '...))
|
[(? dict? d) #:when (not (dict-has-key? (strip-annotations d) '...))
|
||||||
(CompoundPattern-dict (for/hash [((k0 vp) (in-dict d))]
|
(CompoundPattern-dict (DictionaryEntries
|
||||||
(define k (strip-annotations k0))
|
(for/hash [((k0 vp) (in-dict d))]
|
||||||
(values k ((maybe-named* NamedSimplePattern-named
|
(define k (strip-annotations k0))
|
||||||
NamedSimplePattern-anonymous
|
(values k ((maybe-named* NamedSimplePattern-named
|
||||||
walk-simple
|
NamedSimplePattern-anonymous
|
||||||
k) vp))))]
|
walk-simple
|
||||||
|
k) vp)))))]
|
||||||
[_ (error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))]))
|
[_ (error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))]))
|
||||||
|
|
||||||
(define (walk stx) (parse-pattern-dsl name (list stx)))
|
(define (walk stx) (parse-pattern-dsl name (list stx)))
|
||||||
|
|
|
@ -78,7 +78,7 @@
|
||||||
(gather-fields* named-pats acc)]
|
(gather-fields* named-pats acc)]
|
||||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||||
(gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
|
(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)]))
|
(gather-fields* (map cdr (sorted-dict-entries entries)) acc)]))
|
||||||
|
|
||||||
(define (pattern-ty p)
|
(define (pattern-ty p)
|
||||||
|
|
|
@ -34,7 +34,7 @@
|
||||||
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
[(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
|
||||||
`(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
|
`(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
|
||||||
,(pattern->unparser variable-named-pat src-stx))]
|
,(pattern->unparser variable-named-pat src-stx))]
|
||||||
[(CompoundPattern-dict entries)
|
[(CompoundPattern-dict (DictionaryEntries entries))
|
||||||
`(hash ,@(append-map (lambda (entry)
|
`(hash ,@(append-map (lambda (entry)
|
||||||
(list `',(car entry)
|
(list `',(car entry)
|
||||||
(pattern->unparser (cdr entry) src-stx)))
|
(pattern->unparser (cdr entry) src-stx)))
|
||||||
|
|
Loading…
Reference in New Issue