Merge branch 'deforest-all-the-things' into lambda-core-form

Makefile

@@ -125,6 +125,9 @@ test:
 test-flow:
 	racket -y $(PACKAGE-NAME)-test/tests/flow.rkt
 
+test-list:
+	racket -y $(PACKAGE-NAME)-test/tests/list.rkt
+
 test-on:
 	racket -y $(PACKAGE-NAME)-test/tests/on.rkt
 

qi-lib/flow/aux-syntax.rkt

@@ -3,10 +3,12 @@
 (provide literal
          subject
          clause
-         starts-with)
+         starts-with
+         (struct-out deforestable-info))
 
 (require syntax/parse
-         racket/string)
+         racket/string
+         (for-syntax racket/base))
 
 (define-syntax-class literal
   (pattern
@@ -56,3 +58,11 @@
             (symbol->string
              (syntax-e #'i))
             pfx)))
+
+;; A datatype used at compile time to convey user-defined data through
+;; the various stages of compilation for the purposes of extending Qi
+;; deforestation to custom list operations. It is currently used to
+;; convey a Racket runtime for macros in qi/list through to the code
+;; generation stage of Qi compilation (and could be used by any similar
+;; "deep" macros written by users).
+(struct deforestable-info [codegen])

qi-lib/flow/core/compiler/1000-qi0.rkt

@@ -6,19 +6,17 @@
          racket/function
          racket/list
          (for-syntax racket/base
+                     racket/match
                      syntax/parse
                      "../syntax.rkt"
                      "../../aux-syntax.rkt"
                      (only-in racket/list make-list)
                      ))
 
 (begin-for-syntax
-
   (define-and-register-pass 1000 (qi0-wrapper stx)
     (syntax-parse stx
-      (ex #'(qi0->racket ex))))
-
-  )
+      (ex #'(qi0->racket ex)))))
 
 (define-syntax (qi0->racket stx)
   ;; this is a macro so it receives the entire expression
@@ -394,44 +392,18 @@ the DSL.
                (qi0->racket (~> (-< (~> (gen args) △) _)
                                 onex))))]))
 
