commit 66b41f4a21d39e539632099200751e3002ac2a62
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sat, 15 Oct 2016 05:35:20 +0200
Initial commit
Diffstat:
8 files changed, 289 insertions(+), 0 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -0,0 +1,6 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/doc/
diff --git a/.travis.yml b/.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 .
diff --git a/LICENSE.txt b/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.
diff --git a/README.md b/README.md
@@ -0,0 +1,10 @@
+[](https://travis-ci.org/jsmaniac/typed-map)
+[](https://coveralls.io/github/jsmaniac/typed-map)
+[](http://jsmaniac.github.io/travis-stats/#jsmaniac/typed-map)
+[](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.
+\ No newline at end of file
diff --git a/info.rkt b/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"))
diff --git a/main.rkt b/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ᵢ ...))]))
diff --git a/scribblings/typed-map.scrbl b/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].}]}
diff --git a/test/test-map.rkt b/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))))
