Sort emitted entries; add throwing parser variant

This commit is contained in:
Tony Garnock-Jones 2021-05-25 11:06:30 +02:00
parent 6c9071fd88
commit eeb84ad669
3 changed files with 68 additions and 49 deletions

View File

@ -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

View File

@ -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

View File

@ -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])))