Racket Preserves Schema reader implementation
This commit is contained in:
parent
a24a5b19f5
commit
49efc76580
|
@ -0,0 +1,187 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match)
|
||||
(require racket/set)
|
||||
(require racket/dict)
|
||||
(require (only-in racket/list splitf-at))
|
||||
(require (only-in racket/string string-split))
|
||||
(require preserves)
|
||||
|
||||
(require (only-in "type.rkt" namelike))
|
||||
(require "gen/schema.rkt")
|
||||
|
||||
(define (split-by items separator)
|
||||
(let loop ((items items) (acc-rev '()))
|
||||
(if (null? items)
|
||||
(reverse acc-rev)
|
||||
(let-values (((head separator-and-rest)
|
||||
(splitf-at items (lambda (x) (not (preserve=? x separator))))))
|
||||
(loop (if (pair? separator-and-rest)
|
||||
(cdr separator-and-rest)
|
||||
separator-and-rest)
|
||||
(if (null? head)
|
||||
acc-rev
|
||||
(cons head acc-rev)))))))
|
||||
|
||||
(define (input->string input)
|
||||
(preserve->string input #:commas? #f))
|
||||
|
||||
(define (parse-schema-dsl toplevel-tokens #:read-include [read-include #f])
|
||||
(define version #f)
|
||||
(define embeddedType (EmbeddedTypeName-false))
|
||||
(define definitions (make-hash))
|
||||
|
||||
(for [(clause (in-list (split-by (peel-annotations toplevel-tokens) '|.|)))]
|
||||
(match clause
|
||||
[`(,(peel-annotations 'version) ,(peel-annotations v))
|
||||
(set! version (parse-Version! (strip-annotations v)))]
|
||||
[`(,(peel-annotations 'embeddedType) ,(peel-annotations #f))
|
||||
(set! embeddedType (EmbeddedTypeName-false))]
|
||||
[`(,(peel-annotations 'embeddedType) ,(peel-annotations (? symbol? r)))
|
||||
(set! embeddedType (EmbeddedTypeName-Ref (parse-ref-dsl r)))]
|
||||
[`(,(peel-annotations (? symbol? name)) ,(peel-annotations '=) ,@def-stx)
|
||||
(when (hash-has-key? definitions name)
|
||||
(error 'parse-schema-dsl "Duplicate definition: ~a" name))
|
||||
(hash-set! definitions name (parse-def-dsl name def-stx))]
|
||||
[clause (error 'parse-schema-dsl "Invalid clause: ~a" (input->string clause))]))
|
||||
|
||||
(when (not version) (error 'parse-schema "Missing version declaration"))
|
||||
|
||||
(Schema 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))
|
||||
|
||||
(define (parse-def-dsl name def-stx)
|
||||
(define (and-branch input)
|
||||
(define p (parse-pattern-dsl name input))
|
||||
(match (or (find-name input) (find-name (car input)))
|
||||
[#f
|
||||
(NamedPattern-anonymous p)]
|
||||
[n
|
||||
(when (not (Pattern-SimplePattern? p))
|
||||
(error 'parse-def-dsl "Named pattern in 'and' must be simple: ~a" (input->string input)))
|
||||
(NamedPattern-named (NamedSimplePattern_ n (Pattern-SimplePattern-value p)))]))
|
||||
(define (or-branch input)
|
||||
(define p (parse-pattern-dsl name input))
|
||||
(match (or (find-name input) (find-name (car input)))
|
||||
[(and n (not #f)) (NamedAlternative (symbol->string n) p)]
|
||||
[#f (match p
|
||||
[(Pattern-CompoundPattern
|
||||
(CompoundPattern-rec
|
||||
(NamedPattern-anonymous
|
||||
(Pattern-SimplePattern
|
||||
(SimplePattern-lit (? symbol? n))))
|
||||
_))
|
||||
(NamedAlternative (symbol->string n) p)]
|
||||
[(Pattern-SimplePattern (SimplePattern-Ref (Ref _ n)))
|
||||
(NamedAlternative (symbol->string n) p)]
|
||||
[(Pattern-SimplePattern (SimplePattern-lit (app namelike (? symbol? n))))
|
||||
(NamedAlternative (symbol->string n) p)]
|
||||
[_
|
||||
(error 'parse-def-dsl "Name missing for alternative: ~a" (input->string input))])]))
|
||||
(match* [(split-by def-stx '&) (split-by def-stx '/)]
|
||||
[['() '()]
|
||||
(error 'parse-def-dsl "Invalid clause in ~a" name)]
|
||||
[[(list* _ _ _) (list* _ _ _)]
|
||||
(error 'parse-def-dsl "Mixed 'or' and 'and' clause: ~a" (input->string def-stx))]
|
||||
[[(list* p0 p1 pN) (list _)]
|
||||
(Definition-and (and-branch p0) (and-branch p1) (map and-branch pN))]
|
||||
[[(list _) (list* p0 p1 pN)]
|
||||
(Definition-or (or-branch p0) (or-branch p1) (map or-branch pN))]
|
||||
[[(list p) (list _)]
|
||||
(Definition-Pattern (parse-pattern-dsl name p))]))
|
||||
|
||||
(define (parse-pattern-dsl name input)
|
||||
|
||||
(define (parse-simple-dsl item ks kf)
|
||||
(match (peel-annotations item)
|
||||
['any (ks (SimplePattern-any))]
|
||||
['bool (ks (SimplePattern-atom (AtomKind-Boolean)))]
|
||||
['float (ks (SimplePattern-atom (AtomKind-Float)))]
|
||||
['double (ks (SimplePattern-atom (AtomKind-Double)))]
|
||||
['int (ks (SimplePattern-atom (AtomKind-SignedInteger)))]
|
||||
['string (ks (SimplePattern-atom (AtomKind-String)))]
|
||||
['bytes (ks (SimplePattern-atom (AtomKind-ByteString)))]
|
||||
['symbol (ks (SimplePattern-atom (AtomKind-Symbol)))]
|
||||
['embedded (ks (SimplePattern-embedded))]
|
||||
[(? symbol? sym)
|
||||
(define str (symbol->string sym))
|
||||
(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))]
|
||||
[(list stx (peel-annotations '...)) (ks (SimplePattern-seqof (walk-simple stx)))]
|
||||
[(? set? s)
|
||||
(when (not (= (set-count s) 1))
|
||||
(error 'parse-simple-dsl "Invalid set pattern: ~a" (input->string item)))
|
||||
(ks (SimplePattern-setof (walk-simple (car (set->list s)))))]
|
||||
[(hash-table ((peel-annotations '...) (peel-annotations '...)) (kp vp))
|
||||
(ks (SimplePattern-dictof (walk-simple kp) (walk-simple vp)))]
|
||||
[(or (? list?) (? set?) (? dict?) (? record?)) (kf)]
|
||||
[(strip-annotations v) (ks (SimplePattern-lit v))]))
|
||||
|
||||
(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 label) (peel-annotations fields))
|
||||
(CompoundPattern-rec (NamedPattern-anonymous (Pattern-SimplePattern (SimplePattern-lit label)))
|
||||
(NamedPattern-anonymous (walk fields)))]
|
||||
[(list fixed ... variable (peel-annotations '...))
|
||||
(CompoundPattern-tuple* (map maybe-named fixed)
|
||||
(maybe-named-simple
|
||||
(apply annotate (list variable '...) (annotations variable))))]
|
||||
[(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))))]
|
||||
[_ (error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))]))
|
||||
|
||||
(define (walk stx) (parse-pattern-dsl name (list stx)))
|
||||
(define (walk-simple stx)
|
||||
(parse-simple-dsl stx
|
||||
values
|
||||
(lambda () (error 'parse-simple-dsl "Compound patterns not accepted here: ~a" (input->string stx)))))
|
||||
|
||||
(define ((maybe-named* knamed kanonymous recur [literal-name #f]) b)
|
||||
(define n (or (find-name b)
|
||||
(and (symbol? literal-name) literal-name)))
|
||||
(if n
|
||||
(let ((p (parse-simple-dsl
|
||||
b
|
||||
values
|
||||
(lambda () (error 'parse-pattern-dsl "Named pattern must be simple: ~a"
|
||||
(input->string b))))))
|
||||
(knamed (NamedSimplePattern_ n p)))
|
||||
(kanonymous (recur b))))
|
||||
|
||||
(define maybe-named
|
||||
(maybe-named* NamedPattern-named NamedPattern-anonymous walk))
|
||||
|
||||
(define maybe-named-simple
|
||||
(maybe-named* NamedSimplePattern-named NamedSimplePattern-anonymous walk-simple))
|
||||
|
||||
(if (not (= (length input) 1))
|
||||
(error 'parse-pattern-dsl "Invalid pattern: ~a" (input->string input))
|
||||
(parse-simple-dsl (car input)
|
||||
Pattern-SimplePattern
|
||||
(lambda () (Pattern-CompoundPattern (parse-compound-dsl (car input)))))))
|
||||
|
||||
(define (find-name input)
|
||||
(findf symbol? (map peel-annotations (annotations input))))
|
||||
|
||||
(module+ main
|
||||
(require preserves)
|
||||
(define expected (car (file->preserves "../../../../schema/schema.bin")))
|
||||
(equal? expected
|
||||
(Schema->preserves
|
||||
(parse-schema-dsl (file->preserves "../../../../schema/schema.prs"
|
||||
#:read-syntax? #t)))))
|
Loading…
Reference in New Issue