208 lines
9.3 KiB
Racket
208 lines
9.3 KiB
Racket
#lang racket/base
|
|
|
|
(provide parse-schema-dsl
|
|
port->schema
|
|
file->schema)
|
|
|
|
(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
|
|
#:source [source #f]
|
|
#:read-include [read-include #f])
|
|
(define version #f)
|
|
(define embeddedType (EmbeddedTypeName-false))
|
|
(define definitions (make-hash))
|
|
|
|
(define (process toplevel-tokens source)
|
|
(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 'include) ,(peel-annotations (? string? path)))
|
|
(when (not read-include)
|
|
(error 'parse-schema-dsl "Cannot include files"))
|
|
(define new-source
|
|
(cond [(absolute-path? path) path]
|
|
[(not source) (error 'parse-schema-dsl "Cannot resolve relative include path")]
|
|
[else (simplify-path (build-path source 'up path) #f)]))
|
|
(process (read-include new-source) new-source)]
|
|
[`(,(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))])))
|
|
|
|
(process toplevel-tokens source)
|
|
(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))))
|
|
|
|
(define (port->schema src [p (current-input-port)])
|
|
(parse-schema-dsl (port->preserves p #:read-syntax? #t #:source src)
|
|
#:source src
|
|
#:read-include (and src (lambda (src) (file->preserves src #:read-syntax? #t)))))
|
|
|
|
(define (file->schema src)
|
|
(call-with-input-file src (lambda (p) (port->schema src p))))
|
|
|
|
(module+ main
|
|
(require preserves)
|
|
(define expected (car (file->preserves "../../../../schema/schema.bin")))
|
|
(equal? expected (Schema->preserves (file->schema "../../../../schema/schema.prs"))))
|