forked from syndicate-lang/preserves
Checker for Racket
This commit is contained in:
parent
1ca796e6aa
commit
33a80533fa
|
@ -0,0 +1,62 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide schema-check-problems)
|
||||
|
||||
(require racket/match)
|
||||
(require (only-in racket/list check-duplicates))
|
||||
|
||||
(require (only-in "type.rkt" unwrap add-name-if-absent))
|
||||
(require "gen/schema.rkt")
|
||||
|
||||
(define (schema-check-problems schema)
|
||||
(define problems '())
|
||||
|
||||
(define (problem! context f . args)
|
||||
(set! problems (cons (format "~v: ~a" (reverse context) (apply format f args)) problems)))
|
||||
|
||||
(define (check-binding context scope n)
|
||||
(when (hash-has-key? scope n)
|
||||
(problem! context "duplicate binding ~v" n))
|
||||
(hash-set! scope n #t))
|
||||
|
||||
(define (check-pattern context scope p value-available?)
|
||||
(match (unwrap p)
|
||||
[(SimplePattern-lit _)
|
||||
(void)]
|
||||
[(? SimplePattern?)
|
||||
(when (not value-available?) (problem! context "non-bijection"))]
|
||||
[(CompoundPattern-rec l f)
|
||||
(check-named-pattern (cons "label" context) scope l)
|
||||
(check-named-pattern (cons "fields" context) scope f)]
|
||||
[(CompoundPattern-tuple ps)
|
||||
(for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))]
|
||||
[(CompoundPattern-tuple* ps v)
|
||||
(for [(p (in-list ps)) (i (in-naturals))] (check-named-pattern (cons i context) scope p))
|
||||
(check-named-pattern (cons "tail" context) scope v)]
|
||||
[(CompoundPattern-dict entries)
|
||||
(for [((k v) (in-hash entries))]
|
||||
(check-named-pattern (cons k context) scope (add-name-if-absent k v)))]))
|
||||
|
||||
(define (check-named-pattern context scope p)
|
||||
(match (unwrap p)
|
||||
[(NamedSimplePattern_ n p)
|
||||
(check-binding context scope n)
|
||||
(check-pattern (cons n context) scope p #t)]
|
||||
[p (check-pattern context scope p #f)]))
|
||||
|
||||
(for [((name def) (in-hash (Schema-definitions schema)))]
|
||||
(define context (list name))
|
||||
(match def
|
||||
[(Definition-or p0 p1 pN)
|
||||
(define alts (list* p0 p1 pN))
|
||||
(unless (void? (check-duplicates alts #:key NamedAlternative-variantLabel #:default (void)))
|
||||
(problem! context "duplicate variant label"))
|
||||
(for [(a (in-list alts))]
|
||||
(check-pattern context (make-hash) (NamedAlternative-pattern a) #t))]
|
||||
[(Definition-and p0 p1 pN)
|
||||
(define scope (make-hash))
|
||||
(for [(p (in-list (list* p0 p1 pN)))]
|
||||
(check-named-pattern context scope p))]
|
||||
[(Definition-Pattern p) (check-pattern context (make-hash) p #t)]))
|
||||
|
||||
(reverse problems))
|
|
@ -11,6 +11,7 @@
|
|||
(require "type.rkt")
|
||||
(require "parser.rkt")
|
||||
(require "unparser.rkt")
|
||||
(require "checker.rkt")
|
||||
(require "gen/schema.rkt")
|
||||
|
||||
(define (struct-stx name-pieces field-names)
|
||||
|
@ -62,11 +63,13 @@
|
|||
|
||||
(module+ main
|
||||
(require racket/pretty)
|
||||
(define metaschema-module-source
|
||||
(schema->module-stx
|
||||
'gen-schema
|
||||
(parse-Schema
|
||||
(with-input-from-file "../../../../schema/schema.bin" read-preserve))))
|
||||
(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)))
|
||||
|
|
Loading…
Reference in New Issue