Use the new #%deforestable syntax

drym-org · Aug 3, 2024 · 958fe14 · 958fe14
1 parent fe81b7f
commit 958fe14
Show file tree

Hide file tree

Showing 4 changed files with 44 additions and 42 deletions.
diff --git a/qi-lib/flow/core/compiler/1000-qi0.rkt b/qi-lib/flow/core/compiler/1000-qi0.rkt
@@ -395,25 +395,25 @@ the DSL.
 
   (define (deforestable-parser stx)
     (syntax-parse stx
-      [((~datum #%deforestable) ((~datum filter) proc:clause))
+      [((~datum #%deforestable) (~datum filter) (proc:clause))
        #'(lambda (v)
            (filter (qi0->racket proc) v))]
-      [((~datum #%deforestable) ((~datum filter-map) proc:clause))
+      [((~datum #%deforestable) (~datum filter-map) (proc:clause))
        #'(lambda (v)
            (filter-map (qi0->racket proc) v))]
-      [((~datum #%deforestable) ((~datum map) proc:clause))
+      [((~datum #%deforestable) (~datum map) (proc:clause))
        #'(lambda (v)
            (map (qi0->racket proc) v))]
-      [((~datum #%deforestable) ((~datum foldl) proc:clause init:expr))
+      [((~datum #%deforestable) (~datum foldl) (proc:clause) (init:expr))
        #'(lambda (v)
            (foldl (qi0->racket proc) init v))]
-      [((~datum #%deforestable) ((~datum foldr) proc:clause init:expr))
+      [((~datum #%deforestable) (~datum foldr) (proc:clause) (init:expr))
        #'(lambda (v)
            (foldr (qi0->racket proc) init v))]
-      [((~datum #%deforestable) ((~datum range) arg:expr ...))
+      [((~datum #%deforestable) (~datum range) () (arg:expr ...))
        #'(lambda ()
            (range arg ...))]
-      [((~datum #%deforestable) ((~datum take) n:expr))
+      [((~datum #%deforestable) (~datum take) () (n:expr))
        #'(lambda (v)
            (take v n))]
       [((~datum #%deforestable) (~datum car))
@@ -424,7 +424,7 @@ the DSL.
        #'caddr]
       [((~datum #%deforestable) (~datum cadddr))
        #'cadddr]
-      [((~datum #%deforestable) ((~datum list-ref) n:expr))
+      [((~datum #%deforestable) (~datum list-ref) () (n:expr))
        #'(lambda (v)
            (list-ref v n))]
       [((~datum #%deforestable) (~datum length))

diff --git a/qi-lib/flow/core/compiler/deforest/syntax.rkt b/qi-lib/flow/core/compiler/deforest/syntax.rkt
@@ -51,7 +51,7 @@
   #:attributes (blanket? fine? arg pre-arg post-arg)
   #:literal-sets (fs-literals)
   #:datum-literals (range)
-  (pattern (#%deforestable (range the-arg ...))
+  (pattern (#%deforestable range () (the-arg ...))
     #:attr arg #'(the-arg ...)
     #:attr pre-arg #f
     #:attr post-arg #f
@@ -80,25 +80,25 @@
   #:attributes (f)
   #:literal-sets (fs-literals)
   #:datum-literals (filter)
-  (pattern (#%deforestable (filter (#%host-expression f)))))
+  (pattern (#%deforestable filter (f))))
 
 (define-syntax-class fst-map
   #:attributes (f)
   #:literal-sets (fs-literals)
   #:datum-literals (map)
-  (pattern (#%deforestable (map (#%host-expression f)))))
+  (pattern (#%deforestable map (f))))
 
 (define-syntax-class fst-filter-map
   #:attributes (f)
   #:literal-sets (fs-literals)
   #:datum-literals (filter-map)
-  (pattern (#%deforestable (filter-map (#%host-expression f)))))
+  (pattern (#%deforestable filter-map (f))))
 
 (define-syntax-class fst-take
   #:attributes (n)
   #:literal-sets (fs-literals)
   #:datum-literals (take)
-  (pattern (#%deforestable (take (#%host-expression n)))))
+  (pattern (#%deforestable take () ((#%host-expression n)))))
 
 (define-syntax-class fst-syntax0
   (pattern (~or _:fst-filter
@@ -123,18 +123,18 @@
   #:literal-sets (fs-literals)
   #:datum-literals (foldr)
   (pattern (#%deforestable
-            (foldr
-             (#%host-expression op)
-             (#%host-expression init)))))
+            foldr
+            (op)
+            ((#%host-expression init)))))
 
 (define-syntax-class fsc-foldl
   #:attributes (op init)
   #:literal-sets (fs-literals)
   #:datum-literals (foldl)
   (pattern (#%deforestable
-            (foldl
-             (#%host-expression op)
-             (#%host-expression init)))))
+            foldl
+            (op)
+            ((#%host-expression init)))))
 
 (define-syntax-class cad*r-datum
   #:attributes (countdown)
@@ -147,12 +147,14 @@
   #:attributes (pos name)
   #:literal-sets (fs-literals)
   #:datum-literals (list-ref)
-  (pattern (#%deforestable (list-ref idx))
-           #:attr pos #'idx
-           #:attr name #'list-ref)
+  ;; TODO: need #%host-expression wrapping idx?
+  (pattern (#%deforestable list-ref () (idx))
+    #:attr pos #'idx
+    #:attr name #'list-ref)
+  ;; TODO: bring wrapping #%deforestable out here?
   (pattern cad*r:cad*r-datum
-           #:attr pos #'cad*r.countdown
-           #:attr name #'cad*r))
+    #:attr pos #'cad*r.countdown
+    #:attr name #'cad*r))
 
 (define-syntax-class fsc-length
   #:literal-sets (fs-literals)

diff --git a/qi-lib/list.rkt b/qi-lib/list.rkt
@@ -12,30 +12,30 @@
          "macro.rkt")
 
 (define-qi-syntax-rule (map f:expr)
-  (#%deforestable (map f)))
+  (#%deforestable map (f)))
 
 (define-qi-syntax-rule (filter f:expr)
-  (#%deforestable (filter f)))
+  (#%deforestable filter (f)))
 
 (define-qi-syntax-rule (filter-map f:expr)
-  (#%deforestable (filter-map f)))
+  (#%deforestable filter-map (f)))
 
 (define-qi-syntax-rule (foldl f:expr init:expr)
-  (#%deforestable (foldl f init)))
+  (#%deforestable foldl (f) (init)))
 
 (define-qi-syntax-rule (foldr f:expr init:expr)
-  (#%deforestable (foldr f init)))
+  (#%deforestable foldr (f) (init)))
 
 (define-qi-syntax-parser range
-  [(_ low:expr high:expr step:expr) #'(#%deforestable (range low high step))]
-  [(_ low:expr high:expr) #'(range low high 1)]
-  [(_ high:expr) #'(range 0 high 1)]
+  [(_ low:expr high:expr step:expr) #'(#%deforestable range () (low high step))]
+  [(_ low:expr high:expr) #'(#%deforestable range () (low high 1))]
+  [(_ high:expr) #'(#%deforestable range () (0 high 1))]
   [_:id (report-syntax-error this-syntax
           "(range arg ...)"
           "range expects at least one argument")])
 
 (define-qi-syntax-rule (take n:expr)
-  (#%deforestable (take n)))
+  (#%deforestable take () (n)))
 
 (define-qi-syntax-parser car
   [_:id #'(#%deforestable car)])
@@ -50,7 +50,7 @@
   [_:id #'(#%deforestable cadddr)])
 
 (define-qi-syntax-rule (list-ref n:expr)
-  (#%deforestable (list-ref n)))
+  (#%deforestable list-ref () (n)))
 
 (define-qi-syntax-parser length
   [_:id #'(#%deforestable length)])

diff --git a/qi-test/tests/flow.rkt b/qi-test/tests/flow.rkt
@@ -287,14 +287,14 @@
                    "normal racket expressions"))
     (test-suite
      "#%deforestable"
-     (check-equal? ((☯ (#%deforestable (filter odd?))) (list 1 2 3)) (list 1 3))
-     (check-equal? ((☯ (#%deforestable (map sqr))) (list 1 2 3)) (list 1 4 9))
-     (check-equal? ((☯ (#%deforestable (foldl + 0))) (list 1 2 3)) 6)
-     (check-equal? ((☯ (#%deforestable (foldr + 0))) (list 1 2 3)) 6)
-     (check-equal? ((☯ (#%deforestable (range 3)))) (list 0 1 2))
-     (check-equal? ((☯ (#%deforestable (range 0 3)))) (list 0 1 2))
-     (check-equal? ((☯ (#%deforestable (range 0 5 2)))) (list 0 2 4))
-     (check-equal? ((☯ (#%deforestable (take 2))) (list 1 2 3)) (list 1 2)))
+     (check-equal? ((☯ (#%deforestable filter (odd?))) (list 1 2 3)) (list 1 3))
+     (check-equal? ((☯ (#%deforestable map (sqr))) (list 1 2 3)) (list 1 4 9))
+     (check-equal? ((☯ (#%deforestable foldl (+) (0))) (list 1 2 3)) 6)
+     (check-equal? ((☯ (#%deforestable foldr (+) (0))) (list 1 2 3)) 6)
+     (check-equal? ((☯ (#%deforestable range () (3)))) (list 0 1 2))
+     (check-equal? ((☯ (#%deforestable range () (0 3)))) (list 0 1 2))
+     (check-equal? ((☯ (#%deforestable range () (0 5 2)))) (list 0 2 4))
+     (check-equal? ((☯ (#%deforestable take () (2))) (list 1 2 3)) (list 1 2)))
     (test-suite
      "elementary boolean gates"
      (test-suite