89 lines
4.0 KiB
Racket
89 lines
4.0 KiB
Racket
#lang typed/racket
|
|
|
|
(require (only-in racket/base
|
|
[map orig-map]
|
|
[foldr orig-foldr]
|
|
[foldl orig-foldl]))
|
|
|
|
(provide map foldr foldl)
|
|
|
|
(: generalize (∀ (A) (case→ (→ Null Null)
|
|
(→ (Listof A) (Listof A)))))
|
|
(define (generalize l) l)
|
|
|
|
(define-syntax (map stx)
|
|
(syntax-case stx (λ)
|
|
[self (identifier? #'self) #'orig-map]
|
|
[(_ (λ (argᵢ ...) body ...) lᵢ ...)
|
|
(andmap identifier? (syntax->list #'(argᵢ ...)))
|
|
#'(foldr (λ (argᵢ ... acc) (cons (let () body ...) acc)) null lᵢ ...)]
|
|
[(_ f lᵢ ...)
|
|
(with-syntax ([(argᵢ ...) (generate-temporaries #'(lᵢ ...))])
|
|
#'(let ([f-cache f])
|
|
(foldr (λ (argᵢ ... acc)
|
|
(cons (f-cache argᵢ ...) acc))
|
|
null
|
|
lᵢ
|
|
...)))]))
|
|
|
|
(define-syntax (foldr stx)
|
|
(syntax-case stx (λ)
|
|
[self (identifier? #'self) #'orig-foldr]
|
|
[(_ f init-acc lᵢ ...)
|
|
#'(foldl f init-acc (reverse lᵢ) ...)]))
|
|
|
|
(define-syntax (foldl stx)
|
|
(syntax-case stx (λ)
|
|
[self (identifier? #'self) #'orig-foldl]
|
|
[(_ (λ (argᵢ ... arg-acc) body ...) init-acc lᵢ ...)
|
|
(andmap identifier? (syntax->list #'(argᵢ ... arg-acc)))
|
|
(begin
|
|
(unless (equal? (length (syntax->list #'(argᵢ ...)))
|
|
(length (syntax->list #'(lᵢ ...))))
|
|
(raise-syntax-error 'infer-map
|
|
"wrong number of argument lists for the function"
|
|
stx))
|
|
(with-syntax ([(l-cacheᵢ ...) (generate-temporaries #'(lᵢ ...))]
|
|
[(upcast-lᵢ ...) (generate-temporaries #'(lᵢ ...))]
|
|
[(l-loopᵢ ...) (generate-temporaries #'(lᵢ ...))])
|
|
#'(let ([l-cacheᵢ lᵢ] ...)
|
|
(let ([upcast-lᵢ (generalize l-cacheᵢ)]
|
|
...)
|
|
(if (or (null? l-cacheᵢ) ...)
|
|
(begin
|
|
(unless (and (null? l-cacheᵢ) ...)
|
|
;; TODO: produce the same error message as map.
|
|
(error "all lists must have same size"))
|
|
init-acc)
|
|
;; Possibility to call (generalize) on the single-element
|
|
;; list if Typed Racket does not generalize the (List B)
|
|
;; type to (Listof B) thanks to the use of set!.
|
|
;; If necessary, use the following structure:
|
|
;; ((λ #:∀ (B) ([upcast-first-result : B])
|
|
;; (let ([mutable-list : (Listof B)])
|
|
;; … (set! mutable-list (cons … …) …))
|
|
;; ;; compute the first result:
|
|
;; (let ([argᵢ (car upcast-lᵢ)] ...) body ...))
|
|
(let ([upcast-result (let ([argᵢ (car upcast-lᵢ)]
|
|
...
|
|
[arg-acc init-acc])
|
|
body ...)])
|
|
(let loop ([l-loopᵢ (cdr upcast-lᵢ)]
|
|
...)
|
|
(if (or (null? l-loopᵢ) ...)
|
|
(begin
|
|
(unless (and (null? l-loopᵢ) ...)
|
|
;; TODO: same error message as foldr or map.
|
|
(error "all lists must have same size"))
|
|
(void))
|
|
(begin (set! upcast-result
|
|
(let ([argᵢ (car l-loopᵢ)]
|
|
...
|
|
[arg-acc upcast-result])
|
|
body ...))
|
|
(loop (cdr l-loopᵢ) ...))))
|
|
upcast-result))))))]
|
|
[(_ f init-acc lᵢ ...)
|
|
(with-syntax ([(argᵢ ...) (generate-temporaries #'(lᵢ ...))])
|
|
#'(foldl (λ (argᵢ ... arg-acc) (f argᵢ ... arg-acc)) init-acc lᵢ ...))]))
|