-  (define (deforestable-parser stx)
-    (syntax-parse stx
-      [((~datum #%deforestable) (~datum filter) (proc:clause))
-       #'(lambda (v)
-           (filter (qi0->racket proc) v))]
-      [((~datum #%deforestable) (~datum filter-map) (proc:clause))
-       #'(lambda (v)
-           (filter-map (qi0->racket proc) v))]
-      [((~datum #%deforestable) (~datum map) (proc:clause))
-       #'(lambda (v)
-           (map (qi0->racket proc) v))]
-      [((~datum #%deforestable) (~datum foldl) (proc:clause) (init:expr))
-       #'(lambda (v)
-           (foldl (qi0->racket proc) init v))]
-      [((~datum #%deforestable) (~datum foldr) (proc:clause) (init:expr))
-       #'(lambda (v)
-           (foldr (qi0->racket proc) init v))]
-      [((~datum #%deforestable) (~datum range) () (arg:expr ...))
-       #'(lambda ()
-           (range arg ...))]
-      [((~datum #%deforestable) (~datum take) () (n:expr))
-       #'(lambda (v)
-           (take v n))]
-      [((~datum #%deforestable) (~datum car))
-       #'car]
-      [((~datum #%deforestable) (~datum cadr))
-       #'cadr]
-      [((~datum #%deforestable) (~datum caddr))
-       #'caddr]
-      [((~datum #%deforestable) (~datum cadddr))
-       #'cadddr]
-      [((~datum #%deforestable) (~datum list-ref) () (n:expr))
-       #'(lambda (v)
-           (list-ref v n))]
-      [((~datum #%deforestable) (~datum length))
-       #'length]
-      [((~datum #%deforestable) (~or* (~datum empty?) (~datum null?)))
-       #'empty?]))
+  (define (deforestable-clause-parser c)
+    (syntax-parse c
+      [((~datum f) e) #'(qi0->racket e)]
+      [((~datum e) e) #'e]))
+
+  (define (deforestable-parser e)
+    (syntax-parse e
+      #:datum-literals (#%deforestable)
+      [(#%deforestable _name info c ...)
+       (let ([es^ (map deforestable-clause-parser (attribute c))])
+         (match-let ([(deforestable-info codegen) (syntax-local-value #'info)])
+           (apply codegen es^)))]))
 
   (define (blanket-template-form-parser stx)
     (syntax-parse stx

qi-lib/flow/core/compiler/deforest/syntax.rkt

@@ -34,7 +34,7 @@
 
 ;; Literals set used for matching Fusable Stream Literals
 (define-literal-set fs-literals
-  #:datum-literals (esc #%host-expression #%fine-template #%blanket-template _ __)
+  #:datum-literals (esc #%host-expression #%fine-template #%blanket-template #%deforestable _ __)
   ())
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -50,7 +50,7 @@
   #:attributes (blanket? fine? arg pre-arg post-arg)
   #:literal-sets (fs-literals)
   #:datum-literals (range)
-  (pattern (#%deforestable range () (the-arg ...))
+  (pattern (#%deforestable range _info ((~datum e) the-arg) ...)
     #:attr arg #'(the-arg ...)
     #:attr pre-arg #f
     #:attr post-arg #f
@@ -79,27 +79,28 @@
   #:attributes (f)
   #:literal-sets (fs-literals)
   #:datum-literals (filter)
-  (pattern (#%deforestable filter (f-uncompiled))
+  (pattern (#%deforestable filter _info ((~datum f) f-uncompiled))
     #:attr f (run-passes #'f-uncompiled)))
+
 (define-syntax-class fst-map
   #:attributes (f)
   #:literal-sets (fs-literals)
   #:datum-literals (map)
-  (pattern (#%deforestable map (f-uncompiled))
+  (pattern (#%deforestable map _info ((~datum f) f-uncompiled))
     #:attr f (run-passes #'f-uncompiled)))
 
 (define-syntax-class fst-filter-map
   #:attributes (f)
   #:literal-sets (fs-literals)
   #:datum-literals (filter-map)
-  (pattern (#%deforestable filter-map (f-uncompiled))
+  (pattern (#%deforestable filter-map _info ((~datum f) f-uncompiled))
     #:attr f (run-passes #'f-uncompiled)))
 
 (define-syntax-class fst-take
   #:attributes (n)
   #:literal-sets (fs-literals)
   #:datum-literals (take)
-  (pattern (#%deforestable take () ((#%host-expression n)))))
+  (pattern (#%deforestable take _info ((~datum e) n))))
 
 (define-syntax-class fst-syntax0
   (pattern (~or _:fst-filter
@@ -125,8 +126,9 @@
   #:datum-literals (foldr)
   (pattern (#%deforestable
             foldr
-            (op-uncompiled)
-            ((#%host-expression init)))
+            _info
+            ((~datum f) op-uncompiled)
+            ((~datum e) init))
     #:attr op (run-passes #'op-uncompiled)))
 
 (define-syntax-class fsc-foldl
@@ -135,23 +137,25 @@
   #:datum-literals (foldl)
   (pattern (#%deforestable
             foldl
-            (op-uncompiled)
-            ((#%host-expression init)))
+            _info
+            ((~datum f) op-uncompiled)
+            ((~datum e) init))
     #:attr op (run-passes #'op-uncompiled)))
 
 (define-syntax-class cad*r-datum
   #:attributes (countdown)
-  (pattern (#%deforestable (~datum car)) #:attr countdown #'0)
-  (pattern (#%deforestable (~datum cadr)) #:attr countdown #'1)
-  (pattern (#%deforestable (~datum caddr)) #:attr countdown #'2)
-  (pattern (#%deforestable (~datum cadddr)) #:attr countdown #'3))
+  #:datum-literals (#%deforestable car cadr caddr cadddr)
+  (pattern (#%deforestable car _info) #:attr countdown #'0)
+  (pattern (#%deforestable cadr _info) #:attr countdown #'1)
+  (pattern (#%deforestable caddr _info) #:attr countdown #'2)
+  (pattern (#%deforestable cadddr _info) #:attr countdown #'3))
 
 (define-syntax-class fsc-list-ref
   #:attributes (pos name)
   #:literal-sets (fs-literals)
   #:datum-literals (list-ref)
   ;; TODO: need #%host-expression wrapping idx?
-  (pattern (#%deforestable list-ref () (idx))
+  (pattern (#%deforestable list-ref _info ((~datum e) idx))
     #:attr pos #'idx
     #:attr name #'list-ref)
   ;; TODO: bring wrapping #%deforestable out here?
@@ -162,13 +166,12 @@
 (define-syntax-class fsc-length
   #:literal-sets (fs-literals)
   #:datum-literals (length)
-  (pattern (#%deforestable length)))
+  (pattern (#%deforestable length _info)))
 
 (define-syntax-class fsc-empty?
   #:literal-sets (fs-literals)
-  #:datum-literals (null? empty?)
-  (pattern (#%deforestable (~or empty?
-                                null?))))
+  #:datum-literals (empty?) ; note: null? expands to empty?
+  (pattern (#%deforestable empty? _info)))
 
 (define-syntax-class fsc-default
   #:datum-literals (cstream->list)

qi-lib/flow/extended/expander.rkt

@@ -188,9 +188,7 @@ core language's use of #%app, etc.).
         #'(lambda e ...))
 
     ;; core form to express deforestable operations
-    (#%deforestable name:id (f:closed-floe ...) (arg:racket-expr ...))
-    (#%deforestable name:id (f:closed-floe ...+))
-    (#%deforestable name:id)
+    (#%deforestable name:id info:id e:deforestable-clause ...)
 
     ;; backwards compat macro extensibility via Racket macros
     (~> ((~var ext-form (starts-with "qi:")) expr ...)
@@ -246,6 +244,10 @@ core language's use of #%app, etc.).
         #:with spaced-f (introduce-qi-syntax #'f)
         #'(esc spaced-f)))
 
+  (nonterminal deforestable-clause
+    ((~datum f) e:closed-floe)
+    ((~datum e) g:racket-expr))
+
   (nonterminal arg-stx
     (~datum _)
     (~datum __)

qi-lib/list.rkt

@@ -1,64 +1,87 @@
 #lang racket/base
 
 (provide (for-space qi
-                    (all-defined-out)))
+                    (except-out (all-defined-out)
+                                range2
+                                range)
+                    (rename-out [range2 range])))
 
 (require (for-syntax racket/base
                      "private/util.rkt")
          syntax/parse/define
          "flow/extended/expander.rkt"
          (only-in "flow/space.rkt"
                   define-qi-alias)
-         "macro.rkt")
-
-(define-qi-syntax-rule (map f:expr)
-  (#%deforestable map (f)))
-
-(define-qi-syntax-rule (filter f:expr)
-  (#%deforestable filter (f)))
-
-(define-qi-syntax-rule (filter-map f:expr)
-  (#%deforestable filter-map (f)))
-
-(define-qi-syntax-rule (foldl f:expr init:expr)
-  (#%deforestable foldl (f) (init)))
-
-(define-qi-syntax-rule (foldr f:expr init:expr)
-  (#%deforestable foldr (f) (init)))
-
-(define-qi-syntax-parser range
-  [(_ 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))]
+         "macro.rkt"
+         (prefix-in r: racket/base)
+         (prefix-in r: racket/list))
+
+(define-deforestable (map [f f])
+  #'(lambda (vs)  ; single list arg
+      (r:map f vs)))
+
+(define-deforestable (filter [f f])
+  #'(λ (vs)
+      (r:filter f vs)))
+
+(define-deforestable (filter-map [f f])
+  #'(λ (vs)
+      (r:filter-map f vs)))
+
+(define-deforestable (foldl [f f] [e init])
+  #'(λ (vs)
+      (r:foldl f init vs)))
+
+(define-deforestable (foldr [f f] [e init])
+  #'(λ (vs)
+      (r:foldr f init vs)))
+
+(define-deforestable (range [e low] [e high] [e step])
+  #'(λ ()
+      (r:range low high step)))
+
+;; We'd like to indicate multiple surface variants for `range` that
+;; expand to a canonical form, and provide a single codegen just for the
+;; canonical form.
+;; Since `define-deforestable` doesn't support indicating multiple cases
+;; yet, we use the ordinary macro machinery to expand surface variants of
+;; `range` to a canonical form that is defined using
+;; `define-deforestable`.
+(define-qi-syntax-parser range2
+  [(_ low:expr high:expr step:expr) #'(range low high step)]
+  [(_ low:expr high:expr) #'(range low high 1)]
+  [(_ high:expr) #'(range 0 high 1)]
   ;; not strictly necessary but this provides a better error
   ;; message than simply "range: bad syntax" that's warranted
   ;; to differentiate from racket/list's `range`
   [_:id (report-syntax-error this-syntax
           "(range arg ...)"
           "range expects at least one argument")])
 
-(define-qi-syntax-rule (take n:expr)
-  (#%deforestable take () (n)))
+(define-deforestable (take [e n])
+  #'(λ (vs)
+      (r:take vs n)))
 
-(define-qi-syntax-parser car
-  [_:id #'(#%deforestable car)])
+(define-deforestable car
+  #'r:car)
 
-(define-qi-syntax-parser cadr
-  [_:id #'(#%deforestable cadr)])
+(define-deforestable cadr
+  #'r:cadr)
 
-(define-qi-syntax-parser caddr
-  [_:id #'(#%deforestable caddr)])
+(define-deforestable caddr
+  #'r:caddr)
 
-(define-qi-syntax-parser cadddr
-  [_:id #'(#%deforestable cadddr)])
+(define-deforestable cadddr
+  #'r:cadddr)
 
-(define-qi-syntax-rule (list-ref n:expr)
-  (#%deforestable list-ref () (n)))
+(define-deforestable (list-ref [e n])
+  #'(λ (vs)
+      (r:list-ref vs n)))
 
-(define-qi-syntax-parser length
-  [_:id #'(#%deforestable length)])
+(define-deforestable length
+  #'r:length)
 
-(define-qi-syntax-parser empty?
-  [_:id #'(#%deforestable empty?)])
+(define-deforestable empty?
+  #'r:empty?)
 
 (define-qi-alias null? empty?)