Sort emitted entries; add throwing parser variant
This commit is contained in:
parent
6c9071fd88
commit
eeb84ad669
|
@ -17,36 +17,44 @@
|
|||
(define (struct-stx name-pieces field-names)
|
||||
`(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab))
|
||||
|
||||
(define (fold-Schema-definitions kc kn schema)
|
||||
(foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc))
|
||||
kn
|
||||
(sorted-dict-entries (Schema-definitions schema))))
|
||||
|
||||
(define (map-Schema-definitions proc schema)
|
||||
(fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema))
|
||||
|
||||
(define (struct-defs schema)
|
||||
(reverse (for/fold [(acc '())]
|
||||
[((name def) (in-hash (Schema-definitions schema)))]
|
||||
(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 car fields)) acc)]
|
||||
[(ty-unit)
|
||||
(cons (struct-stx (list name variant-name) '()) acc)]
|
||||
[_
|
||||
(cons (struct-stx (list name variant-name) '(value)) acc)]))]
|
||||
[(ty-record fields)
|
||||
(cons (struct-stx (list name) (map car fields)) acc)]
|
||||
[_
|
||||
acc]))))
|
||||
(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 car fields)) acc)]
|
||||
[(ty-unit)
|
||||
(cons (struct-stx (list name variant-name) '()) acc)]
|
||||
[_
|
||||
(cons (struct-stx (list name variant-name) '(value)) acc)]))]
|
||||
[(ty-record fields)
|
||||
(cons (struct-stx (list name) (map car fields)) acc)]
|
||||
[_
|
||||
acc]))
|
||||
'()
|
||||
schema))
|
||||
|
||||
(define (parser-defs schema)
|
||||
(for/list [((name def) (in-hash (Schema-definitions schema)))]
|
||||
(definition-parser name def)))
|
||||
(map-Schema-definitions definition-parsers schema))
|
||||
|
||||
(define (unparser-defs schema)
|
||||
(for/list [((name def) (in-hash (Schema-definitions schema)))]
|
||||
(definition-unparser name def)))
|
||||
(map-Schema-definitions definition-unparser schema))
|
||||
|
||||
(define (schema->module-stx name schema)
|
||||
`(module ,name racket/base
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide definition-parser)
|
||||
(provide definition-parsers)
|
||||
|
||||
(require preserves)
|
||||
(require racket/match)
|
||||
|
@ -9,29 +9,33 @@
|
|||
(require "type.rkt")
|
||||
(require "gen/schema.rkt")
|
||||
|
||||
(define (definition-parser name def)
|
||||
(define (definition-parsers name def)
|
||||
(define ty (definition-ty def))
|
||||
`(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])])))
|
||||
`(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
|
||||
|
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide parse-sequence)
|
||||
(provide parse-sequence
|
||||
parse-success-or-error)
|
||||
|
||||
(require racket/match)
|
||||
|
||||
|
@ -16,3 +17,9 @@
|
|||
[item-pat (loop remainder (cons item-expr acc-rev))]
|
||||
[_ (values #f #f)])])))
|
||||
#t target-pat))]))
|
||||
|
||||
(define (parse-success-or-error parser-name parser)
|
||||
(lambda (input)
|
||||
(match (parser input)
|
||||
[(? eof-object?) (error parser-name "Invalid input")]
|
||||
[v v])))
|
||||
|
|
Loading…
Reference in New Issue