diff --git a/function.rkt b/function.rkt index b88b28a..ab7ff3d 100644 --- a/function.rkt +++ b/function.rkt @@ -1,69 +1,7 @@ #lang typed/racket/base -;; Track procedure arity -;; Applications: -;; - -;; - vectorized ops -;; - (TODO) improve apply/map? ask Leif - (provide curry: ) -;; ----------------------------------------------------------------------------- - -(require - (for-syntax - typed/racket/base - racket/syntax - syntax/id-table - syntax/parse - syntax/stx - trivial/private/common -)) - -;; ============================================================================= - -(begin-for-syntax (define-syntax-class procedure/arity - #:attributes (expanded arity) - (pattern e - #:with e+ (expand-expr #'e) - #:with a (parse-procedure-arity #'e+) - #:when (syntax-e #'a) - #:attr expanded #'e+ - #:attr arity #'a) -)) - -;; ----------------------------------------------------------------------------- - -(define-syntax (curry: stx) - (syntax-parse stx - [(_ p:procedure/arity) - #:with (x* ...) (for/list ([_i (in-range (syntax-e #'p.arity))]) (gensym)) - #:with p+ (for/fold ([e (quasisyntax/loc stx (p #,@#`#,(reverse (syntax-e #'(x* ...)))))]) - ([x (in-list (syntax-e #'(x* ...)))]) - (quasisyntax/loc stx - (lambda (#,x) #,e))) - (syntax/loc stx p+)] - [_ - (raise-user-error 'curry "Fail ~a" (syntax->datum stx))])) - -(define-for-syntax id+procedure-arity (make-free-id-table)) -(define-for-syntax procedure-arity-key 'procedure:arity) - -;; ----------------------------------------------------------------------------- - -(define-for-syntax (parse-procedure-arity stx) - (cond - [(syntax-property stx procedure-arity-key) - => (lambda (x) x)] - [(identifier? stx) - (free-id-table-ref id+procedure-arity stx #f)] - [else - (syntax-parse stx #:literals (#%plain-lambda) - [(#%plain-lambda (x*:id ...) e* ...) - (length (syntax-e #'(x* ...)))] - ;; TODO polydots, keywords, optional args - ;; TODO standard library functions - [_ #f])])) - +(require trivial/private/function) diff --git a/private/function.rkt b/private/function.rkt new file mode 100644 index 0000000..206149a --- /dev/null +++ b/private/function.rkt @@ -0,0 +1,51 @@ +#lang typed/racket/base + +;; Track procedure arity +;; Applications: +;; - +;; - vectorized ops +;; - (TODO) improve apply/map? ask Leif + +(provide + curry: +) + +;; ----------------------------------------------------------------------------- + +(require + (for-syntax + typed/racket/base + syntax/parse + trivial/private/common +)) + +;; ============================================================================= + +(begin-for-syntax + (define (parse-procedure-arity stx) + (syntax-parse stx #:literals (#%plain-lambda) + [(#%plain-lambda (x*:id ...) e* ...) + (length (syntax-e #'(x* ...)))] + ;; 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?) +) + +;; ----------------------------------------------------------------------------- + +(define-syntax (curry: stx) + (syntax-parse stx + [(_ p:procedure/arity) + #:with (x* ...) (for/list ([_i (in-range (syntax-e #'p.evidence))]) (gensym)) + #:with p+ (for/fold ([e (quasisyntax/loc stx (p #,@#`#,(reverse (syntax-e #'(x* ...)))))]) + ([x (in-list (syntax-e #'(x* ...)))]) + (quasisyntax/loc stx + (lambda (#,x) #,e))) + (syntax/loc stx p+)] + [_ + (raise-user-error 'curry "Fail ~a" (syntax->datum stx))])) +