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

Now supports foldl and foldr

Browse Source
This commit is contained in:
Georges Dupéron 2016-10-16 01:20:50 +02:00
parent 8f0bcc61b0
commit 82096377bb
4 changed files with 124 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
info.rkt
View File

@ -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"

50
main.rkt
View File

@ -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ᵢ ...))]))

38
scribblings/typed-map.scrbl
View File

@ -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].}

52
test/test-map.rkt
View File

@ -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))