From 98e2511fe1df69eb623ee91610dc1e378d6ac909 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 25 May 2021 20:14:10 +0200 Subject: [PATCH] #lang preserves-schema --- .../preserves/preserves-schema/checker.rkt | 14 +++- .../preserves/preserves-schema/compiler.rkt | 84 +++++++++++++++++++ .../preserves-schema/lang/reader.rkt | 21 +++++ .../preserves/preserves-schema/main.rkt | 81 +----------------- .../preserves/preserves-schema/metaschema.rkt | 4 + .../preserves/preserves-schema/reader.rkt | 46 ++++++---- 6 files changed, 152 insertions(+), 98 deletions(-) create mode 100644 implementations/racket/preserves/preserves-schema/compiler.rkt create mode 100644 implementations/racket/preserves/preserves-schema/lang/reader.rkt create mode 100644 implementations/racket/preserves/preserves-schema/metaschema.rkt diff --git a/implementations/racket/preserves/preserves-schema/checker.rkt b/implementations/racket/preserves/preserves-schema/checker.rkt index 2065018..ea7ff47 100644 --- a/implementations/racket/preserves/preserves-schema/checker.rkt +++ b/implementations/racket/preserves/preserves-schema/checker.rkt @@ -1,9 +1,11 @@ #lang racket/base -(provide schema-check-problems) +(provide schema-check-problems + schema-check-problems!) (require racket/match) (require (only-in racket/list check-duplicates)) +(require (only-in racket/string string-join)) (require preserves/order) (require (only-in "type.rkt" unwrap)) @@ -13,7 +15,7 @@ (define problems '()) (define (problem! context f . args) - (set! problems (cons (format "~v: ~a" (reverse context) (apply format f args)) problems))) + (set! problems (cons (format "~a: ~a" (reverse context) (apply format f args)) problems))) (define (check-binding context scope n) (when (hash-has-key? scope n) @@ -61,3 +63,11 @@ [(Definition-Pattern p) (check-pattern context (make-hash) p #t)])) (reverse problems)) + +(define (schema-check-problems! schema #:name [name ""]) + (let ((problems (schema-check-problems schema))) + (when (not (null? problems)) + (error 'schema-check-problems! "Problems checking schema ~a:\n - ~a" + name + (string-join problems "\n - ")))) + schema) diff --git a/implementations/racket/preserves/preserves-schema/compiler.rkt b/implementations/racket/preserves/preserves-schema/compiler.rkt new file mode 100644 index 0000000..9c5c61e --- /dev/null +++ b/implementations/racket/preserves/preserves-schema/compiler.rkt @@ -0,0 +1,84 @@ +#lang racket/base + +(provide schema->module-stx) + +(require preserves) +(require racket/match) +(require (only-in racket/string string-join)) +(require (only-in racket/format ~a)) +(require (only-in racket/syntax format-symbol)) + +(require "type.rkt") +(require "parser.rkt") +(require "unparser.rkt") +(require "checker.rkt") +(require "gen/schema.rkt") + +(define (struct-stx name-pieces field-names) + `(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab)) + +(define (fold-Schema-definitions kc kn schema) + (foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc)) + kn + (sorted-dict-entries (Schema-definitions schema)))) + +(define (map-Schema-definitions proc schema) + (fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema)) + +(define (struct-defs schema) + (fold-Schema-definitions + (lambda (name def acc) + (match (definition-ty def) + [(ty-union variants) + (for/fold [(acc (cons `(define (,(format-symbol "~a?" name) p) + (or ,@(for/list [(variant (in-list variants))] + `(,(format-symbol "~a-~a?" name (car variant)) p)))) + acc))] + [(variant (in-list variants))] + (match-define (list variant-name variant-ty) variant) + (match variant-ty + [(ty-record fields) + (cons (struct-stx (list name variant-name) (map car fields)) acc)] + [(ty-unit) + (cons (struct-stx (list name variant-name) '()) acc)] + [_ + (cons (struct-stx (list name variant-name) '(value)) acc)]))] + [(ty-record fields) + (cons (struct-stx (list name) (map car fields)) acc)] + [_ + acc])) + '() + schema)) + +(define (parser-defs schema) + (map-Schema-definitions definition-parsers schema)) + +(define (unparser-defs schema) + (map-Schema-definitions definition-unparser schema)) + +(define (schema->module-stx name schema) + (schema-check-problems! schema #:name name) + `(module ,name racket/base + (provide (all-defined-out)) + (require preserves) + (require preserves-schema/support) + (require racket/match) + (require racket/set) + (require racket/dict) + ,@(struct-defs schema) + ,@(parser-defs schema) + ,@(unparser-defs schema) + )) + +(module+ main + (require racket/pretty) + (require racket/runtime-path) + + (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)) + + (if #t + (with-output-to-file "gen/schema.rkt" #:exists 'replace + (lambda () (pretty-write metaschema-module-source))) + (pretty-write metaschema-module-source))) diff --git a/implementations/racket/preserves/preserves-schema/lang/reader.rkt b/implementations/racket/preserves/preserves-schema/lang/reader.rkt new file mode 100644 index 0000000..6fb3782 --- /dev/null +++ b/implementations/racket/preserves/preserves-schema/lang/reader.rkt @@ -0,0 +1,21 @@ +#lang racket/base + +(provide (rename-out [read-preserves-schema-module read-syntax])) + +(require preserves) +(require racket/port) + +(require "../reader.rkt") +(require "../compiler.rkt") + +(define (read-preserves-schema-module src [p (current-input-port)]) + (define-values (_dirname filename _must-be-dir) (split-path src)) + (define module-stx + (schema->module-stx + (string->symbol (path->string (path-replace-extension filename ""))) + (parse-schema-dsl (port->list (lambda (p) (read-preserve p #:read-syntax? #t #:source src)) p) + #:source src + #:read-include (lambda (src) (file->preserves src #:read-syntax? #t))))) + ;; (local-require racket/pretty) + ;; (pretty-write module-stx) (newline) + module-stx) diff --git a/implementations/racket/preserves/preserves-schema/main.rkt b/implementations/racket/preserves/preserves-schema/main.rkt index e3db4a5..846d57e 100644 --- a/implementations/racket/preserves/preserves-schema/main.rkt +++ b/implementations/racket/preserves/preserves-schema/main.rkt @@ -2,83 +2,4 @@ (provide schema->module-stx) -(require preserves) -(require racket/match) -(require (only-in racket/string string-join)) -(require (only-in racket/format ~a)) -(require (only-in racket/syntax format-symbol)) - -(require "type.rkt") -(require "parser.rkt") -(require "unparser.rkt") -(require "checker.rkt") -(require "gen/schema.rkt") - -(define (struct-stx name-pieces field-names) - `(struct ,(string->symbol (string-join (map ~a name-pieces) "-")) ,field-names #:prefab)) - -(define (fold-Schema-definitions kc kn schema) - (foldr (lambda (entry acc) (kc (car entry) (cdr entry) acc)) - kn - (sorted-dict-entries (Schema-definitions schema)))) - -(define (map-Schema-definitions proc schema) - (fold-Schema-definitions (lambda (n p acc) (cons (proc n p) acc)) '() schema)) - -(define (struct-defs schema) - (fold-Schema-definitions - (lambda (name def acc) - (match (definition-ty def) - [(ty-union variants) - (for/fold [(acc (cons `(define (,(format-symbol "~a?" name) p) - (or ,@(for/list [(variant (in-list variants))] - `(,(format-symbol "~a-~a?" name (car variant)) p)))) - acc))] - [(variant (in-list variants))] - (match-define (list variant-name variant-ty) variant) - (match variant-ty - [(ty-record fields) - (cons (struct-stx (list name variant-name) (map car fields)) acc)] - [(ty-unit) - (cons (struct-stx (list name variant-name) '()) acc)] - [_ - (cons (struct-stx (list name variant-name) '(value)) acc)]))] - [(ty-record fields) - (cons (struct-stx (list name) (map car fields)) acc)] - [_ - acc])) - '() - schema)) - -(define (parser-defs schema) - (map-Schema-definitions definition-parsers schema)) - -(define (unparser-defs schema) - (map-Schema-definitions definition-unparser schema)) - -(define (schema->module-stx name schema) - `(module ,name racket/base - (provide (all-defined-out)) - (require preserves) - (require preserves-schema/support) - (require racket/match) - (require racket/set) - (require racket/dict) - ,@(struct-defs schema) - ,@(parser-defs schema) - ,@(unparser-defs schema) - )) - -(module+ main - (require racket/pretty) - (define metaschema - (parse-Schema - (with-input-from-file "../../../../schema/schema.bin" read-preserve))) - (let ((problems (schema-check-problems metaschema))) - (when (not (null? problems)) - (error 'schema-check-problems "Problems checking schema: ~v" problems))) - (define metaschema-module-source (schema->module-stx 'gen-schema metaschema)) - (if #t - (with-output-to-file "gen/schema.rkt" #:exists 'replace - (lambda () (pretty-write metaschema-module-source))) - (pretty-write metaschema-module-source))) +(require "compiler.rkt") diff --git a/implementations/racket/preserves/preserves-schema/metaschema.rkt b/implementations/racket/preserves/preserves-schema/metaschema.rkt new file mode 100644 index 0000000..e0eb750 --- /dev/null +++ b/implementations/racket/preserves/preserves-schema/metaschema.rkt @@ -0,0 +1,4 @@ +#lang preserves-schema + +version 1 . +include "../../../../schema/schema.prs" . diff --git a/implementations/racket/preserves/preserves-schema/reader.rkt b/implementations/racket/preserves/preserves-schema/reader.rkt index 5815135..d1df738 100644 --- a/implementations/racket/preserves/preserves-schema/reader.rkt +++ b/implementations/racket/preserves/preserves-schema/reader.rkt @@ -1,5 +1,7 @@ #lang racket/base +(provide parse-schema-dsl) + (require racket/match) (require racket/set) (require racket/dict) @@ -26,27 +28,38 @@ (define (input->string input) (preserve->string input #:commas? #f)) -(define (parse-schema-dsl toplevel-tokens #:read-include [read-include #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)) - (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))])) + (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) @@ -184,4 +197,5 @@ (equal? expected (Schema->preserves (parse-schema-dsl (file->preserves "../../../../schema/schema.prs" - #:read-syntax? #t))))) + #:read-syntax? #t) + #:source "../../../../schema/schema.prs"))))