suzanne.soy/trivial
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

[function] fixedd curry

Browse Source
This commit is contained in:
ben 2016-03-19 08:47:49 -04:00
parent a5f44b69d1
commit a508db7a73
1 changed files with 16 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
private/function.rkt
View File

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