88 lines
3.4 KiB
Racket
88 lines
3.4 KiB
Racket
#lang racket/base
|
|
|
|
(provide schema-check-problems
|
|
schema-check-problems!
|
|
valid-id?)
|
|
|
|
(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))
|
|
(require "gen/schema.rkt")
|
|
|
|
(define (valid-id? x)
|
|
(and (symbol? x)
|
|
(regexp-match? #px"^[a-zA-Z][a-zA-Z_0-9]*$" (symbol->string x))))
|
|
|
|
(define (schema-check-problems schema)
|
|
(define problems '())
|
|
|
|
(define (problem! context f . args)
|
|
(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)
|
|
(problem! context "duplicate binding ~v" n))
|
|
(when (not (valid-id? n))
|
|
(problem! context "invalid binding name ~v" n))
|
|
(hash-set! scope n #t))
|
|
|
|
(define (check-pattern context scope p value-available?)
|
|
(match (unwrap p)
|
|
[(SimplePattern-lit _)
|
|
(void)]
|
|
[(? SimplePattern? u)
|
|
(when (not value-available?) (problem! context "necessary information not captured"))
|
|
(match u
|
|
[(SimplePattern-Ref (Ref (ModulePath ids) id))
|
|
(when (not (andmap valid-id? (cons id ids)))
|
|
(problem! context "invalid reference name"))]
|
|
[_ (void)])]
|
|
[(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-tuplePrefix 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 (DictionaryEntries entries))
|
|
(for [(entry (in-list (sorted-dict-entries entries)))]
|
|
(check-named-pattern (cons (car entry) context) scope (cdr entry)))]))
|
|
|
|
(define (check-named-pattern context scope p)
|
|
(match (unwrap p)
|
|
[(Binding 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 (Definitions-value (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))]
|
|
(define label (string->symbol (NamedAlternative-variantLabel a)))
|
|
(when (not (valid-id? label)) (problem! context "invalid variant label ~v" label))
|
|
(check-pattern (cons label 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))
|
|
|
|
(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)
|