Code generator tool; handle module references and embeddeds
This commit is contained in:
parent
cb88c587b6
commit
f90544d807
|
@ -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)))))))
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1,3 @@
|
|||
#lang setup/infotab
|
||||
(define racket-launcher-names '("preserves-schema-rkt"))
|
||||
(define racket-launcher-libraries '("bin/preserves-schema-rkt.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))))
|
||||
|
|
|
@ -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 '_)))]
|
||||
|
|
|
@ -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"))))
|
||||
|
|
|
@ -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) ":"))))
|
||||
|
|
|
@ -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,12 +25,12 @@
|
|||
[(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))))
|
||||
(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
|
||||
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue