From 33a80533fa3e6f74ff37605124abe5babdd5d187 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Mon, 24 May 2021 12:47:44 +0200
Subject: [PATCH] Checker for Racket

---
 .../preserves/preserves-schema/checker.rkt    | 62 +++++++++++++++++++
 .../preserves/preserves-schema/main.rkt       | 13 ++--
 2 files changed, 70 insertions(+), 5 deletions(-)
 create mode 100644 implementations/racket/preserves/preserves-schema/checker.rkt

diff --git a/implementations/racket/preserves/preserves-schema/checker.rkt b/implementations/racket/preserves/preserves-schema/checker.rkt
new file mode 100644
index 0000000..f693084
--- /dev/null
+++ b/implementations/racket/preserves/preserves-schema/checker.rkt
@@ -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))
diff --git a/implementations/racket/preserves/preserves-schema/main.rkt b/implementations/racket/preserves/preserves-schema/main.rkt
index f6bd0c3..13e7320 100644
--- a/implementations/racket/preserves/preserves-schema/main.rkt
+++ b/implementations/racket/preserves/preserves-schema/main.rkt
@@ -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)))