[function] fixedd curry

private/function.rkt

@@ -35,72 +35,29 @@
     trivial/private/common
 ))
 
-(require
-    (prefix-in tr: typed/racket/base)
-    (prefix-in r: (only-in racket/base quote))
- (for-syntax
-  syntax/id-table))
+;(require
+;    (prefix-in tr: typed/racket/base)
+;    (prefix-in r: (only-in racket/base quote))
+; (for-syntax
+;  syntax/id-table))
 
 ;; =============================================================================
 
 (begin-for-syntax
+  (define TYPE-KEY 'type-label)
+
   (define (parse-procedure-arity stx)
-    (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* ...))]
+    (syntax-parse stx #:literals (: #%plain-lambda lambda)
+     [(#%plain-lambda (x*:id ...) e* ...)
+      (syntax/loc stx (x* ...))]
      ;; TODO polydots, keywords, optional args
      ;; TODO standard library functions
      [_ #f]))
 
-  ;; 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-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+))
+  (define-syntax-class/predicate procedure/arity fun?)
 )
 
 ;; -----------------------------------------------------------------------------
@@ -108,12 +65,10 @@
 (define-syntax (curry: stx)
   (syntax-parse stx
    [(_ p:procedure/arity)
-    #: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* ...)))]
-                         [t (in-list (syntax-e #'p.evidence))])
+    #:with p+ (for/fold ([e (quasisyntax/loc stx (p.expanded #,@#'p.evidence))])
+                        ([x (in-list (reverse (syntax-e #'p.evidence)))])
                 (quasisyntax/loc stx
-                  (lambda ([#,x : #,t]) #,e)))
+                  (lambda (#,x) #,e)))
     (syntax/loc stx p+)]
    [_
     (raise-user-error 'curry "Fail at: ~a" (syntax->datum stx))]))