Always use wrapper struct
This commit is contained in:
parent
e5b6c46169
commit
27002dfe7f
|
@ -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)
|
||||
|
|
|
@ -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]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)))
|
||||
|
|
Loading…
Reference in New Issue