diff --git a/implementations/racket/preserves/preserves-schema/reader.rkt b/implementations/racket/preserves/preserves-schema/reader.rkt new file mode 100644 index 0000000..5815135 --- /dev/null +++ b/implementations/racket/preserves/preserves-schema/reader.rkt @@ -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)))))