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

Improve error-handling in Racket schema reader

This commit is contained in:
Tony Garnock-Jones 2021-05-28 20:06:46 +02:00
parent b69c3a0894
commit 947b816a57
1 changed files with 9 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -127,7 +127,10 @@
(if (and (> (string-length str) 0) (string=? (substring str 0 1) "="))
(ks (SimplePattern-lit (string->symbol (substring str 1))))
(ks (SimplePattern-Ref (parse-ref-dsl sym))))]
[(strip-annotations (record (record 'lit '()) (list v))) (ks (SimplePattern-lit v))]
[(strip-annotations (record (record 'lit '()) lit-pat))
(match lit-pat
[(list v) (ks (SimplePattern-lit v))]
[_ (error 'parse-simple-dsl "Invalid <<lit> ...> pattern: ~a" (input->string item))])]
[(list stx (peel-annotations '...)) (ks (SimplePattern-seqof (walk-simple stx)))]
[(? set? s)
(when (not (= (set-count s) 1))
@ -140,8 +143,11 @@
(define (parse-compound-dsl item)
(match (peel-annotations item)
[(record (strip-annotations (record 'rec '())) (peel-annotations (list label fields)))
(CompoundPattern-rec (maybe-named label) (maybe-named fields))]
[(record (strip-annotations (record 'rec '())) fields-pat)
(match fields-pat
[(peel-annotations (list label fields))
(CompoundPattern-rec (maybe-named label) (maybe-named fields))]
[_ (error 'parse-simple-dsl "Invalid <<rec> ...> pattern: ~a" (input->string item))])]
[(record (strip-annotations label) (peel-annotations fields))
(CompoundPattern-rec (NamedPattern-anonymous (Pattern-SimplePattern (SimplePattern-lit label)))
(NamedPattern-anonymous (walk fields)))]