forked from syndicate-lang/preserves
#lang preserves-schema
This commit is contained in:
parent
3559cc679e
commit
98e2511fe1
|
@ -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)
|
||||
|
|
|
@ -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)))
|
|
@ -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)
|
|
@ -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")
|
||||
|
|
|
@ -0,0 +1,4 @@
|
|||
#lang preserves-schema
|
||||
|
||||
version 1 .
|
||||
include "../../../../schema/schema.prs" .
|
|
@ -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"))))
|
||||
|
|
Loading…
Reference in New Issue