Follow improvements through Racket schema impl

implementations/racket/preserves/preserves-schema/gen/schema.rkt

@@ -14,11 +14,17 @@
         (SimplePattern-atom? p)
         (SimplePattern-embedded? p)
         (SimplePattern-lit? p)
+        (SimplePattern-seqof? p)
+        (SimplePattern-setof? p)
+        (SimplePattern-dictof? p)
         (SimplePattern-Ref? p)))
   (struct SimplePattern-any () #:prefab)
   (struct SimplePattern-atom (atomKind) #:prefab)
   (struct SimplePattern-embedded () #:prefab)
   (struct SimplePattern-lit (value) #:prefab)
+  (struct SimplePattern-seqof (pattern) #:prefab)
+  (struct SimplePattern-setof (pattern) #:prefab)
+  (struct SimplePattern-dictof (key value) #:prefab)
   (struct SimplePattern-Ref (value) #:prefab)
   (struct NamedAlternative (variantLabel pattern) #:prefab)
   (struct Schema (version embeddedType definitions) #:prefab)
@@ -30,14 +36,10 @@
     (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)
-  (struct CompoundPattern-setof (pattern) #:prefab)
-  (struct CompoundPattern-dictof (key value) #:prefab)
   (struct CompoundPattern-dict (entries) #:prefab)
   (struct Ref (module name) #:prefab)
   (struct Bundle (modules) #:prefab)
@@ -89,6 +91,23 @@
       (SimplePattern-atom $atomKind))
      ((and dest (record 'embedded (list))) (SimplePattern-embedded))
      ((and dest (record 'lit (list $value))) (SimplePattern-lit $value))
+     ((and dest
+           (record
+            'seqof
+            (list (app parse-SimplePattern (and $pattern (not (== eof)))))))
+      (SimplePattern-seqof $pattern))
+     ((and dest
+           (record
+            'setof
+            (list (app parse-SimplePattern (and $pattern (not (== eof)))))))
+      (SimplePattern-setof $pattern))
+     ((and dest
+           (record
+            'dictof
+            (list
+             (app parse-SimplePattern (and $key (not (== eof))))
+             (app parse-SimplePattern (and $value (not (== eof)))))))
+      (SimplePattern-dictof $key $value))
      ((app parse-Ref (and dest (not (== eof)))) (SimplePattern-Ref dest))
      (_ eof)))
   (define (parse-NamedAlternative input)
@@ -153,31 +172,17 @@
            (record
             'tuple
             (list
-             (list*
+             (list
-              (list
+              (app parse-NamedPattern (and $patterns (not (== eof))))
-               (app parse-NamedPattern (and $patterns (not (== eof))))
+              ...))))
-               ...)))))
       (CompoundPattern-tuple $patterns))
      ((and dest
            (record
             'tuple*
             (list
-             (list*
+             (list (app parse-NamedPattern (and $fixed (not (== eof)))) ...)
-              (list (app parse-NamedPattern (and $fixed (not (== eof)))) ...))
              (app parse-NamedSimplePattern (and $variable (not (== eof)))))))
       (CompoundPattern-tuple* $fixed $variable))
-     ((and dest
-           (record
-            'setof
-            (list (app parse-SimplePattern (and $pattern (not (== eof)))))))
-      (CompoundPattern-setof $pattern))
-     ((and dest
-           (record
-            'dictof
-            (list
-             (app parse-SimplePattern (and $key (not (== eof))))
-             (app parse-SimplePattern (and $value (not (== eof)))))))
-      (CompoundPattern-dictof $key $value))
      ((and dest
            (record
             'dict
@@ -272,11 +277,7 @@
      ((and dest (== '#f)) (EmbeddedTypeName-false))
      (_ eof)))
   (define (parse-ModulePath input)
-    (match
+    (match input ((list (and dest (? symbol?)) ...) dest) (_ eof)))
-     input
-     ((parse-sequence list? values (and item (? symbol?)) item values dest)
-      dest)
-     (_ eof)))
   (define (parse-AtomKind input)
     (match
      input
@@ -315,6 +316,16 @@
       (record 'atom (list (AtomKind->preserves $atomKind))))
      ((SimplePattern-embedded) (record 'embedded (list)))
      ((SimplePattern-lit $value) (record 'lit (list $value)))
+     ((SimplePattern-seqof $pattern)
+      (record 'seqof (list (SimplePattern->preserves $pattern))))
+     ((SimplePattern-setof $pattern)
+      (record 'setof (list (SimplePattern->preserves $pattern))))
+     ((SimplePattern-dictof $key $value)
+      (record
+       'dictof
+       (list
+        (SimplePattern->preserves $key)
+        (SimplePattern->preserves $value))))
      ((SimplePattern-Ref src) (Ref->preserves src))))
   (define (NamedAlternative->preserves input)
     (match
@@ -360,25 +371,15 @@
       (record
        'tuple
        (list
-        (list*
+        (for/list
-         (for/list
+         ((item (in-list $patterns)))
-          ((item (in-list $patterns)))
+         (NamedPattern->preserves item)))))
-          (NamedPattern->preserves item))))))
      ((CompoundPattern-tuple* $fixed $variable)
       (record
        'tuple*
        (list
-        (list*
+        (for/list ((item (in-list $fixed))) (NamedPattern->preserves item))
-         (for/list ((item (in-list $fixed))) (NamedPattern->preserves item)))
         (NamedSimplePattern->preserves $variable))))
-     ((CompoundPattern-setof $pattern)
-      (record 'setof (list (SimplePattern->preserves $pattern))))
-     ((CompoundPattern-dictof $key $value)
-      (record
-       'dictof
-       (list
-        (SimplePattern->preserves $key)
-        (SimplePattern->preserves $value))))
      ((CompoundPattern-dict $entries)
       (record 'dict (list (DictionaryEntries->preserves $entries))))))
   (define (Modules->preserves input)

implementations/racket/preserves/preserves-schema/parser.rkt

@@ -60,25 +60,16 @@
                         [(AtomKind-Symbol) 'symbol?])))]
     [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
     [(SimplePattern-lit v) (maybe-dest dest-pat-stx (literal->pattern v))]
-    [(SimplePattern-Ref (Ref '() name))
+    [(SimplePattern-seqof variable-pat)
-     `(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))]
+     `(list ,(pattern->match-pattern variable-pat dest-pat-stx) ...)]
-    [(SimplePattern-Ref (Ref module-path name))
+    [(SimplePattern-setof pat)
-     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
-    [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
-     `(parse-sequence list?
-                      values
-                      ,(pattern->match-pattern variable-pat 'item)
-                      item
-                      values
-                      ,dest-pat-stx)]
-    [(CompoundPattern-setof pat)
      `(parse-sequence set?
                       set->list
                       ,(pattern->match-pattern pat 'item)
                       item
                       list->set
                       ,dest-pat-stx)]
-    [(CompoundPattern-dictof key-pat value-pat)
+    [(SimplePattern-dictof key-pat value-pat)
      `(parse-sequence dict?
                       dict->list
                       (cons ,(pattern->match-pattern key-pat 'key)
@@ -86,17 +77,22 @@
                       (cons key value)
                       make-immutable-hash
                       ,dest-pat-stx)]
+    [(SimplePattern-Ref (Ref '() name))
+     `(app ,(format-symbol "parse-~a" name) ,(maybe-dest dest-pat-stx `(not (== eof))))]
+    [(SimplePattern-Ref (Ref module-path name))
+     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
     [(CompoundPattern-rec label-pat fields-pat)
      (maybe-dest dest-pat-stx `(record ,(pattern->match-pattern label-pat '_)
                                        ,(pattern->match-pattern fields-pat '_)))]
     [(CompoundPattern-tuple named-pats)
      (maybe-dest dest-pat-stx
                  `(list ,@(map (lambda (p) (pattern->match-pattern p '_)) named-pats)))]
-    [(CompoundPattern-tuple* fixed-named-pats
+    [(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
-                             (NamedSimplePattern-named (NamedSimplePattern_ vname vpat)))
      (maybe-dest dest-pat-stx
-                 `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
+                 (if (null? fixed-named-pats)
-                         (list ,(pattern->match-pattern vpat (escape vname)) ...)))]
+                     (pattern->match-pattern variable-named-pat '_)
+                     `(list* ,@(map (lambda (p) (pattern->match-pattern p '_)) fixed-named-pats)
+                             ,(pattern->match-pattern variable-named-pat '_))))]
     [(CompoundPattern-dict (hash-table (keys pats) ...))
      (maybe-dest dest-pat-stx
                  `(hash-table ,@(for/list [(key (in-list keys))

implementations/racket/preserves/preserves-schema/type.rkt

@@ -61,15 +61,15 @@
      (match (pattern-ty p)
        [(ty-unit) acc]
        [ty (cons (list n ty) acc)])]
+    [(? SimplePattern?) acc]
     [(CompoundPattern-rec label-named-pat fields-named-pat)
      (gather-fields label-named-pat (gather-fields fields-named-pat acc))]
-    [(CompoundPattern-tuple named-pats) (gather-fields* named-pats acc)]
+    [(CompoundPattern-tuple named-pats)
+     (gather-fields* named-pats acc)]
     [(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
      (gather-fields* fixed-named-pats (gather-fields variable-named-pat acc))]
     [(CompoundPattern-dict (hash-table (keys pats) ...))
-     (gather-fields* (map add-name-if-absent keys pats) acc)]
+     (gather-fields* (map add-name-if-absent keys pats) acc)]))
-    [(? SimplePattern?) acc]
-    [(? CompoundPattern?) acc]))
 
 (define (pattern-ty p)
   (match (unwrap p)
@@ -77,12 +77,10 @@
     [(SimplePattern-atom _atomKind) (ty-value)]
     [(SimplePattern-embedded) (ty-value)]
     [(SimplePattern-lit _value) (ty-unit)]
+    [(SimplePattern-seqof pat) (ty-array (pattern-ty pat))]
+    [(SimplePattern-setof pat) (ty-set (pattern-ty pat))]
+    [(SimplePattern-dictof kp vp) (ty-dictionary (pattern-ty kp) (pattern-ty vp))]
     [(SimplePattern-Ref _r) (ty-value)]
-    [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
-     (ty-array (pattern-ty variable-pat))]
-    [(CompoundPattern-setof pat) (ty-set (pattern-ty pat))]
-    [(CompoundPattern-dictof key-pat value-pat)
-     (ty-dictionary (pattern-ty key-pat) (pattern-ty value-pat))]
     [(? CompoundPattern?) (product-ty (list p))]))
 
 (define (add-name-if-absent k p)

implementations/racket/preserves/preserves-schema/unparser.rkt

@@ -58,25 +58,24 @@
     [(SimplePattern-atom _) src-stx]
     [(SimplePattern-embedded) (error 'pattern-parser "Embedded not yet implemented")]
     [(SimplePattern-lit v) `',v]
-    [(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
+    [(SimplePattern-seqof variable-pat)
-    [(SimplePattern-Ref (Ref module-path name))
-     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
-    [(CompoundPattern-tuple* '() (NamedSimplePattern-anonymous variable-pat))
      `(for/list [(item (in-list ,src-stx))] ,(pattern->unparser variable-pat 'item))]
-    [(CompoundPattern-setof pat)
+    [(SimplePattern-setof pat)
      `(for/set [(item (in-set ,src-stx))] ,(pattern->unparser pat 'item))]
-    [(CompoundPattern-dictof key-pat value-pat)
+    [(SimplePattern-dictof key-pat value-pat)
      `(for/hash [((key value) (in-dict ,src-stx))]
         (values ,(pattern->unparser key-pat 'key)
                 ,(pattern->unparser value-pat 'value)))]
+    [(SimplePattern-Ref (Ref '() name)) `(,(format-symbol "~a->preserves" name) ,src-stx)]
+    [(SimplePattern-Ref (Ref module-path name))
+     (error 'pattern-parser "Ref with non-empty module path not yet implemented")]
     [(CompoundPattern-rec label-pat fields-pat)
      `(record ,(pattern->unparser label-pat src-stx) ,(pattern->unparser fields-pat src-stx))]
     [(CompoundPattern-tuple named-pats)
      `(list ,@(for/list [(p (in-list named-pats))] (pattern->unparser p src-stx)))]
-    [(CompoundPattern-tuple* fixed-named-pats
+    [(CompoundPattern-tuple* fixed-named-pats variable-named-pat)
-                             (NamedSimplePattern-named (NamedSimplePattern_ vname vpat)))
      `(list* ,@(for/list [(p (in-list fixed-named-pats))] (pattern->unparser p src-stx))
-             (for/list [(item (in-list ,(escape vname)))] ,(pattern->unparser vpat 'item)))]
+             ,(pattern->unparser variable-named-pat src-stx))]
     [(CompoundPattern-dict (hash-table (keys pats) ...))
      `(hash ,@(append-map (lambda (key pat)
                             (list `',key (pattern->unparser (add-name-if-absent key pat) src-stx)))