64 lines
2.3 KiB
Racket
64 lines
2.3 KiB
Racket
#lang racket/base
|
|
|
|
(provide schema-check-problems)
|
|
|
|
(require racket/match)
|
|
(require (only-in racket/list check-duplicates))
|
|
(require preserves/order)
|
|
|
|
(require (only-in "type.rkt" unwrap))
|
|
(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 [(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)
|
|
[(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))
|