main.rkt (4092B)
1 #lang typed/racket 2 3 (require (only-in racket/base 4 [map orig-map] 5 [foldr orig-foldr] 6 [foldl orig-foldl])) 7 8 (provide map foldr foldl) 9 10 (: generalize (∀ (A) (case→ (→ Null Null) 11 (→ (Listof A) (Listof A))))) 12 (define (generalize l) l) 13 14 (define-syntax (map stx) 15 (syntax-case stx (λ) 16 [self (identifier? #'self) #'orig-map] 17 [(_ (λ (argᵢ ...) body ...) lᵢ ...) 18 (andmap identifier? (syntax->list #'(argᵢ ...))) 19 #'(foldr (λ (argᵢ ... acc) (cons (let () body ...) acc)) null lᵢ ...)] 20 [(_ f lᵢ ...) 21 (with-syntax ([(argᵢ ...) (generate-temporaries #'(lᵢ ...))]) 22 #'(let ([f-cache f]) 23 (foldr (λ (argᵢ ... acc) 24 (cons (f-cache argᵢ ...) acc)) 25 null 26 lᵢ 27 ...)))])) 28 29 (define-syntax (foldr stx) 30 (syntax-case stx (λ) 31 [self (identifier? #'self) #'orig-foldr] 32 [(_ f init-acc lᵢ ...) 33 #'(foldl f init-acc (reverse lᵢ) ...)])) 34 35 (define-syntax (foldl stx) 36 (syntax-case stx (λ) 37 [self (identifier? #'self) #'orig-foldl] 38 [(_ (λ (argᵢ ... arg-acc) body ...) init-acc lᵢ ...) 39 (andmap identifier? (syntax->list #'(argᵢ ... arg-acc))) 40 (begin 41 (unless (equal? (length (syntax->list #'(argᵢ ...))) 42 (length (syntax->list #'(lᵢ ...)))) 43 (raise-syntax-error 'infer-map 44 "wrong number of argument lists for the function" 45 stx)) 46 (with-syntax ([(l-cacheᵢ ...) (generate-temporaries #'(lᵢ ...))] 47 [(upcast-lᵢ ...) (generate-temporaries #'(lᵢ ...))] 48 [(l-loopᵢ ...) (generate-temporaries #'(lᵢ ...))]) 49 #'(let ([l-cacheᵢ lᵢ] ...) 50 (let ([upcast-lᵢ (generalize l-cacheᵢ)] 51 ...) 52 (if (or (null? l-cacheᵢ) ...) 53 (begin 54 (unless (and (null? l-cacheᵢ) ...) 55 ;; TODO: produce the same error message as map. 56 (error "all lists must have same size")) 57 init-acc) 58 ;; Possibility to call (generalize) on the single-element 59 ;; list if Typed Racket does not generalize the (List B) 60 ;; type to (Listof B) thanks to the use of set!. 61 ;; If necessary, use the following structure: 62 ;; ((λ #:∀ (B) ([upcast-first-result : B]) 63 ;; (let ([mutable-list : (Listof B)]) 64 ;; … (set! mutable-list (cons … …) …)) 65 ;; ;; compute the first result: 66 ;; (let ([argᵢ (car upcast-lᵢ)] ...) body ...)) 67 (let ([upcast-result (let ([argᵢ (car upcast-lᵢ)] 68 ... 69 [arg-acc init-acc]) 70 body ...)]) 71 (let loop ([l-loopᵢ (cdr upcast-lᵢ)] 72 ...) 73 (if (or (null? l-loopᵢ) ...) 74 (begin 75 (unless (and (null? l-loopᵢ) ...) 76 ;; TODO: same error message as foldr or map. 77 (error "all lists must have same size")) 78 (void)) 79 (begin (set! upcast-result 80 (let ([argᵢ (car l-loopᵢ)] 81 ... 82 [arg-acc upcast-result]) 83 body ...)) 84 (loop (cdr l-loopᵢ) ...)))) 85 upcast-result))))))] 86 [(_ f init-acc lᵢ ...) 87 (with-syntax ([(argᵢ ...) (generate-temporaries #'(lᵢ ...))]) 88 #'(foldl (λ (argᵢ ... arg-acc) (f argᵢ ... arg-acc)) init-acc lᵢ ...))]))