Autogenerate predicate for unions

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)

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)

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)