From 9e6743abdc20b40e126816b84d6b346f014d16b7 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonyg@leastfixedpoint.com>
Date: Sat, 22 May 2021 15:50:54 +0200
Subject: [PATCH] Autogenerate predicate for unions

---
 .../preserves/preserves-schema/gen-schema.rkt | 31 +++++++++++++++++++
 .../preserves/preserves-schema/main.rkt       |  7 +++--
 .../preserves/preserves-schema/type.rkt       | 15 ---------
 3 files changed, 36 insertions(+), 17 deletions(-)

diff --git a/implementations/racket/preserves/preserves-schema/gen-schema.rkt b/implementations/racket/preserves/preserves-schema/gen-schema.rkt
index 46a05c0..f075dac 100644
--- a/implementations/racket/preserves/preserves-schema/gen-schema.rkt
+++ b/implementations/racket/preserves/preserves-schema/gen-schema.rkt
@@ -5,8 +5,16 @@
   (require racket/match)
   (require racket/set)
   (require racket/dict)
+  (define (NamedPattern? p)
+    (or (NamedPattern-named? p) (NamedPattern-anonymous? p)))
   (struct NamedPattern-named (value) #:prefab)
   (struct NamedPattern-anonymous (value) #:prefab)
+  (define (SimplePattern? p)
+    (or (SimplePattern-any? p)
+        (SimplePattern-atom? p)
+        (SimplePattern-embedded? p)
+        (SimplePattern-lit? p)
+        (SimplePattern-Ref? p)))
   (struct SimplePattern-any () #:prefab)
   (struct SimplePattern-atom (atomKind) #:prefab)
   (struct SimplePattern-embedded () #:prefab)
@@ -14,8 +22,17 @@
   (struct SimplePattern-Ref (value) #:prefab)
   (struct NamedAlternative (variantLabel pattern) #:prefab)
   (struct Schema (version embeddedType definitions) #:prefab)
+  (define (Pattern? p)
+    (or (Pattern-SimplePattern? p) (Pattern-CompoundPattern? p)))
   (struct Pattern-SimplePattern (value) #:prefab)
   (struct Pattern-CompoundPattern (value) #:prefab)
+  (define (CompoundPattern? p)
+    (or (CompoundPattern-rec? p)
+        (CompoundPattern-tuple? p)
+        (CompoundPattern-tuple*? p)
+        (CompoundPattern-setof? p)
+        (CompoundPattern-dictof? p)
+        (CompoundPattern-dict? p)))
   (struct CompoundPattern-rec (label fields) #:prefab)
   (struct CompoundPattern-tuple (patterns) #:prefab)
   (struct CompoundPattern-tuple* (fixed variable) #:prefab)
@@ -25,13 +42,27 @@
   (struct Ref (module name) #:prefab)
   (struct Bundle (modules) #:prefab)
   (struct NamedSimplePattern_ (name pattern) #:prefab)
+  (define (Definition? p)
+    (or (Definition-or? p) (Definition-and? p) (Definition-Pattern? p)))
   (struct Definition-or (pattern0 pattern1 patternN) #:prefab)
   (struct Definition-and (pattern0 pattern1 patternN) #:prefab)
   (struct Definition-Pattern (value) #:prefab)
+  (define (NamedSimplePattern? p)
+    (or (NamedSimplePattern-named? p) (NamedSimplePattern-anonymous? p)))
   (struct NamedSimplePattern-named (value) #:prefab)
   (struct NamedSimplePattern-anonymous (value) #:prefab)
+  (define (EmbeddedTypeName? p)
+    (or (EmbeddedTypeName-Ref? p) (EmbeddedTypeName-false? p)))
   (struct EmbeddedTypeName-Ref (value) #:prefab)
   (struct EmbeddedTypeName-false () #:prefab)
+  (define (AtomKind? p)
+    (or (AtomKind-Boolean? p)
+        (AtomKind-Float? p)
+        (AtomKind-Double? p)
+        (AtomKind-SignedInteger? p)
+        (AtomKind-String? p)
+        (AtomKind-ByteString? p)
+        (AtomKind-Symbol? p)))
   (struct AtomKind-Boolean () #:prefab)
   (struct AtomKind-Float () #:prefab)
   (struct AtomKind-Double () #:prefab)
diff --git a/implementations/racket/preserves/preserves-schema/main.rkt b/implementations/racket/preserves/preserves-schema/main.rkt
index afcaf78..1611055 100644
--- a/implementations/racket/preserves/preserves-schema/main.rkt
+++ b/implementations/racket/preserves/preserves-schema/main.rkt
@@ -6,6 +6,7 @@
 (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")
@@ -20,7 +21,10 @@
                      [((name def) (in-hash (Schema-definitions schema)))]
              (match (definition-ty def)
                [(ty-union variants)
-                (for/fold [(acc acc)]
+                (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
@@ -51,7 +55,6 @@
      (require racket/match)
      (require racket/set)
      (require racket/dict)
-     ;; TODO: overall predicate for e.g. CompoundPattern, anything with an alternation
      ,@(struct-defs schema)
      ,@(parser-defs schema)
      ,@(unparser-defs schema)
diff --git a/implementations/racket/preserves/preserves-schema/type.rkt b/implementations/racket/preserves/preserves-schema/type.rkt
index eb43dc0..2259b8b 100644
--- a/implementations/racket/preserves/preserves-schema/type.rkt
+++ b/implementations/racket/preserves/preserves-schema/type.rkt
@@ -55,21 +55,6 @@
 (define (gather-fields* named-pats acc)
   (foldr gather-fields acc named-pats))
 
-(define (SimplePattern? p)
-  (or (SimplePattern-any? p)
-      (SimplePattern-atom? p)
-      (SimplePattern-embedded? p)
-      (SimplePattern-lit? p)
-      (SimplePattern-Ref? p)))
-
-(define (CompoundPattern? p)
-  (or (CompoundPattern-rec? p)
-      (CompoundPattern-tuple? p)
-      (CompoundPattern-tuple*? p)
-      (CompoundPattern-setof? p)
-      (CompoundPattern-dictof? p)
-      (CompoundPattern-dict? p)))
-
 (define (gather-fields named-pat acc)
   (match (unwrap named-pat)
     [(NamedSimplePattern_ n p)