preserves/implementations/racket/preserves/preserves-schema/reader.rkt

188 lines
8.4 KiB
Racket

#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)))))