From 82096377bb20ee275046d74d8fdaa1f78e630073 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Sun, 16 Oct 2016 01:20:50 +0200 Subject: [PATCH] Now supports foldl and foldr --- info.rkt | 3 ++- main.rkt | 50 ++++++++++++++++++++++++----------- scribblings/typed-map.scrbl | 38 +++++++++++++++++++++++++-- test/test-map.rkt | 52 ++++++++++++++++++++++++++++++++++++- 4 files changed, 124 insertions(+), 19 deletions(-) diff --git a/info.rkt b/info.rkt index 9e80b20..19c9858 100644 --- a/info.rkt +++ b/info.rkt @@ -2,7 +2,8 @@ (define collection "typed-map") (define deps '("base" "rackunit-lib" - "typed-racket-lib")) + "typed-racket-lib" + "typed-racket-more")) (define build-deps '("scribble-lib" "racket-doc" "afl" diff --git a/main.rkt b/main.rkt index ed2b818..e38aa9b 100644 --- a/main.rkt +++ b/main.rkt @@ -1,8 +1,11 @@ #lang typed/racket -(require (only-in racket/base [map orig-map])) +(require (only-in racket/base + [map orig-map] + [foldr orig-foldr] + [foldl orig-foldl])) -(provide map) +(provide map foldr foldl) (module m racket/base (provide unoptimizable-false) @@ -23,6 +26,23 @@ (syntax-case stx (λ) [self (identifier? #'self) #'orig-map] [(_ (λ (argᵢ ...) body ...) lᵢ ...) + (andmap identifier? (syntax->list #'(argᵢ ...))) + #'(foldr (λ (argᵢ ... acc) (cons (begin body ...) acc)) null lᵢ ...)] + [(_ f lᵢ ...) + (with-syntax ([(argᵢ ...) (generate-temporaries #'(lᵢ ...))]) + #'(foldr (λ (argᵢ ... acc) (cons (f 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ᵢ ...)))) @@ -40,7 +60,7 @@ (unless (and (null? l-cacheᵢ) ...) ;; TODO: copy the error message from 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!. @@ -50,25 +70,25 @@ ;; … (set! mutable-list (cons … …) …)) ;; ;; compute the first result: ;; (let ([argᵢ (car upcast-lᵢ)] ...) body ...)) - (let ([upcast-result (list (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: copy the error message from map. + ;; TODO: copy the error message from foldr/map. (error "all lists must have same size")) (void)) (begin (set! upcast-result - (cons (let ([argᵢ (car l-loopᵢ)] - ...) - body ...) - upcast-result)) + (let ([argᵢ (car l-loopᵢ)] + ... + [arg-acc upcast-result]) + body ...)) (loop (cdr l-loopᵢ) ...)))) - (reverse upcast-result)))))))] - [(_ f lᵢ ...) - ;; TODO: multiple l + upcast-result))))))] + [(_ f init-acc lᵢ ...) (with-syntax ([(argᵢ ...) (generate-temporaries #'(lᵢ ...))]) - #'(map (λ (argᵢ ...) (f argᵢ ...)) lᵢ ...))])) + #'(foldr (λ (argᵢ ... arg-acc) (f argᵢ ... arg-acc)) init-acc lᵢ ...))])) diff --git a/scribblings/typed-map.scrbl b/scribblings/typed-map.scrbl index 773f753..d58f5c5 100644 --- a/scribblings/typed-map.scrbl +++ b/scribblings/typed-map.scrbl @@ -8,8 +8,10 @@ @(module orig racket/base (require scribble/manual (for-label racket/base)) - (provide orig:map) - (define orig:map @racket[map])) + (provide orig:map orig:foldl orig:foldr) + (define orig:map @racket[map]) + (define orig:foldl @racket[foldl]) + (define orig:foldr @racket[foldr])) @(require 'orig) @defmodule[typed-map] @@ -76,3 +78,35 @@ result of calling @racket[f] on any element has the same type, therefore the accumulator has the type @racket[(Listof B)], where @racket[B] is the inferred type of the result of @racket[f].}]} + + +@defproc[#:kind "syntax" + (foldl [f (→ A ... Acc Acc)] [init Acc] [l (Listof A)] ...) Acc]{ + Like @orig:foldl from @racketmodname[typed/racket/base] but with better type + inference for Typed Racket. + + This form is implemented in the same way as the overloaded version of + @racket[map] presented above. + + Note that in some cases, the type for the accumulator is not generalised + enough based on the result of the first iteration, in which cases annotations + are needed: + + @examples[#:eval ((make-eval-factory '(typed-map) #:lang 'typed/racket)) + (eval:error (foldl (λ (x acc) (cons acc (add1 x))) '() '(1 2 3))) + (foldl (λ (x [acc : (Rec R (U Null (Pairof R Positive-Index)))]) + (cons acc (add1 x))) + '() + '(1 2 3))]} + +@defproc[#:kind "syntax" + (foldr [f (→ A ... Acc Acc)] [init Acc] [l (Listof A)] ...) Acc]{ + Like @orig:foldr from @racketmodname[typed/racket/base] but with better type + inference for Typed Racket. + + This form is implemented in the same way as the overloaded version of + @racket[map] presented above. + + Note that in some cases, the type for the accumulator is not generalised + enough based on the result of the first iteration, in which cases annotations + are needed. See the example given for @racket[foldl].} \ No newline at end of file diff --git a/test/test-map.rkt b/test/test-map.rkt index f67bb97..6b6b015 100644 --- a/test/test-map.rkt +++ b/test/test-map.rkt @@ -1,6 +1,7 @@ #lang afl typed/racket -(require typed-map) +(require typed-map + typed/rackunit) ;; without ann (let () @@ -35,3 +36,52 @@ (ann (λ #:∀ (A) ([l : (Listof A)]) (map (λ (x) x) l)) (∀ (A) (→ (Listof A) (Listof A)))) + +;; with check-equal? +(check-equal? (map (λ (x) (* x 2)) '()) '()) +(check-equal? (map (λ (x) (* x 2)) '(1)) '(2)) +(check-equal? (map (λ (x) (* x 2)) '(1 2)) '(2 4)) +(check-equal? (map (λ (x) (* x 2)) '(1 2 3)) '(2 4 6)) +(check-equal? (map + '(1 2 3) '(4 5 6)) '(5 7 9)) +(check-equal? (map car '((1 2) (3 4))) '(1 3)) +(check-equal? (map #λ(+ % 1) '(1 2 3)) '(2 3 4)) + +(check-equal? (map map (list add1 sub1) '((1 2 3) (4 5 6))) + '((2 3 4) (3 4 5))) +(check-equal? (map map + (ann (list car cdr) + (Listof (→ (List Number) (U Number Null)))) + '(((1) (2) (3)) ((4) (5) (6)))) + '((1 2 3) (() () ()))) + +(check-equal? ((λ #:∀ (A) ([l : (Listof A)]) + (map (λ (x) x) l)) + '(a b c)) + '(a b c)) + +;; foldr: + +(check-equal? (foldr (λ (x acc) (cons (add1 x) acc)) '() '(1 2 3)) + (map add1 '(1 2 3))) +(check-equal? (foldr (λ (x acc) (cons (add1 x) acc)) '() '(1 2 3)) + '(2 3 4)) + +(let () + (ann (foldr (λ (x acc) (cons (add1 x) acc)) '() '()) Null) + (void)) + +;; foldl: + +(check-equal? (foldl (λ (x acc) (cons (add1 x) acc)) '() '(1 2 3)) + '(4 3 2)) +;; Does not work because the type changes. +#;(check-equal? (foldl (λ (x acc) (cons acc (add1 x))) '() '(1 2 3)) + '(4 (3 (2)))) +(foldl (λ (x [acc : (Rec R (U Null (Pairof R Positive-Index)))]) + (cons acc (add1 x))) + '() + '(1 2 3)) + +(let () + (ann (foldl (λ (x acc) (cons (add1 x) acc)) '() '()) Null) + (void)) \ No newline at end of file