Code generator tool; handle module references and embeddeds

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

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

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

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

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 '_)))]

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

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

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)