Initial commit

.gitignore

@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/

.travis.yml

@@ -0,0 +1,60 @@
+language: c
+
+# Based from: https://github.com/greghendershott/travis-racket
+
+# Optional: Remove to use Travis CI's older infrastructure.
+sudo: false
+
+env:
+  global:
+    # Supply a global RACKET_DIR environment variable. This is where
+    # Racket will be installed. A good idea is to use ~/racket because
+    # that doesn't require sudo to install and is therefore compatible
+    # with Travis CI's newer container infrastructure.
+    - RACKET_DIR=~/racket
+  matrix:
+    # Supply at least one RACKET_VERSION environment variable. This is
+    # used by the install-racket.sh script (run at before_install,
+    # below) to select the version of Racket to download and install.
+    #
+    # Supply more than one RACKET_VERSION (as in the example below) to
+    # create a Travis-CI build matrix to test against multiple Racket
+    # versions.
+    #- RACKET_VERSION=6.0
+    #- RACKET_VERSION=6.1
+    - RACKET_VERSION=6.1.1
+    - RACKET_VERSION=6.2
+    - RACKET_VERSION=6.3
+    - RACKET_VERSION=6.4
+    - RACKET_VERSION=6.5
+    - RACKET_VERSION=6.6
+    #- RACKET_VERSION=6.7 # Not yet
+    - RACKET_VERSION=HEAD
+
+matrix:
+  allow_failures:
+#   - env: RACKET_VERSION=HEAD
+  fast_finish: true
+
+before_install:
+- git clone https://github.com/greghendershott/travis-racket.git ~/travis-racket
+- cat ~/travis-racket/install-racket.sh | bash # pipe to bash not sh!
+- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us
+
+install:
+ - raco pkg install --deps search-auto
+
+before_script:
+
+# Here supply steps such as raco make, raco test, etc.  You can run
+# `raco pkg install --deps search-auto` to install any required
+# packages without it getting stuck on a confirmation prompt.
+script:
+ - raco test -x -p typed-map
+ - raco setup --check-pkg-deps --pkgs typed-map
+ - raco pkg install --deps search-auto doc-coverage
+ - if test "$RACKET_VERSION" != "6.2" -a "$RACKET_VERSION" != "6.3"; then raco doc-coverage typed-map; fi
+
+after_success:
+ - raco pkg install --deps search-auto cover cover-coveralls
+ - raco cover -b -f coveralls -d $TRAVIS_BUILD_DIR/coverage .

LICENSE.txt

@@ -0,0 +1,11 @@
+typed-map
+Copyright (c) 2016 georges
+
+This package is distributed under the GNU Lesser General Public
+License (LGPL).  This means that you can link typed-map into proprietary
+applications, provided you follow the rules stated in the LGPL.  You
+can also modify this package; if you distribute a modified version,
+you must distribute it under the terms of the LGPL, which in
+particular means that you must release the source code for the
+modified software.  See http://www.gnu.org/copyleft/lesser.html
+for more information.

README.md

