WIP on map:

graph/graph/__DEBUG_graph__.rkt

@@ -34,6 +34,7 @@
 ((λget owner name) (get g streets cadr houses car))
 (get g streets … houses … owner name)
 ((λget streets … houses … owner name) g)
+(let ([f (λget streets … houses … owner name)]) f)
 ;(map: (λget houses … owner name) (get g streets))
 
 

graph/graph/graph4.lp2.rkt

@@ -89,12 +89,12 @@ otherwise throw an error:
              [(_ v:expr c…r:c…r other-fields …)
               #`(get v c…r.reverse-expanded … other-fields …)]
              [(_ v:expr (~literal …) other-fields …)
-              #;#'((map:: T
-                          (result-get T other-fields …)
-                          (has-get T other-fields …)
-                          (λget other-fields …))
-                   v)
-              #'((λ #:∀ (T) ([l : (Listof (has-get T other-fields …))])
+              #'((curry-map T
+                            (result-get T other-fields …)
+                            (has-get T other-fields …)
+                            (λget other-fields …))
+                 v)
+              #;#'((λ #:∀ (T) ([l : (Listof (has-get T other-fields …))])
                    : (Listof (result-get T other-fields …))
                    ((inst map
                           (result-get T other-fields …)
@@ -207,7 +207,8 @@ The type for the function generated by @tc[λget] mirrors the cases from
                   "variant.lp2.rkt"
                   "graph3.lp2.rkt"
                   "../type-expander/multi-id.lp2.rkt"
-                  "../type-expander/type-expander.lp2.rkt")
+                  "../type-expander/type-expander.lp2.rkt"
+                  "map1.rkt")
          (provide get
                   λget
                   has-get

graph/graph/map.rkt

@@ -1,29 +1,197 @@
-#lang typed/racket
+#lang debug typed/racket
 
-(require (for-syntax syntax/parse)
+(require (for-syntax racket/syntax
+                     syntax/stx
+                     syntax/parse
+                     syntax/parse/experimental/template
+                     "../lib/low-untyped.rkt")
          "../lib/low.rkt"
-         "map1.rkt")
+         "map1.rkt"
+         "graph4.lp2.rkt"
+         "../type-expander/type-expander.lp2.rkt")
 
 (provide map:)
 
 (begin-for-syntax
   (define-syntax-class lam
-    (pattern (~or (~literal λ) (~literal lambda)))))
+    (pattern (~or (~literal λ) (~literal lambda))))
+  (define-syntax-class mapp
+    (pattern (~or (~literal map) (~literal map:)))))
 
