diff --git a/implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt b/implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt new file mode 100644 index 0000000..2030f8c --- /dev/null +++ b/implementations/racket/preserves/preserves-schema/bin/preserves-schema-rkt.rkt @@ -0,0 +1,124 @@ +#lang racket/base + +(require "../main.rkt") +(require "../reader.rkt") +(require racket/match) +(require (only-in racket/list index-of append-map remove-duplicates last drop-right)) +(require (only-in racket/string string-split string-prefix?)) +(require (only-in racket/file make-parent-directory*)) +(require file/glob) + +(struct schema (full-input-path + relative-input-path + full-output-path + relative-output-path + module-path + value) #:transparent) + +(define (clean-input p) + (path->string (simplify-path (path->complete-path (expand-user-path p)) #f))) + +(define (compute-base paths) + (match paths + ['() "."] + [(list p) (path->string (simplify-path (build-path p 'up) #f))] + [_ (let try-index ((i 0)) + (let scan-paths ((paths paths) (ch #f)) + (match paths + ['() (try-index (+ i 1))] + [(cons p more-paths) + (cond [(= i (string-length p)) (substring p 0 i)] + [(not ch) (scan-paths more-paths (string-ref p i))] + [(eqv? ch (string-ref p i)) (scan-paths more-paths ch)] + [else (substring p 0 i)])])))])) + +(define (expand-globs globs base0 output-directory0 k) + (define base (or base0 (compute-base globs))) + (define output-directory (or (and output-directory0 (clean-input output-directory0)) + base)) + (k base + output-directory + (for/list [(full-input-path (in-list (map path->string + (remove-duplicates + (append-map (lambda (g) + (define results (glob g)) + (when (null? results) + (error 'preserves-schema-rkt + "Input not found: ~v" g)) + results) + globs)))))] + (when (not (string-prefix? full-input-path base)) + (error 'preserves-schema-rkt "Input filename ~v falls outside base ~v" + full-input-path + base)) + (define relative-input-path (substring full-input-path (string-length base))) + (define module-path (for/list [(p (explode-path relative-input-path))] + (string->symbol (path->string (path-replace-extension p ""))))) + (define relative-output-path + (path->string (path-replace-extension relative-input-path ".rkt"))) + (schema full-input-path + relative-input-path + (path->string (build-path output-directory relative-output-path)) + relative-output-path + module-path + (file->schema full-input-path))))) + +(module+ main + (require racket/cmdline) + (require racket/pretty) + + (define output-directory #f) + (define stdout? #f) + (define base-directory #f) + (define additional-modules '()) + (define inputs '()) + + (command-line #:once-each + ["--output" directory "Output directory for modules (default: next to sources)" + (set! output-directory directory)] + ["--stdout" "Prints each module to stdout one after the other instead of writing them to files in the `--output` directory" + (set! stdout? #t)] + ["--base" directory "Base directory for sources (default: common prefix)" + (set! base-directory directory)] + #:multi + ["--module" namespace=path "Additional Namespace=path import" + (let ((i (index-of (string->list namespace=path) #\=))) + (when (not i) + (error '--module "Argument must be Namespace=path: ~v" namespace=path)) + (let* ((namespace-str (substring namespace=path 0 i)) + (path-str (substring namespace=path (+ i 1)))) + (set! additional-modules + (cons (list (map string->symbol (string-split namespace-str ".")) + path-str) + additional-modules))))] + #:args input-glob + (set! inputs (map clean-input input-glob))) + + (expand-globs inputs + base-directory + output-directory + (lambda (base-directory output-directory schemas) + + (define index (make-hash)) + (for [(s (in-list schemas))] + (hash-set! index (schema-module-path s) (schema-relative-output-path s))) + (for [(e (in-list additional-modules))] + (hash-set! index (car e) (cadr e))) + + (define outputs + (for/hash [(s (in-list schemas))] + (values (schema-full-output-path s) + (schema->module-stx (last (schema-module-path s)) + (lambda (module-path) + (hash-ref index + module-path + (lambda () + (error 'preserves-schema-rkt + "Undefined module: ~a" + module-path)))) + (schema-value s))))) + + (for [((output-path stx) (in-hash outputs))] + (make-parent-directory* output-path) + (with-output-to-file output-path #:exists 'replace + (lambda () (pretty-write stx))))))) diff --git a/implementations/racket/preserves/preserves-schema/compiler.rkt b/implementations/racket/preserves/preserves-schema/compiler.rkt index 9c5c61e..dce72f8 100644 --- a/implementations/racket/preserves/preserves-schema/compiler.rkt +++ b/implementations/racket/preserves/preserves-schema/compiler.rkt @@ -25,6 +25,54 @@ (define (map-Schema-definitions proc schema) (fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema)) +(define (module-imports schema lookup-module-path) + (define imports (make-hash)) + (define (import-ref! r) + (match-define (Ref module-path _name) r) + (when (not (null? module-path)) + (hash-set! imports module-path #t))) + (define (walk x) + (match (unwrap x) + [(Definition-Pattern p) (walk p)] + [(Definition-or p0 p1 pN) (for-each walk (list* p0 p1 pN))] + [(Definition-and p0 p1 pN) (for-each walk (list* p0 p1 pN))] + [(NamedSimplePattern_ n p) (walk p)] + [(NamedAlternative _ p) (walk p)] + [(SimplePattern-seqof p) (walk p)] + [(SimplePattern-setof p) (walk p)] + [(SimplePattern-dictof kp vp) + (walk kp) + (walk vp)] + [(SimplePattern-Ref r) (import-ref! r)] + [(? SimplePattern?) (void)] + [(CompoundPattern-rec label-named-pat fields-named-pat) + (walk label-named-pat) + (walk fields-named-pat)] + [(CompoundPattern-tuple named-pats) + (for-each walk named-pats)] + [(CompoundPattern-tuple* fixed-named-pats variable-named-pat) + (for-each walk fixed-named-pats) + (walk variable-named-pat)] + [(CompoundPattern-dict entries) + (for-each walk (map cdr (sorted-dict-entries entries)))] + [x (error 'module-imports "Unimplemented: ~v" x)])) + (match (Schema-embeddedType schema) + [(EmbeddedTypeName-false) (void)] + [(EmbeddedTypeName-Ref r) (import-ref! r)]) + (map-Schema-definitions (lambda (n p) (walk p)) schema) + (for/list [(import (in-hash-keys imports))] + `(require (prefix-in ,(module-path-prefix import) ,(lookup-module-path import))))) + +(define (embedded-defs schema) + (match (Schema-embeddedType schema) + [(EmbeddedTypeName-false) `((define :parse-embedded values) + (define :embedded->preserves values))] + [(EmbeddedTypeName-Ref r) `((define (:parse-embedded input) + (match input + [,(pattern->match-pattern (SimplePattern-Ref r) 'output) output] + [_ eof])) + (define (:embedded->preserves input) + ,(pattern->unparser (SimplePattern-Ref r) 'input)))])) (define (struct-defs schema) (fold-Schema-definitions (lambda (name def acc) @@ -56,10 +104,12 @@ (define (unparser-defs schema) (map-Schema-definitions definition-unparser schema)) -(define (schema->module-stx name schema) +(define (schema->module-stx name lookup-module-path schema) (schema-check-problems! schema #:name name) `(module ,name racket/base (provide (all-defined-out)) + ,@(module-imports schema lookup-module-path) + ,@(embedded-defs schema) (require preserves) (require preserves-schema/support) (require racket/match) @@ -76,7 +126,10 @@ (define-runtime-path schema-binary "../../../../schema/schema.bin") (define metaschema (parse-Schema (with-input-from-file schema-binary read-preserve))) - (define metaschema-module-source (schema->module-stx 'gen-schema metaschema)) + (define metaschema-module-source (schema->module-stx 'gen-schema + (lambda (module-path) + (error 'compiler-rkt-main "~a" module-path)) + metaschema)) (if #t (with-output-to-file "gen/schema.rkt" #:exists 'replace diff --git a/implementations/racket/preserves/preserves-schema/info.rkt b/implementations/racket/preserves/preserves-schema/info.rkt new file mode 100644 index 0000000..cc452e4 --- /dev/null +++ b/implementations/racket/preserves/preserves-schema/info.rkt @@ -0,0 +1,3 @@ +#lang setup/infotab +(define racket-launcher-names '("preserves-schema-rkt")) +(define racket-launcher-libraries '("bin/preserves-schema-rkt.rkt")) diff --git a/implementations/racket/preserves/preserves-schema/main.rkt b/implementations/racket/preserves/preserves-schema/main.rkt index 84bf6e7..f5473fb 100644 --- a/implementations/racket/preserves/preserves-schema/main.rkt +++ b/implementations/racket/preserves/preserves-schema/main.rkt @@ -6,14 +6,10 @@ (module+ reader (provide (rename-out [read-preserves-schema-module read-syntax])) - - (require (only-in preserves port->preserves file->preserves)) - (require (only-in "reader.rkt" parse-schema-dsl)) - + (require (only-in "reader.rkt" port->schema)) (define (read-preserves-schema-module src [p (current-input-port)]) (define-values (_dirname filename _must-be-dir) (split-path src)) (schema->module-stx (string->symbol (path->string (path-replace-extension filename ""))) - (parse-schema-dsl (port->preserves p #:read-syntax? #t #:source src) - #:source src - #:read-include (lambda (src) (file->preserves src #:read-syntax? #t)))))) + (lambda (module-path) (error 'read-preserves-schema-module "~a" module-path)) + (port->schema src p)))) diff --git a/implementations/racket/preserves/preserves-schema/parser.rkt b/implementations/racket/preserves/preserves-schema/parser.rkt index d89ad4d..21f6c4d 100644 --- a/implementations/racket/preserves/preserves-schema/parser.rkt +++ b/implementations/racket/preserves/preserves-schema/parser.rkt @@ -1,6 +1,7 @@ #lang racket/base -(provide definition-parsers) +(provide definition-parsers + pattern->match-pattern) (require preserves) (require racket/match) @@ -62,7 +63,8 @@ [(AtomKind-String) 'string?] [(AtomKind-ByteString) 'bytes?] [(AtomKind-Symbol) 'symbol?])))] - [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")] + [(SimplePattern-embedded) + `(embedded (app :parse-embedded ,(maybe-dest dest-pat-stx `(not (== eof)))))] [(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))] [(SimplePattern-seqof variable-pat) `(list ,(pattern->match-pattern variable-pat dest-pat-stx) ...)] @@ -81,10 +83,9 @@ (cons key value) make-immutable-hash ,dest-pat-stx)] - [(SimplePattern-Ref (Ref '() name)) - `(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))] [(SimplePattern-Ref (Ref module-path name)) - (error 'pattern-parser "Ref with non-empty module path not yet implemented")] + `(app ,(format-symbol "~aparse-~a" (module-path-prefix module-path) name) + ,(maybe-dest dest-pat-stx `(not (== eof))))] [(CompoundPattern-rec label-pat fields-pat) (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_) ,(pattern->match-pattern fields-pat '_)))] diff --git a/implementations/racket/preserves/preserves-schema/reader.rkt b/implementations/racket/preserves/preserves-schema/reader.rkt index d1df738..363caa6 100644 --- a/implementations/racket/preserves/preserves-schema/reader.rkt +++ b/implementations/racket/preserves/preserves-schema/reader.rkt @@ -1,6 +1,8 @@ #lang racket/base -(provide parse-schema-dsl) +(provide parse-schema-dsl + port->schema + file->schema) (require racket/match) (require racket/set) @@ -191,11 +193,15 @@ (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 - (parse-schema-dsl (file->preserves "../../../../schema/schema.prs" - #:read-syntax? #t) - #:source "../../../../schema/schema.prs")))) + (equal? expected (Schema->preserves (file->schema "../../../../schema/schema.prs")))) diff --git a/implementations/racket/preserves/preserves-schema/type.rkt b/implementations/racket/preserves/preserves-schema/type.rkt index 38f8273..e6d9641 100644 --- a/implementations/racket/preserves/preserves-schema/type.rkt +++ b/implementations/racket/preserves/preserves-schema/type.rkt @@ -11,12 +11,14 @@ definition-ty unwrap namelike - escape) + escape + module-path-prefix) (require preserves/record) (require preserves/order) (require racket/match) (require (only-in racket/syntax format-symbol)) +(require (only-in racket/string string-join)) (require "gen/schema.rkt") @@ -94,3 +96,8 @@ (define (escape s) (format-symbol "$~a" s)) + +(define (module-path-prefix module-path) + (if (null? module-path) + '|| + (format-symbol "~a:" (string-join (map symbol->string module-path) ":")))) diff --git a/implementations/racket/preserves/preserves-schema/unparser.rkt b/implementations/racket/preserves/preserves-schema/unparser.rkt index 4c41d70..e816f3c 100644 --- a/implementations/racket/preserves/preserves-schema/unparser.rkt +++ b/implementations/racket/preserves/preserves-schema/unparser.rkt @@ -1,6 +1,7 @@ #lang racket/base -(provide definition-unparser) +(provide definition-unparser + pattern->unparser) (require preserves) (require racket/match) @@ -10,15 +11,6 @@ (require "type.rkt") (require "gen/schema.rkt") -(define (simple-pattern? p) - (match p - ['any #t] - [(record 'atom _) #t] - [(record 'embedded _) #t] - [(record 'lit _) #t] - [(record 'ref _) #t] - [_ #f])) - (define (definition-unparser name def) (define ty (definition-ty def)) `(define (,(format-symbol "~a->preserves" name) input) @@ -33,13 +25,13 @@ [(Definition-and p0 p1 pN) `(match input [,(deconstruct name #f ty) - (merge-preserves (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge"))) - ,@(append-map - (lambda (named-pat) - (if (simple-pattern? named-pat) - '() - (list (pattern->unparser named-pat 'src)))) - (list* p0 p1 pN)))])] + (merge-preserves + (lambda (a b) (if (equal? a b) a (error 'merge-preserves "Cannot merge"))) + ,@(append-map (lambda (named-pat) + (match named-pat + [(NamedPattern-anonymous (Pattern-SimplePattern _)) '()] + [_ (list (pattern->unparser named-pat 'src))])) + (list* p0 p1 pN)))])] [(Definition-Pattern pattern) `(match input [,(deconstruct name #f ty) @@ -56,7 +48,7 @@ [(NamedSimplePattern_ n p) (pattern->unparser p (escape n))] [(SimplePattern-any) src-stx] [(SimplePattern-atom _) src-stx] - [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")] + [(SimplePattern-embedded) `(embedded (:embedded->preserves ,src-stx))] [(SimplePattern-lit v) `',v] [(SimplePattern-seqof variable-pat) `(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))] @@ -66,9 +58,8 @@ `(for/hash [((key value) (in-dict ,src-stx))] (values ,(pattern->unparser key-pat 'key) ,(pattern->unparser value-pat 'value)))] - [(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)] [(SimplePattern-Ref (Ref module-path name)) - (error 'pattern-parser "Ref with non-empty module path not yet implemented")] + `(,(format-symbol "~a~a->preserves" (module-path-prefix module-path) name) ,src-stx)] [(CompoundPattern-rec label-pat fields-pat) `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))] [(CompoundPattern-tuple named-pats)