#lang preserves-schema

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 "<unknown>"])
+  (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)

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

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)

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

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

@@ -0,0 +1,4 @@
+#lang preserves-schema
+
+version 1 .
+include "../../../../schema/schema.prs" .

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