+(define-for-syntax (remove-identities stx)
+  (syntax-parse stx
+    [() #'()]
+    [((~or (~lit identity) (~lit values) (~lit compose)) . rest)
+     (remove-identities #'rest)]
+    [([(~literal compose) . fs] . rest)
+     (define/with-syntax cleaned-fs (remove-identities #'fs))
+     (syntax-parse #'cleaned-fs
+       [() (remove-identities #'rest)]
+       [(one-f) #`(one-f . #,(remove-identities #'rest))]
+       [some-fs #`((compose . some-fs) . #,(remove-identities #'rest))])]
+    [(f . rest)
+     #`(f . #,(remove-identities #'rest))]))
+
+;; TODO: check that we don't bork the literals identity, values and compose
+;; inside macros or function calls, or alter them in any other way, e.g.
+;;     (map: (compose identity (λ (values) (+ values 1)) identity) '(1 2 3))
+;; or
+;;     (define (calltwice f) (λ (x) (f (f x))))
+;;     (map: (compose (calltwice identity)) '(1 2 3))
+;; Although a poor variable name choice, the two occurences of "values" in the
+;; first example shouldn't be altered, and the λ itself shouldn't be touched.
+;; In the second one, everything inside the calltwice function call should be
+;; left intact.
+(define-for-syntax (remove-identities1 stx)
+  (syntax-parse (remove-identities #`(#,stx))
+    [() #'identity]
+    [(f) #'f]))
+
+(begin-for-syntax
+  (define-syntax-class map-info
+    (pattern (_ #:in in-type
+                #:out out-type
+                #:∀ (∀-type …)
+                #:arg-funs ([arg-fun
+                             param-fun
+                             (~optional (~and auto-in #:auto-in))
+                             fun-in fun-out] …)
+                #:funs [fun …]))))
+
+(define-for-syntax (:map* stx* stx-&l… stx-out)
+  (if (stx-null? stx*)
+      '()
+      (syntax-parse (:map (stx-car stx*) stx-&l… stx-out)
+        [info:map-info
+         (let ([r (:map* (stx-cdr stx*) stx-&l… #'info.in-type)]
+               [auto (attribute info.auto-in)])
+           (if (and (not (null? auto)) (car auto) (not (null? r)))
+               (syntax-parse (car r)
+                 [r-info:map-info
+                  (let ([intact #'([info.arg-fun
+                                    info.param-fun
+                                    info.fun-in ;;;
+                                    info.fun-out] …)]
+                        [replaced #'([info.arg-fun
+                                      info.param-fun
+                                      r-info.out-type ;;info.fun-in ;;;
+                                      info.fun-out] …)])
+                    (cons #`(info #:in info.in-type
+                                  #:out info.out-type
+                                  #:∀ (info.∀-type …)
+                                  #:arg-funs (#,(stx-car replaced)
+                                              #,@(stx-cdr intact))
+                                  #:funs [info.fun …])
+                          r))])
+               (cons #'info r)))])))
+
+(define-for-syntax (:map stx stx-&l… stx-out)
+  (define/with-syntax (&l …) stx-&l…)
+  (define/with-syntax out stx-out)
+  (syntax-parse (remove-identities1 stx)
+    [(~literal car)
+     #'(info #:in (Pairof out Any) #:out out #:∀ ()
+             #:arg-funs () #:funs (car))]
+    [(~literal cdr)
+     #'(info #:in (Pairof Any out) #:out out #:∀ ()
+             #:arg-funs () #:funs (cdr))]
+    ;; TODO: should remove `identity` completely, doing (map identity l) is
+    ;; useless appart for constraining the type, but it's an ugly way to do so.
+    [(~literal identity)
+     #'(info #:in out #:out out #:∀ ()
+             #:arg-funs () #:funs (identity))]
+    [((~literal compose) f …)
+     (syntax-parse (:map* #'(f …) #'(&l …) #'out)
+       [(~and (_ … first:map-info) (last:map-info . _) (:map-info …))
+        #'(info #:in first.in-type
+                #:out last.out-type
+                #:∀ (∀-type … …)
+                #:arg-funs ([arg-fun param-fun fun-in fun-out] … …)
+                #:funs (fun … …))])]
+    [((~literal curry) :mapp f)
+     (syntax-parse (internal-map: #'f #'(&l …) #'out)
+       [(i:map-info . code)
+        #'(info #:in (Listof i.in-type)
+                #:out (Listof out)
+                #:∀ [i.∀-type …]; i.out-type
+                #:arg-funs [(i.arg-fun i.param-fun i.fun-in i.fun-out) …]
+                #:funs [(code i.fun … _)])])]
+    [(~literal length)
+     (define-temp-ids "&~a" f)
+     (define-temp-ids "~a/in" f)
+     #'(info #:in f/in #:out out #:∀ (f/in)
+             #:arg-funs ([(λ ([l : (Listof Any)]) (length l))
+                          &f
+                          #:auto-in f/in
+                          out])
+             #:funs (&f))]
+    [f
+     (define-temp-ids "&~a" f)
+     (define-temp-ids "~a/in" f)
+     #'(info #:in f/in #:out out #:∀ (f/in)
+             #:arg-funs ([f &f #:auto-in f/in out]) #:funs (&f))]))
+
+(define-syntax apply-compose
+  (syntax-rules ()
+    [(_ [] [a …]) (values a …)]
+    [(_ [f0 . f] [a …]) (apply-compose f [(f0 a …)])]))
+
+(define-for-syntax (internal-map: stx-f stx-&l… stx-out)
+  (define/with-syntax f stx-f)
+  (define/with-syntax (&l …) stx-&l…)
+  (define/with-syntax out stx-out)
+  (syntax-parse (:map #'f #'(&l …) #'out)
+    [(~and i :map-info)
+     (cons #'i
+           #'(let ()
+               (: map1 (∀ [out ∀-type …]
+                          (→ (→ fun-in fun-out) …
+                             (Listof in-type)
+                             (Listof out-type))))
+               (define (map1 param-fun … &l …)
+                 (if (or (null? &l) …)
+                     '()
+                     (cons (apply-compose [fun …] [(car &l) …])
+                           (map1 param-fun … (cdr &l) …))))
+               map1))]));(map1 arg-fun … . ls)
+
+;; TODO: inefficient at compile-time: we run (:map #'f #'Out) twice.
+;; Plus it could cause some bugs because of differing #'Out.
 (define-syntax (map: stx)
   (syntax-parse stx
-    [(_ (~literal car) l) #'((curry-map A A (Pairof A Any) car) l)]
-    [(_ (~literal cdr) l) #'((curry-map B B (Pairof Any B) cdr) l)]
-    ;; TODO: add caar etc.
-    [(_ ((~literal values)) l) #'l]
-    [(_ ((~literal compose)) l) #'l]
-    [(_ ((~literal compose) f0 . fs) l) #'(map: f0 (map: (compose . fs) l))]
-    [(_ ((~literal curry) map: f) l)
-     #''_]
-    [(_ f . ls)
-     #'(map f . ls)]))
+    [(_ (~optional (~and norun (~literal norun))) f l …)
+     (define-temp-ids "&~a" (l …))
+     (syntax-parse (internal-map: #'f #'(&l …) #'Out)
+       [(:map-info . code)
+        (if (attribute norun)
+            #'(ann '(code arg-fun … l …) Any)
+            #'(code arg-fun … l …))])]))
 
-(module* test typed/racket
+(map: add1 '(1 2 3))
+(map: (compose add1) '(1 2 3))
+(map: (∘ identity add1) '(1 2 3))
+(map: (∘ add1 identity) '(1 2 3))
+(map: (∘ number->string add1) '(1 2 9))
+(map: (∘ string-length number->string add1) '(1 2 9))
+(map: car '((1 2) (2) (9 10 11)))
+(map: (∘ add1 car) '((1 2) (2) (9 10 11)))
+(map: (∘ string-length number->string add1 car cdr)
+      '((1 2) (2 3) (9 10 11)))
+(map: identity '(1 2 3))
+(map: values '(1 2 3))
+(map: (compose) '(1 2 3))
+(map: (compose identity) '(1 2 3))
+(map: (∘ identity values identity values) '(1 2 3))
+(map: (∘ length (curry map add1)) '((1 2) (3)))
+
+(map: (curry map add1) '((1 2) (3)))
+
+(define (numlist [x : Number]) (list x))
+(map: (∘ (curry map add1) numlist) '(1 2 3))
+(map: (∘ (curry map add1) (λ ([x : Number]) (list x))) '(1 2 3))
+
+
+#|(module* test typed/racket
   (require (submod "..")
            "../lib/low.rkt")
   
@@ -53,4 +221,253 @@
                  '(2 3 4))
   (check-equal?: (map: + '(1 2 3) '(4 5 6))
                  : (Listof Number)
-                 '(5 7 9)))
+                 '(5 7 9)))|#
+
+
+
+
+
+
+#|
+(map: (compose F (curry map add1)) '((1 2) (3)))
+
+Problem: in the code above, the input type of `F` has to be the return type of
+`(curry map add1)`, i.e. `(Listof B)`. The return type of `F` may depend on its
+input type (e.g. wrapping a value), so the type information flows leftwards
+inside `compose`.
+
+However, if F is a destructuring operation, like `car` or `cdr`, it may impose
+constraints on the return type of the function immediately to its right, meaning
+that the type information flows rightwards.
+
+It seems difficult to reconcile these two cases without writing a complex
+algorithm.
+
+Worst-case scenario:
+
+         +-- constrains to the right
+         v                                  v-- constrains to the right
+(compose car complex-calculation (curry map car))
+             ^                   ^-- gives a (Listof ?) to the left
+             +-- constrained on both sides
+
+Maybe we could cover most common cases by first getting the type for the handled
+cases which impose constraints to the right and/or give a type to the left, and
+then use these types instead of the ∀, to fill in the holes for other functions.
+
+EDIT: that's what we did, using the #:auto-in
+|#
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+#|
+(define-for-syntax (map-infer-types stx)
+  (syntax-parse stx
+    [(_ (~literal car))
+     (values #'(A B)
+             #'(Pairof A B))]
+    [(_ (~literal cdr)) #'(Pairof Any T)]
+    [(_ T (~literal values)) #'T]
+    [(_ T ((~literal compose))) #'T]
+    [(_ T ((~literal compose) f0 . fs))
+     #'(map-element (map-element T f0) (compose . fs))]
+    [(_ T ((~literal curry) (~or (~literal map:) (~literal map)) f) l)
+     #''_]
+    ;; get
+    [(_ f . ls)
+     ;; TODO:
+     #'T]))
+
+(define-type-expander (map-element stx)
+  (syntax-parse stx
+    [(_ T:id (~literal car)) #'(Pairof T Any)]
+    [(_ T:id (~literal cdr)) #'(Pairof Any T)]
+    [(_ T (~literal values)) #'T]
+    [(_ T ((~literal compose))) #'T]
+    [(_ T ((~literal compose) f0 . fs))
+     #'(map-element (map-element T f0) (compose . fs))]
+    [(_ T ((~literal curry) (~or (~literal map:) (~literal map)) f) l)
+     #''_]
+    ;; get
+    [(_ f . ls)
+     ;; TODO:
+     #'T]))
+
+
+(define-type-expander (map-result stx)
+  (syntax-parse stx
+    [(_ T:id (~literal car)) #'T]
+    [(_ T:id (~literal cdr)) #'T]))
+
+(define-syntax (map: stx)
+  (syntax-parse stx
+    [(_ (~literal car) l) #'((curry-map A A (Pairof A Any) car) l)]
+    [(_ (~literal cdr) l) #'((curry-map B B (Pairof Any B) cdr) l)]
+    ;; TODO: add caar etc.
+    [(_ ((~literal values)) l) #'l]
+    [(_ ((~literal compose)) l) #'l]
+    [(_ ((~literal compose) f0 . fs) l) #'(map: f0 (map: (compose . fs) l))]
+    [(_ ((~literal curry) (~or (~literal map:) (~literal map)) f) l)
+     #''_]
+    [(_ ((~literal λget) field-or-accessor …) l)
+     #'(get l (… …) field-or-accessor …)]
+    [(_ f . ls)
+     #'(map f . ls)]))
+
+
+
+|#
+
+
+
+
+
+
+
+
+
+#|
+
+#;#'(let ()      
+      (: map2 (∀ (poly-types …) (→ function-types …
+                                   (Listof (Listof A))
+                                   (Listof (Listof D)))))
+      (define (map2 f … l)
+        (if (null? l)
+            '()
+            (cons (map1 f … (car l))
+                  (map2 f … (cdr l)))))
+      (map2 f … l))
+
+; (map: (curry map add1) '((1 2 3) (4 5))) =>
+; (map: (curry map: add1) '((1 2 3) (4 5))) =>
+(let ()
+  (: map2 (∀ (A C) (→ (→ A C)
+                      (Listof (Listof A))
+                      (Listof (Listof C)))))
+  (define (map2 f l)
+    (if (null? l) '() (cons (map f (car l)) (map2 f (cdr l)))))
+  (map2 add1 '((1 2 3) (4 5))))
+
+;; TODO:
+; (map: (compose (curry map (compose list add1))
+;                (curry map (compose add1 add1)))
+;       '((1 2 3) (4 5)))
+; =>
+#;???
+
+; (map: (curry map (compose number->string add1)) '((1 2 3) (4 5))) =>
+; (map: (curry map: (compose number->string add1)) '((1 2 3) (4 5))) =>
+(let ()
+  (: map2 (∀ (A C D) (→ (→ A C)
+                        (→ C D)
+                        (Listof (Listof A))
+                        (Listof (Listof D)))))
+  (define (map2 f g l)
+    (if (null? l)
+        '()
+        (cons ;(map1 f g (car l))
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         (let ()
+           (: map1 (∀ (A C D) (→ (→ A C)
+                                 (→ C D)
+                                 (Listof A)
+                                 (Listof D))))
+           (define (map1 f g l)
+             (if (null? l) '() (cons (g (f (car l))) (map1 f g (cdr l)))))
+           (map1 f g (car l)))
+         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+         (map2 f g (cdr l)))))
+  (map2 add1 number->string '((1 2 3) (4 5))))
+
+; (map: add1 '(1 2 3))
+(let ()
+  (: map1 (∀ (A C) (→ (→ A C)
+                      (Listof A)
+                      (Listof C))))
+  (define (map1 f l)
+    (if (null? l) '() (cons (f (car l)) (map1 f (cdr l)))))
+  (map1 add1 '(1 2 3)))
+
+; (map: car '((1 a) (2 b) (3 c)))
+(let ()
+  (: map1 (∀ (A B) (→ (→ (Pairof A B) A)
+                      (Listof (Pairof A B))
+                      (Listof A))))
+  (define (map1 f l)
+    (if (null? l) '() (cons (f (car l)) (map1 f (cdr l)))))
+  (map1 car
+        '((1 a) (2 b) (3 c))))
+
+; (map: (curry map car) '([(1 a) (2 b)] [(3 c)]))
+; (map: (curry map: car) '([(1 a) (2 b)] [(3 c)]))
+(let ()
+  (: map1 (∀ (A B) (→ (→ (Pairof A B) A)
+                      (Listof (Pairof A B))
+                      (Listof A))))
+  (define (map1 f l)
+    (if (null? l) '() (cons (f (car l)) (map1 f (cdr l)))))
+  
+  (: map2 (∀ (A B) (→ (→ (Pairof A B) A)
+                      (Listof (Listof (Pairof A B)))
+                      (Listof (Listof A)))))
+  (define (map2 f l)
+    (if (null? l) '() (cons (map1 f (car l)) (map2 f (cdr l)))))
+  
+  (map2 car
+        '([(1 a) (2 b)] [(3 c)])))
+
+; (map: (curry map (curry map car)) '([(1 a) (2 b)] [(3 c)]))
+; (map: (curry map (curry map: car)) '([(1 a) (2 b)] [(3 c)]))
+; (map: (curry map: (curry map car)) '([(1 a) (2 b)] [(3 c)]))
+; (map: (curry map: (curry map: car)) '([(1 a) (2 b)] [(3 c)]))
+(let ()
+  (: map3 (∀ (A B) (→ ;(→ (Pairof A B) A)
+                    (Listof (Listof (Listof (Pairof A B))))
+                    (Listof (Listof (Listof A))))))
+  (define (map3 #|f|# l)
+    (if (null? l)
+        '()
+        (cons (let ()
+                (: map2 (∀ (A B) (→ ;(→ (Pairof A B) A)
+                                  (Listof (Listof (Pairof A B)))
+                                  (Listof (Listof A)))))
+                (define (map2 #|f|# l)
+                  (if (null? l)
+                      '()
+                      (cons (let ()
+                              (: map1 (∀ (A B) (→ ;(→ (Pairof A B) A)
+                                                (Listof (Pairof A B))
+                                                (Listof A))))
+                              (define (map1 #|f|# l)
+                                (if (null? l)
+                                    '()
+                                    (cons (#|f|#car (car l))
+                                          (map1 #|f|# (cdr l)))))
+                              (map1 #|f|# (car l)))
+                            (map2 #|f|# (cdr l)))))
+                (map2 #|f|# (car l)))
+              (map3 #|f|# (cdr l)))))
+  (map3 ;car
+   '([[(1 a) (2 b)] [(3 c)]] [[(4 d)]])))
+
+;(define-syntax-rule (inst-∀ T …)
+
+
+|#

graph/graph/map1.rkt

@@ -1,7 +1,8 @@
 #lang typed/racket
 
 (require (for-syntax syntax/parse
-                     "../lib/low-untyped.rkt"))
+                     "../lib/low-untyped.rkt")
+         "../type-expander/type-expander.lp2.rkt")
 
 (provide curry-map)
 
@@ -22,6 +23,9 @@
   (syntax-parse stx
     [(_ TVar Result-Type Element-Type f:curry-map-rec)
      (if (attribute f.bottom?)
+         ;; We use (ann λ type) instead of (λ #:∀ …) because as of version
+         ;; 6.3.0.8--2015-12-17(0d633fe/a), the latter doesn't work if put in a
+         ;; let's binding clause: (let ([f (λ #:∀ …)]) f) fails to typecheck.
          #'(ann (λ (l) ((inst map Result-Type Element-Type) f l))
                 (∀ (TVar) (→ (Listof Element-Type)
                              (Listof Result-Type))))

graph/lib/low.rkt

@@ -9,11 +9,20 @@
 ;; raco pkg install alexis-util
 ;; or:
 ;; raco pkg install threading
-(require alexis/util/threading)
+(require alexis/util/threading
+         (for-syntax racket/syntax
+                     syntax/parse))
 
 (define-syntax-rule (~>_ clause ... expr) (~> expr clause ...))
+(define-syntax (<~ stx)
+  (syntax-parse stx
+    [(_ expr clause ...)
+     (define/with-syntax (r-clause ...) (reverse (syntax->list #'(clause ...))))
+     #'(~> expr r-clause ...)]))
 
-(provide ~>_ ~> ~>> _ (rename-out [_ ♦]))
+(define-syntax-rule (<~_ clause ... expr) (<~ expr clause ...))
+
+(provide <~ <~_ ~>_ ~> ~>> _ (rename-out [_ ♦] [<~_ <~♦] [~>_ ~>♦]))
 
 ;; ==== low/typed-untyped-module.rkt ====
 
@@ -596,7 +605,7 @@
 (define (check-duplicate-identifiers ids)
   (if (check-duplicate-identifier (my-in-syntax ids)) #t #f))
 
-(require/typed racket/syntax [generate-temporary (→ Syntax Identifier)])
+(require/typed racket/syntax [generate-temporary (→ Any Identifier)])
 
 (require syntax/parse/define)
 (provide define-simple-macro)
@@ -619,7 +628,8 @@
   
   (require/typed racket/syntax
                  [format-id (→ Syntax String (U String Identifier) *
-                               Identifier)])
+                               Identifier)]
+                 [(generate-temporary generate-temporary2) (→ Any Identifier)])
   (require (only-in racket/syntax define/with-syntax)
            (only-in syntax/stx stx-map)
            (for-syntax racket/base
@@ -780,7 +790,9 @@
          (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
          
          (define/with-syntax format-temp-ids*
-           ((attribute base.wrap) #'(compose car (curry format-temp-ids format))
+           ((attribute base.wrap) #'(compose car
+                                             (curry format-temp-ids format)
+                                             generate-temporary)
                                   (λ (x deepest?)
                                     (if deepest?
                                         x
@@ -823,14 +835,14 @@
        (define/with-syntax pat (format-id #'base (syntax-e #'format)))
        (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
        (define/with-syntax format-temp-ids*
-           ((attribute base.wrap) #'(λ (x)
-                                      (car (format-temp-ids
-                                            (string-append format "~a")
-                                            "")))
-                                  (λ (x deepest?)
-                                    (if deepest?
-                                        x
-                                        #`(curry stx-map #,x)))))
+         ((attribute base.wrap) #'(λ (x)
+                                    (car (format-temp-ids
+                                          (string-append format "~a")
+                                          "")))
+                                (λ (x deepest?)
+                                  (if deepest?
+                                      x
+                                      #`(curry stx-map #,x)))))
        (syntax-cons-property
         #'(define/with-syntax pat-dotted
             (format-temp-ids* #'base))
@@ -892,15 +904,25 @@
   
   (check-equal? (fubar) '((1 . a) (2 . b) (3 . c))))
 
-#|
-(define-template-metafunction (t/gen-temp stx)
-  (syntax-parse stx
-    [(_ . id:id)
-     #:with (temp) (generate-temporaries #'(id))
-     #'temp]
-    [(_ id:id ...)
-     (generate-temporaries #'(id ...))]))
-|#
+(module m-t/gen-temp racket
+  (require syntax/parse
+           syntax/parse/experimental/template)
+  
+  (provide t/gen-temp)
+  
+  (define-template-metafunction (t/gen-temp stx)
+    (syntax-parse stx
+      [(_ id:id)
+       #:with (temp) (generate-temporaries #'(id))
+       #'temp]
+      #|[(_ . id:id)
+       #:with (temp) (generate-temporaries #'(id))
+       #'temp]
+      [(_ id:id ...)
+       (generate-temporaries #'(id ...))]|#)))
+
+(require 'm-t/gen-temp)
+(provide (rename-out [t/gen-temp &]))
 
 ;; ==== syntax.rkt ====
 
@@ -936,11 +958,75 @@
                [stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A))]
                [stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B))])
 |#
-(: stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A)))
-(define (stx-car p) (car (syntax-e p)))
+(: stx-car (∀ (A B)
+              (case→ (→ (Syntaxof (Pairof A B)) A)
+                     ;; TODO: Not typesafe!
+                     (→ (U (Syntaxof (Listof A)) (Listof A)) A))))
+(define (stx-car p) (car (if (syntax? p) (syntax-e p) p)))
 
-(: stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B)))
-(define (stx-cdr p) (cdr (syntax-e p)))
+(: stx-cdr (∀ (A B)
+              (case→ (→ (Syntaxof (Pairof A B)) B)
+                     ;; TODO: Not typesafe!
+                     (→ (U (Syntaxof (Listof A)) (Listof A)) (Listof A)))))
+(define (stx-cdr p) (cdr (if (syntax? p) (syntax-e p) p)))
+
+(: stx-null? (→ Any Boolean : (U (Syntaxof Null) Null)))
+(define (stx-null? v)
+  ((make-predicate (U (Syntaxof Null) Null)) v))
+
+(: stx-foldl
+   (∀ (E F G Acc)
+      (case→ (→ (→ E Acc Acc)
+                Acc
+                (U (Syntaxof (Listof E)) (Listof E))
+                Acc)
+             (→ (→ E F Acc Acc)
+                Acc
+                (U (Syntaxof (Listof E)) (Listof E))
+                (U (Syntaxof (Listof F)) (Listof F))
+                Acc)
+             (→ (→ E F G Acc Acc)
+                Acc
+                (U (Syntaxof (Listof E)) (Listof E))
+                (U (Syntaxof (Listof F)) (Listof F))
+                (U (Syntaxof (Listof G)) (Listof G))
+                Acc))))
+(define stx-foldl
+  (case-lambda
+    [(f acc l)
+     (if (stx-null? l)
+         acc
+         (stx-foldl f (f (stx-car l) acc) (stx-cdr l)))]
+    [(f acc l l2)
+     (if (or (stx-null? l) (stx-null? l2))
+         acc
+         (stx-foldl f
+                    (f (stx-car l) (stx-car l2) acc)
+                    (stx-cdr l)
+                    (stx-cdr l2)))]
+    [(f acc l l2 l3)
+     (if (or (stx-null? l) (stx-null? l2) (stx-null? l3))
+         acc
+         (stx-foldl f
+                    (f (stx-car l) (stx-car l2) (stx-car l3) acc)
+                    (stx-cdr l)
+                    (stx-cdr l2)
+                    (stx-cdr l3)))]))
+
+(module m-stx-untyped racket
+  (require syntax/stx)
+  (provide stx-cons stx-drop-last)
+  
+  ;(: stx-cons (∀ (A B) (→ A B (Syntaxof (Pairof A B)))))
+  (define (stx-cons a b) #`(#,a . #,b))
+  
+  ;(: stx-drop-last (∀ (A) (→ (Syntaxof (Listof A)) (Syntaxof (Listof A)))))
+  (define (stx-drop-last l)
+    (if (and (stx-pair? l) (stx-pair? (stx-cdr l)))
+        (stx-cons (stx-car l) (stx-drop-last (stx-cdr l)))
+        #'())))
+
+(require 'm-stx-untyped)
 
 ; (require/typed racket/base [(assoc assoc3)
 ;                             (∀ (a b) (→ Any (Listof (Pairof a b))

graph/type-expander/type-expander.lp2.rkt

@@ -385,7 +385,7 @@ them.
          (pattern [id:id (~optional (~seq :colon type:expr)) default:expr]
                   #:with tvars tvars
                   #:with (expanded ...)
-                  (template ([id (?@ : (tmpl-expand-type tvars type))
+                  (template ([id (?? (?@ : (tmpl-expand-type tvars type)))
                               default])))
          (pattern (~var kw (new-kw-formal tvars))
                   #:with (expanded ...) #'(kw.expanded ...)))