@@ -0,0 +1,10 @@
+[![Build Status,](https://img.shields.io/travis/jsmaniac/typed-map/master.svg)](https://travis-ci.org/jsmaniac/typed-map)
+[![Coverage Status,](https://img.shields.io/coveralls/jsmaniac/typed-map/master.svg)](https://coveralls.io/github/jsmaniac/typed-map)
+[![Build Stats,](https://img.shields.io/badge/build-stats-blue.svg)](http://jsmaniac.github.io/travis-stats/#jsmaniac/typed-map)
+[![Online Documentation.](https://img.shields.io/badge/docs-online-blue.svg)](http://docs.racket-lang.org/typed-map/)
+
+typed-map
+=========
+
+Type inference helper for map with Typed/Racket.
+Supports afl, un-annotated lambdas and polymorphic functions.

info.rkt

@@ -0,0 +1,15 @@
+#lang info
+(define collection "typed-map")
+(define deps '("base"
+               "rackunit-lib"
+               "typed-racket-lib"))
+(define build-deps '("scribble-lib"
+                     "racket-doc"
+                     "afl"))
+(define scribblings '(("scribblings/typed-map.scrbl" ())))
+(define pkg-desc
+  (string-append "Type inference helper for map with Typed/Racket."
+                 " Supports afl, un-annotated lambdas and polymorphic"
+                 " functions."))
+(define version "1.0")
+(define pkg-authors '("Georges Dupéron"))

main.rkt

@@ -0,0 +1,74 @@
+#lang typed/racket
+
+(require (only-in racket/base [map orig-map]))
+
+(provide map generalize)
+
+(module m racket/base
+  (provide unoptimizable-false)
+  (define (unoptimizable-false) #f))
+(require/typed 'm [unoptimizable-false (→ Boolean)])
+
+(define #:∀ (A) (generalize [l : (Listof A)])
+  (if (unoptimizable-false)
+      l
+      ;; the double-reverse is complex enough that Typed/Racket does not
+      ;; infer that generalize has type (→ A A) instead of
+      ;; (→ (Listof A) (Listof A))
+      ;; The unoptimizable-false above means that this is never executed,
+      ;; so the performance cost of the double-reverse is not incured.
+      (reverse (reverse l))))
+
+(define-syntax (map stx)
+  (syntax-case stx (λ)
+    [self (identifier? #'self) #'orig-map]
+    [(_ (λ (argᵢ ...) body ...) lᵢ ...)
+     (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: copy the error message from map.
+                       (error "all lists must have same size"))
+                     '())
+                   ;; 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 (list (let ([argᵢ (car upcast-lᵢ)]
+                                                    ...)
+                                                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.
+                               (error "all lists must have same size"))
+                             (void))
+                           (begin (set! upcast-result
+                                        (cons (let ([argᵢ (car l-loopᵢ)]
+                                                    ...)
+                                                body ...)
+                                              upcast-result))
+                                  (loop (cdr l-loopᵢ) ...))))
+                     (reverse upcast-result)))))))]
+    [(_ f lᵢ ...)
+     ;; TODO: multiple l
+     (with-syntax ([(argᵢ ...) (generate-temporaries #'(lᵢ ...))])
+       #'(map (λ (argᵢ ...) (f argᵢ ...)) lᵢ ...))]))

scribblings/typed-map.scrbl

@@ -0,0 +1,75 @@
+#lang scribble/manual
+@require[scribble/example
+         @for-label[typed-map]]
+
+@title{typed-map}
+@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
+
+@(module orig racket/base
+   (require scribble/manual
+            (for-label racket/base))
+   (provide orig:map)
+   (define orig:map @racket[map]))
+@(require 'orig)
+
+@defmodule[typed-map]
+
+@defproc[#:kind "syntax"
+         (map [f (→ A ... B)] [l (Listof A)] ...) (Listof B)]{
+ Like @orig:map, but with better type inference for Typed Racket.
+ 
+ When @racket[f] is a literal lambda of the form
+ @racket[(λ (arg ...) body ...)], it is not necessary to specify the type of
+ the arguments, as they will be inferred from the list.
+
+ @examples[#:eval ((make-eval-factory '(typed-map) #:lang 'typed/racket))
+           (map (λ (x) (* x 2)) '(1 2 3))
+           (let ([l '(4 5 6)])
+             (map (λ (x) (* x 2)) l))]
+
+ This enables the use of @racket[#,hash-lang afl] for @racket[map] in Typed
+ Racket.
+
+ Furthermore, when @racket[f] is a polymorphic function, type annotations are
+ not needed:
+
+ @examples[#:eval ((make-eval-factory '(typed-map) #:lang 'typed/racket))
+           (map car '([a . 1] [b . 2] [c . 3]))]
+
+ Compare this with the behaviour of @orig:map from
+ @racketmodname[racket/base], which generates a type error:
+ 
+ @examples[#:eval ((make-eval-factory '() #:lang 'typed/racket))
+           (eval:alts (#,orig:map car '([a . 1] [b . 2] [c . 3]))
+                      (eval:error (map car '([a . 1] [b . 2] [c . 3]))))]
+
+ When used as an identifier, the @racket[map] macro expands to the original
+ @orig:map from @racketmodname[racket/base]:
+
+ @examples[#:eval ((make-eval-factory '(typed-map) #:lang 'typed/racket))
+           (require (only-in racket/base [map orig:map]))
+           (equal? map orig:map)]
+
+ Note that the implementation expands to a large expression, and makes use of
+ @racket[set!] internally to build the result list. The trick used proceeds as
+ follows:
+ @itemlist[
+ @item{It uses @racket[(reverse (reverse l))] to generalise the type of the
+   list, without having to express that type, so that Type / Racket infers a
+   more general type of the form @racket[(Listof A)], without detecting that the
+   output is identical to the input. An unoptimizable guard prevents the
+   double-reverse from actually being executed, so it does not incur a
+   performance cost.}
+ @item{It uses a named let to perform the loop the function @racket[f] is
+   never passed as an argument to another polymorphic function, and is instead
+   directly called with the appropriate arguments. The error message
+   "Polymorphic function `map' could not be applied to arguments" is therefore
+   not raised.}
+ @item{To have the most precise and correct types, it uses a named let with a
+   single variable containing the list (with the generalized type). An outer let
+   binds a mutable accumulator, initialized with a single-element list
+   containing the result of applying @racket[f] on the first element of the
+   list. Since all elements of the list belong to the generalized type, the
+   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].}]}

test/test-map.rkt

@@ -0,0 +1,37 @@
+#lang afl typed/racket
+
+(require typed-map)
+
+;; without ann
+(let ()
+  (map (λ (x) (* x 2)) '())
+  (map (λ (x) (* x 2)) '(1))
+  (map (λ (x) (* x 2)) '(1 2))
+  (map (λ (x) (* x 2)) '(1 2 3))
+  (map + '(1 2 3) '(4 5 6))
+  (map car '((1 2) (3 4)))
+  (map #λ(+ % 1) '(1 2 3))
+
+  ;; used as a function (identifier macro), looses the inference abilities
+  (map map (list add1 sub1) '((1 2 3) (4 5 6)))
+  (map map
+       (ann (list car cdr) (Listof (→ (List Number) (U Number Null))))
+       '(((1) (2) (3)) ((4) (5) (6))))
+
+  (λ #:∀ (A) ([l : (Listof A)])
+    (map (λ (x) x) l))
+
+  (void))
+
+;; with ann
+(ann (map (λ (x) (* x 2)) '()) Null)
+(ann (map (λ (x) (* x 2)) '(1)) (Listof Positive-Byte))
+(ann (map (λ (x) (* x 2)) '(1 2)) (Listof Positive-Index))
+(ann (map (λ (x) (* x 2)) '(1 2 3)) (Listof Positive-Index))
+(ann (map + '(1 2 3) '(4 5 6)) (Listof Positive-Index))
+(ann (map car '((1 2) (3 4))) (Listof Positive-Byte))
+(ann (map #λ(+ % 1) '(1 2 3)) (Listof Positive-Index))
+
+(ann (λ #:∀ (A) ([l : (Listof A)])
+       (map (λ (x) x) l))
+     (∀ (A) (→ (Listof A) (Listof A))))