commit 82096377bb20ee275046d74d8fdaa1f78e630073
parent 8f0bcc61b08edbe10c963908c467ddce85212c15
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 16 Oct 2016 01:20:50 +0200
Now supports foldl and foldr
Diffstat:
4 files changed, 126 insertions(+), 19 deletions(-)
diff --git 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
@@ -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
@@ -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
@@ -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
