From b509908ad9842e8bcfbac6e8c60fb11cfbb60fc3 Mon Sep 17 00:00:00 2001
From: ben <benjaminlgreenman@gmail.com>
Date: Tue, 15 Mar 2016 18:29:28 -0400
Subject: [PATCH] [function] hacked up map implementation

---
 define.rkt             |   7 ++-
 function.rkt           |   1 +
 function/no-colon.rkt  |   1 +
 private/common.rkt     |   1 +
 private/function.rkt   | 131 +++++++++++++++++++++++++++++++++++++----
 test/define-fail.rkt   |  14 +++++
 test/define-pass.rkt   |  16 ++++-
 test/function-fail.rkt |  18 +++++-
 test/function-pass.rkt |  27 +++++++++
 9 files changed, 202 insertions(+), 14 deletions(-)

diff --git a/define.rkt b/define.rkt
index 1e10e59..48ded70 100644
--- a/define.rkt
+++ b/define.rkt
@@ -17,6 +17,9 @@
   (only-in trivial/private/regexp
     rx-define
     rx-let)
+  (only-in trivial/private/function
+    fun-define
+    fun-let)
   (only-in trivial/private/vector
     vec-define
     vec-let))
@@ -25,10 +28,12 @@
   (lambda (stx)
     (or (num-define stx)
         (rx-define stx)
+        (fun-define stx)
         (vec-define stx)))))
 
 (define-syntax let: (make-keyword-alias 'let
   (lambda (stx)
-    (or (num-let stx)
+    (or (fun-let stx)
+        (num-let stx)
         (rx-let stx)
         (vec-let stx)))))
diff --git a/function.rkt b/function.rkt
index ab7ff3d..7194ffa 100644
--- a/function.rkt
+++ b/function.rkt
@@ -2,6 +2,7 @@
 
 (provide
   curry:
+  map:
 )
 
 (require trivial/private/function)
diff --git a/function/no-colon.rkt b/function/no-colon.rkt
index 5e629eb..d714ddd 100644
--- a/function/no-colon.rkt
+++ b/function/no-colon.rkt
@@ -3,4 +3,5 @@
 (provide (all-from-out trivial/function))
 
 (require (rename-in trivial/function
+ [map: map]
  [curry: curry]))
diff --git a/private/common.rkt b/private/common.rkt
index c6a88a6..908df34 100644
--- a/private/common.rkt
+++ b/private/common.rkt
@@ -4,6 +4,7 @@
 ;; TODO make-set!-transformer
 
 (provide
+  expand-expr ;; TODO stop providing
 
   quoted-stx-value?
   ;; (-> Any (U #f Syntax))
diff --git a/private/function.rkt b/private/function.rkt
index 8de10ec..e723b64 100644
--- a/private/function.rkt
+++ b/private/function.rkt
@@ -1,5 +1,13 @@
 #lang typed/racket/base
 
+;; TODO get type from a lambda AFTER expansion
+;
+;(require
+; (for-syntax
+;   (only-in typed-racket/private/syntax-properties plambda-property)))
+;
+;; -----------------------------------------------------------------------------
+
 ;; Track procedure arity
 ;; Applications:
 ;; - 
@@ -9,6 +17,12 @@
 
 (provide
   curry:
+  map:
+
+  ;; --
+  (for-syntax
+    fun-define
+    fun-let)
 )
 
 ;; -----------------------------------------------------------------------------
@@ -17,23 +31,76 @@
   (for-syntax
     typed/racket/base
     syntax/parse
+    racket/syntax
     trivial/private/common
 ))
 
+(require
+    (prefix-in tr: typed/racket/base)
+    (prefix-in r: (only-in racket/base quote))
+ (for-syntax
+  syntax/id-table))
+
 ;; =============================================================================
 
 (begin-for-syntax
   (define (parse-procedure-arity stx)
-    (syntax-parse stx #:literals (#%plain-lambda)
-     [(#%plain-lambda (x*:id ...) e* ...)
-      (length (syntax-e #'(x* ...)))]
+    (syntax-parse stx #:literals (: lambda)
+     [(lambda (x*:id ...) e* ...)
+      (define any-stx (format-id stx "Any"))
+      (for/list ([_x (in-list (syntax-e #'(x* ...)))])
+        any-stx)]
+     [(lambda ([x*:id : t*] ...) e* ...)
+      (syntax-e #'(t* ...))]
      ;; TODO polydots, keywords, optional args
      ;; TODO standard library functions
      [_ #f]))
 
-  (define-values (arity-key proc? define-proc let-proc)
-    (make-value-property 'procedure:arity parse-procedure-arity))
-  (define-syntax-class/predicate procedure/arity proc?)
+  ;; TODO ugly! ==============================================================
+  ;; need to recover types after expansion
+
+  ;(define-values (arity-key fun? fun-define fun-let)
+  ;  (make-value-property 'procedure:arity parse-procedure-arity))
+  (define key 'procedure:arity)
+  (define tbl (make-free-id-table))
+  (define fun?
+    (lambda (stx)
+      (let ([v (syntax-property stx key)])
+        (cond
+         [v                  v]
+         [(identifier? stx)  (free-id-table-ref tbl stx #f)]
+         [else               (parse-procedure-arity stx)]))))
+  (define fun-define
+    (lambda (stx)
+      (syntax-parse stx #:literals (tr:#%plain-lambda)
+       [(_ name:id v)
+        #:with m (fun? (syntax/loc stx v))
+        #:when (syntax-e (syntax/loc stx m))
+        (free-id-table-set! tbl #'name (syntax-e #'m))
+        (syntax/loc stx
+          (tr:define name v))]
+       [_ #f])))
+  (define fun-let
+    (lambda (stx)
+      (syntax-parse stx
+       [(_ ([name*:id v*] ...) e* ...)
+        #:with (m* ...) (map fun? (syntax-e (syntax/loc stx (v* ...))))
+        #:when (andmap syntax-e (syntax-e (syntax/loc stx (m* ...))))
+        (quasisyntax/loc stx
+          (tr:let ([name* v*] ...)
+            (tr:let-syntax ([name* (make-rename-transformer
+                                     (syntax-property #'name* '#,key 'm*))] ...)
+              e* ...)))]
+       [_ #f])))
+
+  (define-syntax-class procedure/arity
+   #:attributes (evidence expanded)
+   (pattern e
+    #:with e+ #'e
+    #:with p+ (fun? #'e+)
+    #:when (syntax-e #'p+)
+    #:attr evidence #'p+
+    #:attr expanded #'e+))
 )
 
 ;; -----------------------------------------------------------------------------
@@ -41,12 +108,56 @@
 (define-syntax (curry: stx)
   (syntax-parse stx
    [(_ p:procedure/arity)
-    #:with (x* ...) (for/list ([_i (in-range (syntax-e #'p.evidence))]) (gensym))
+    #:with (x* ...) (for/list ([t (in-list (syntax-e #'p.evidence))]) (gensym))
     #:with p+ (for/fold ([e (quasisyntax/loc stx (p #,@#`#,(reverse (syntax-e #'(x* ...)))))])
-                        ([x (in-list (syntax-e #'(x* ...)))])
+                        ([x (in-list (syntax-e #'(x* ...)))]
+                         [t (in-list (syntax-e #'p.evidence))])
                 (quasisyntax/loc stx
-                  (lambda (#,x) #,e)))
+                  (lambda ([#,x : #,t]) #,e)))
     (syntax/loc stx p+)]
    [_
-    (raise-user-error 'curry "Fail ~a" (syntax->datum stx))]))
+    (raise-user-error 'curry "Fail at: ~a" (syntax->datum stx))]))
+
+;; TODO try the other direction, inferring type from arguments.
+;;   (may not be practical here, may need to be inside TR)
+(define-syntax map: (make-alias #'map
+  (lambda (stx) (syntax-parse stx
+   [(_ p:procedure/arity e* ...)
+    ;; --
+    #:when
+      (let ([num-expected (length (syntax-e #'p.evidence))]
+            [num-actual (length (syntax-e #'(e* ...)))])
+        (unless (= num-expected num-actual)
+          (apply raise-arity-error
+            'map:
+            num-expected
+            (map syntax->datum (syntax-e #'(e* ...))))))
+    ;; --
+    #:with Listof-stx (format-id stx "Listof")
+    #:with (e+* ...)
+      (for/list ([t (in-list (syntax-e #'p.evidence))]
+                 [e (in-list (syntax-e #'(e* ...)))])
+        (quasisyntax/loc stx (ann #,e (Listof-stx #,t))))
+    (syntax/loc stx (map p.expanded e+* ...))]
+   [(_ p e* ...)
+    ;; TODO -- this case should be subsumed by the last
+    #:with p+ (expand-expr #'p)
+    #:with evi (fun? #'p+)
+    #:when (syntax-e #'evi)
+    #:when
+      (let ([num-expected (length (syntax-e #'evi))]
+            [num-actual (length (syntax-e #'(e* ...)))])
+        (unless (= num-expected num-actual)
+          (apply raise-arity-error
+            'map:
+            num-expected
+            (map syntax->datum (syntax-e #'(e* ...))))))
+    ;; --
+    #:with Listof-stx (format-id stx "Listof")
+    #:with (e+* ...)
+      (for/list ([t (in-list (syntax-e #'evi))]
+                 [e (in-list (syntax-e #'(e* ...)))])
+        ;; TODO stop using format-id
+        (quasisyntax/loc stx (ann #,e (Listof-stx #,(format-id stx "~a" t)))))
+    (syntax/loc stx (map p+ e+* ...))]))))
 
diff --git a/test/define-fail.rkt b/test/define-fail.rkt
index a0e4ee7..15300bb 100644
--- a/test/define-fail.rkt
+++ b/test/define-fail.rkt
@@ -1,4 +1,6 @@
 #lang racket/base
+;; TODO why raising wrong exception?
+
 (require trivial/private/test-common
   (only-in typed/racket/base
     ann Zero))
@@ -10,4 +12,16 @@
   (let-num: ([n 5])
     (set! n 6)
     (ann (-: n 5) Zero))
+)
+(test-compile-error
+  #:require trivial/define trivial/function trivial/format
+  #:exn exn:fail? ;;#rx"Type Checker"
+
+  (let: ([f (lambda ([x : String] [y : Integer])
+  ;; Error here -- swapped y and x
+              (format: "hello(~a) and ~b" y x))])
+    (let: ([xs '("hi" "hi" "HI")]
+           [ys '(4 3 1)])
+    (map: f xs ys)))
+
 ))
diff --git a/test/define-pass.rkt b/test/define-pass.rkt
index 95b60c0..69cc4fb 100644
--- a/test/define-pass.rkt
+++ b/test/define-pass.rkt
@@ -1,5 +1,11 @@
 #lang typed/racket/base
-(require trivial/define trivial/math trivial/regexp trivial/vector)
+(require
+  trivial/define
+  trivial/format
+  trivial/function
+  trivial/math
+  trivial/regexp
+  trivial/vector)
 
 (module+ test
   (require typed/rackunit)
@@ -21,4 +27,12 @@
     (let: ([v '#(3 9 2)])
       (ann (-: (vector-length: v) 3) Zero))
     0)
+
+  (check-equal?
+    (let: ([f (lambda ([x : String] [y : Integer])
+                (format: "hello(~a) and ~b" x y))])
+      (let: ([xs '("hi" "hi" "HI")]
+             [ys '(4 3 1)])
+      (map: f xs ys)))
+    '("hello(hi) and 100" "hello(hi) and 11" "hello(HI) and 1"))
 )
diff --git a/test/function-fail.rkt b/test/function-fail.rkt
index 212a47c..cac4d96 100644
--- a/test/function-fail.rkt
+++ b/test/function-fail.rkt
@@ -2,8 +2,22 @@
 (require trivial/private/test-common)
 
 (module+ test (test-compile-error
-  #:require trivial/function
-  #:exn #rx"Type Checker"
+  #:require trivial/function trivial/format
+  #:exn #rx"at:" ;;TODO
   ((curry: (lambda (x y) x)) 0 1)
   (((curry: (lambda (x y z) z)) 'x) 'y 'z)
+  (((curry: (lambda ([x : Integer] [y : Integer]) (+ x x y))) 'a) 'b)
+  ((((curry: (λ ([x : Any] [y : Any]) x)) 'a) 'b) 'c)
+  (map: (λ ([x : String] [y : String])
+            (string-append x y))
+          '("hello"))
+  (map: (λ ([x : String] [y : String])
+          (string-append x y))
+          '("hello")
+          '("world")
+          '("howareya"))
+  (map: (λ ([x : String] [y : String])
+          (format: "~d ~d" x y))
+          '("hello")
+          '("world"))
 ))
diff --git a/test/function-pass.rkt b/test/function-pass.rkt
index 75da6bd..4e7e01f 100644
--- a/test/function-pass.rkt
+++ b/test/function-pass.rkt
@@ -2,6 +2,7 @@
 
 (module+ test
   (require
+    trivial/format
     trivial/function
     typed/rackunit)
 
@@ -12,4 +13,30 @@
   (check-equal?
     ((((curry: (lambda (x y z) z)) 0) 1) 2)
     2)
+
+  (check-equal?
+    (((curry: (lambda ([x : Integer] [y : Integer]) 2)) 0) 1)
+    2)
+
+  (check-equal?
+    (((curry: (lambda ([x : Integer] [y : Integer]) (+ x x y))) 3) 1)
+    7)
+
+  (check-equal?
+    (((curry: (λ ([x : Any] [y : Any]) x)) 'a) 'b)
+    'a)
+
+  (check-equal?
+    (map: (λ ([x : String] [y : String])
+            (string-append x y))
+          '("hello")
+          '("world"))
+    '("helloworld"))
+
+  (check-equal?
+    (map: (λ ([x : String] [y : String])
+            (format: "~a ~a" x y))
+          '("hello")
+          '("world"))
+    '("hello world"))
 )