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

Squashed old commits.

Browse Source
This commit is contained in:
Georges Dupéron 2016-10-08 23:19:27 +02:00
commit fb38440010
21 changed files with 1399 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.gitignore vendored Normal file
View File

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

32
.travis.yml Normal file
View File

@ -0,0 +1,32 @@
language: c
sudo: false
env:
global:
# RACKET_DIR is an argument to install-racket.sh
- RACKET_DIR=~/racket
- PATH="$RACKET_DIR/bin:$PATH"
matrix:
# RACKET_VERSION is an argument to install-racket.sh
- RACKET_VERSION=6.4
- RACKET_VERSION=6.5
- RACKET_VERSION=6.6
- RACKET_VERSION=6.7
- RACKET_VERSION=6.8
- RACKET_VERSION=RELEASE
- RACKET_VERSION=HEAD
before_install:
- curl -L https://raw.githubusercontent.com/greghendershott/travis-racket/master/install-racket.sh | bash
- raco pkg install --deps search-auto doc-coverage cover cover-codecov # or cover-coveralls
install:
- raco pkg install --deps search-auto -j 2
script:
- raco test -x -p "$(basename "$TRAVIS_BUILD_DIR")"
- raco setup --check-pkg-deps --no-zo --no-launcher --no-install --no-post-install --no-docs --pkgs "$(basename "$TRAVIS_BUILD_DIR")"
- raco doc-coverage "$(basename "$TRAVIS_BUILD_DIR")"
- raco cover -s main -s test -s doc -f codecov -f html -d ~/coverage . || true
# TODO: add an option to cover to run the "outer" module too, not just the submodules.
# TODO: deploy the coverage info.

24
LICENSE-more.md Normal file
View File

@ -0,0 +1,24 @@
anaphoric
Copyright (c) 2016-2017 Georges Dupéron
This package is in distributed under the Creative Commons CC0 license
https://creativecommons.org/publicdomain/zero/1.0/, as specified by
the LICENSE.txt file.
The CC0 license is equivalent to a dedication to the Public Domain
in most countries, but is also effective in countries which do not
recognize explicit dedications to the Public Domain.
In order to avoid any potential licensing issues, this package is explicitly
distributed under the Creative Commons CC0 license
https://creativecommons.org/publicdomain/zero/1.0/, or under the GNU Lesser
General Public License (LGPL) https://opensource.org/licenses/LGPL-3.0, or
under the Apache License Version 2.0
https://opensource.org/licenses/Apache-2.0, or under the MIT license
https://opensource.org/licenses/MIT, at your option.

116
LICENSE.txt Normal file
View File

@ -0,0 +1,116 @@
CC0 1.0 Universal
Statement of Purpose
The laws of most jurisdictions throughout the world automatically confer
exclusive Copyright and Related Rights (defined below) upon the creator and
subsequent owner(s) (each and all, an "owner") of an original work of
authorship and/or a database (each, a "Work").
Certain owners wish to permanently relinquish those rights to a Work for the
purpose of contributing to a commons of creative, cultural and scientific
works ("Commons") that the public can reliably and without fear of later
claims of infringement build upon, modify, incorporate in other works, reuse
and redistribute as freely as possible in any form whatsoever and for any
purposes, including without limitation commercial purposes. These owners may
contribute to the Commons to promote the ideal of a free culture and the
further production of creative, cultural and scientific works, or to gain
reputation or greater distribution for their Work in part through the use and
efforts of others.
For these and/or other purposes and motivations, and without any expectation
of additional consideration or compensation, the person associating CC0 with a
Work (the "Affirmer"), to the extent that he or she is an owner of Copyright
and Related Rights in the Work, voluntarily elects to apply CC0 to the Work
and publicly distribute the Work under its terms, with knowledge of his or her
Copyright and Related Rights in the Work and the meaning and intended legal
effect of CC0 on those rights.
1. Copyright and Related Rights. A Work made available under CC0 may be
protected by copyright and related or neighboring rights ("Copyright and
Related Rights"). Copyright and Related Rights include, but are not limited
to, the following:
i. the right to reproduce, adapt, distribute, perform, display, communicate,
and translate a Work;
ii. moral rights retained by the original author(s) and/or performer(s);
iii. publicity and privacy rights pertaining to a person's image or likeness
depicted in a Work;
iv. rights protecting against unfair competition in regards to a Work,
subject to the limitations in paragraph 4(a), below;
v. rights protecting the extraction, dissemination, use and reuse of data in
a Work;
vi. database rights (such as those arising under Directive 96/9/EC of the
European Parliament and of the Council of 11 March 1996 on the legal
protection of databases, and under any national implementation thereof,
including any amended or successor version of such directive); and
vii. other similar, equivalent or corresponding rights throughout the world
based on applicable law or treaty, and any national implementations thereof.
2. Waiver. To the greatest extent permitted by, but not in contravention of,
applicable law, Affirmer hereby overtly, fully, permanently, irrevocably and
unconditionally waives, abandons, and surrenders all of Affirmer's Copyright
and Related Rights and associated claims and causes of action, whether now
known or unknown (including existing as well as future claims and causes of
action), in the Work (i) in all territories worldwide, (ii) for the maximum
duration provided by applicable law or treaty (including future time
extensions), (iii) in any current or future medium and for any number of
copies, and (iv) for any purpose whatsoever, including without limitation
commercial, advertising or promotional purposes (the "Waiver"). Affirmer makes
the Waiver for the benefit of each member of the public at large and to the
detriment of Affirmer's heirs and successors, fully intending that such Waiver
shall not be subject to revocation, rescission, cancellation, termination, or
any other legal or equitable action to disrupt the quiet enjoyment of the Work
by the public as contemplated by Affirmer's express Statement of Purpose.
3. Public License Fallback. Should any part of the Waiver for any reason be
judged legally invalid or ineffective under applicable law, then the Waiver
shall be preserved to the maximum extent permitted taking into account
Affirmer's express Statement of Purpose. In addition, to the extent the Waiver
is so judged Affirmer hereby grants to each affected person a royalty-free,
non transferable, non sublicensable, non exclusive, irrevocable and
unconditional license to exercise Affirmer's Copyright and Related Rights in
the Work (i) in all territories worldwide, (ii) for the maximum duration
provided by applicable law or treaty (including future time extensions), (iii)
in any current or future medium and for any number of copies, and (iv) for any
purpose whatsoever, including without limitation commercial, advertising or
promotional purposes (the "License"). The License shall be deemed effective as
of the date CC0 was applied by Affirmer to the Work. Should any part of the
License for any reason be judged legally invalid or ineffective under
applicable law, such partial invalidity or ineffectiveness shall not
invalidate the remainder of the License, and in such case Affirmer hereby
affirms that he or she will not (i) exercise any of his or her remaining
Copyright and Related Rights in the Work or (ii) assert any associated claims
and causes of action with respect to the Work, in either case contrary to
Affirmer's express Statement of Purpose.
4. Limitations and Disclaimers.
a. No trademark or patent rights held by Affirmer are waived, abandoned,
surrendered, licensed or otherwise affected by this document.
b. Affirmer offers the Work as-is and makes no representations or warranties
of any kind concerning the Work, express, implied, statutory or otherwise,
including without limitation warranties of title, merchantability, fitness
for a particular purpose, non infringement, or the absence of latent or
other defects, accuracy, or the present or absence of errors, whether or not
discoverable, all to the greatest extent permissible under applicable law.
c. Affirmer disclaims responsibility for clearing rights of other persons
that may apply to the Work or any use thereof, including without limitation
any person's Copyright and Related Rights in the Work. Further, Affirmer
disclaims responsibility for obtaining any necessary consents, permissions
or other rights required for any use of the Work.
d. Affirmer understands and acknowledges that Creative Commons is not a
party to this document and has no duty or obligation with respect to this
CC0 or use of the Work.
For more information, please see
<http://creativecommons.org/publicdomain/zero/1.0/>

11
README.md Normal file
View File

@ -0,0 +1,11 @@
[![Build Status,](https://img.shields.io/travis/jsmaniac/delay-pure/master.svg)](https://travis-ci.org/jsmaniac/delay-pure)
[![Coverage Status,](https://img.shields.io/coveralls/jsmaniac/delay-pure/master.svg)](https://coveralls.io/github/jsmaniac/delay-pure)
[![Build Stats,](https://img.shields.io/badge/build-stats-blue.svg)](http://jsmaniac.github.io/travis-stats/#jsmaniac/delay-pure)
[![Online Documentation.](https://img.shields.io/badge/docs-online-blue.svg)](http://docs.racket-lang.org/delay-pure/)
[![License: CC0 v1.0.](https://img.shields.io/badge/license-CC0-blue.svg)](https://creativecommons.org/publicdomain/zero/1.0/)
delay-pure
==========
Non-cached promises for Typed/Racket, like delay/name. Should be sound for
occurrence typing (unlike delay/name) because only pure functions are allowed.

18
info.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang info
(define collection "delay-pure")
(define deps '("base"
"rackunit-lib"
"typed-racket-lib"
"typed-racket-more"
"type-expander"
"phc-toolkit"))
(define build-deps '("scribble-lib"
"racket-doc"
"typed-racket-doc"))
(define scribblings '(("scribblings/delay-pure.scrbl" () ("typed-racket"))))
(define pkg-desc
(string-append "Non-cached promises for Typed/Racket, like delay/name."
" Should be sound for occurrence typing (unlike"
" delay/name) because only pure functions are allowed."))
(define version "1.0")
(define pkg-authors '("Georges Dupéron"))

25
main.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket/base
(require "private/pure-safe.rkt"
"private/pure-function.rkt"
"private/pure-exception.rkt")
(provide promise/pure/maybe-stateful?
promise/pure/stateless?
delay/pure/stateful
delay/pure/stateless
pure/stateful
pure/stateless
pure-thunk/stateful
pure-thunk/stateless
define-pure/stateful
define-pure/stateless
immutable/stateful/c
immutable/stateless/c
built-in-pure-functions-set
(for-syntax built-in-pure-functions-free-id-set)
unsafe-pure/stateless
unsafe-operation/mutating
unsafe-declare-pure/stateless
unsafe-declare-allowed-in-pure/stateful)

98
private/fully-expanded-grammar-no-set.rkt Normal file
View File

@ -0,0 +1,98 @@
#lang racket/base
;; This file is not used by the project, but can be used as a base for macros
;; which need to parse the result of local-expand. For example, the file
;; fully-expanded-grammar-extract-bindings.rkt is based on this one.
(require (rename-in syntax/parse [...+ …+])
(rename-in racket/base [... …])
(for-template '#%kernel)
(for-syntax racket/base))
(provide disallow-set!-in-expression)
(define whole-expr (make-parameter #f))
(define (disallow-set!-in-expression e)
(parameterize ([whole-expr e])
(syntax-parse e [:expr 'ok])))
(define-syntax-class top-level-form
#:literals (#%expression module #%plain-module-begin begin begin-for-syntax)
(pattern :general-top-level-form)
(pattern (#%expression :expr))
(pattern (module :id _module-path
(#%plain-module-begin
:module-level-form …)))
(pattern (begin :top-level-form …))
(pattern (begin-for-syntax :top-level-form …)))
(define-syntax-class module-level-form
#:literals (#%provide begin-for-syntax #%declare)
(pattern :general-top-level-form)
(pattern (#%provide _raw-provide-spec …))
(pattern (begin-for-syntax :module-level-form …))
(pattern :submodule-form)
(pattern (#%declare _declaration-keyword …)))
(define-syntax-class submodule-form
#:literals (module #%plain-module-begin module* )
(pattern (module :id _module-path
(#%plain-module-begin
:module-level-form …)))
(pattern (module* :id _module-path
(#%plain-module-begin
:module-level-form …)))
(pattern (module* :id #f
(#%plain-module-begin
:module-level-form …))))
(define-syntax-class general-top-level-form
#:literals (define-values define-syntaxes #%require)
(pattern :expr)
(pattern (define-values (:id …) :expr))
(pattern (define-syntaxes (:id …) :expr))
(pattern (#%require _raw-require-spec …)))
(define-syntax-class expr
#:literals (lambda case-lambda if begin begin0
let-values letrec-values letrec-syntaxes+values
set! quote quote-syntax
with-continuation-mark
#%app #%top #%expression #%variable-reference)
(pattern :id)
(pattern (lambda :formals :expr …+))
(pattern (case-lambda (:formals :expr …+) …))
(pattern (if :expr :expr :expr))
(pattern (begin :expr …+))
(pattern (begin0 :expr :expr …))
(pattern (let-values ([(:id …) :expr] …)
:expr …+))
(pattern (letrec-values ([(:id …) :expr] …)
:expr …+))
(pattern (letrec-syntaxes+values ([(:id …) :expr] …)
([(:id …) :expr] …)
:expr …+))
(pattern {~and whole-set ({~and set-id set!} :id :expr)}
#:do [(raise-syntax-error
'pure
"set! is disallowed within pure/stateless and similar forms"
#'whole-expr
#'whole-set
(list #'set-id))])
(pattern (quote _datum))
(pattern (quote-syntax _datum))
(pattern (quote-syntax _datum #:local))
(pattern (with-continuation-mark :expr :expr :expr))
(pattern (#%app :expr …+))
(pattern (#%top . :id))
(pattern (#%expression :expr))
(pattern (#%variable-reference :id))
(pattern (#%variable-reference (#%top . :id)))
(pattern (#%variable-reference)))
(define-syntax-class formals
(pattern (:id …))
(pattern (:id …+ . :id))
(pattern :id))

104
private/immutable-struct-constructor.rkt Normal file
View File

@ -0,0 +1,104 @@
#lang typed/racket
(require typed/racket/unsafe
(for-syntax racket/struct-info
racket/list
racket/function)
(for-template phc-toolkit/untyped/meta-struct)
phc-toolkit)
(unsafe-require/typed racket/base
[struct-constructor-procedure? (→ Any Boolean)])
(provide immutable-struct-constructor?)
(: immutable-struct-constructor? (→ Any Variable-Reference Boolean))
(define (immutable-struct-constructor? v vr)
(and (struct-constructor-procedure? v)
(let ([s-name (object-name v)])
(and (symbol? s-name)
(or (immutable-struct?/symbol s-name v vr)
(let ([mk-s (regexp-match #px"^make-(.*)$"
(symbol->string s-name))])
(and mk-s (pair? (cdr mk-s)) (cadr mk-s)
(let ([sym (string->symbol (cadr mk-s))])
(immutable-struct?/symbol sym v vr)))))))))
(define-syntax (meta-struct-immutable stx)
(syntax-case stx ()
[(_ ident)
(let ()
(define slv (syntax-local-value #'ident (λ () #f)))
(if (and slv
(struct-info? slv)
(let ([esi (extract-struct-info slv)])
(and (last (fourth esi))
(not (ormap identity (fifth esi))))))
#'#t
#'#f))]))
(define-syntax (meta-struct-type-descriptor stx)
(syntax-case stx ()
[(_ ident)
(let ()
(define slv (syntax-local-value #'ident (λ () #f)))
#`#,(and slv
(struct-info? slv)
(first (extract-struct-info slv))))]))
(define-syntax (meta-struct-constructor stx)
(syntax-case stx ()
[(_ ident)
(let ()
(define slv (syntax-local-value #'ident (λ () #f)))
#`#,(and slv
(struct-info? slv)
(second (extract-struct-info slv))))]))
(define (raco-test-exn? [e : exn:fail:contract])
;; See TR issue #439 at https://github.com/racket/typed-racket/issues/439
(regexp-match #px"Attempted to use a struct type reflectively in untyped code"
(exn-message e)))
(: immutable-struct?/symbol (→ Symbol Any Variable-Reference Boolean))
(define (immutable-struct?/symbol sym ctor vr)
(define meta-result
(call-with-values
(λ ()
(eval `(,#'list* (,#'meta-struct-immutable ,sym)
(,#'meta-struct-type-descriptor ,sym)
(,#'meta-struct-constructor ,sym))
(variable-reference->namespace vr)))
(λ l l)))
(and (pair? meta-result)
(pair? (car meta-result))
(pair? (cdar meta-result))
(let ([meta-probably-immutable? (equal? (caar meta-result) #t)]
[meta-descriptor (cadar meta-result)]
[meta-constructor (cddar meta-result)])
(and meta-probably-immutable?
meta-descriptor
(struct-type? meta-descriptor)
;; double-check, meta-probably-immutable? could be true if we
;; use a constructor named make-st, but st is actually bound to a
;; different struct.
(let ([try-immutable-struct-type
: (U #t #f 'raco-test-exn)
(with-handlers ([exn:fail:contract?
(λ ([e : exn:fail:contract])
(if (raco-test-exn? e)
'raco-test-exn
#f))])
(if (struct-type-is-immutable? meta-descriptor)
#t
#f))])
(cond
[(eq? try-immutable-struct-type #t)
;; double-check that the heuristic worked, and that the
;; guessed struct's constructor is indeed the original one:
(eq? meta-constructor ctor)]
[(eq? try-immutable-struct-type 'raco-test-exn)
;; the (eq? meta-constructor ctor) does not work properly
;; with raco test either
#t]
[(eq? try-immutable-struct-type #f)
#f]))))))

30
private/pure-exception.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang typed/racket
(provide unsafe-pure-block/stateless
unsafe-operation-block/mutating
unsafe-pure/stateless
unsafe-operation/mutating)
(module m typed/racket
(provide unsafe-pure-block/stateless
unsafe-operation-block/mutating)
(define-syntax-rule (unsafe-pure-block/stateless . body)
(λ () . body))
(define-syntax-rule (unsafe-operation-block/mutating . body)
(λ () . body)))
(require 'm)
(define-syntax (unsafe-pure/stateless stx)
(syntax-case stx ()
[(_ . body)
(with-syntax ([lifted-id (syntax-local-lift-expression
#'(unsafe-pure-block/stateless . body))])
#'(lifted-id))]))
(define-syntax (unsafe-operation/mutating stx)
(syntax-case stx ()
[(_ . body)
(with-syntax ([lifted-id (syntax-local-lift-expression
#'(unsafe-operation-block/mutating . body))])
#'(lifted-id))]))

375
private/pure-function.rkt Normal file
View File

@ -0,0 +1,375 @@
#lang typed/racket/base
(require "immutable-struct-constructor.rkt"
"pure-exception.rkt"
racket/set
racket/format
racket/promise
(only-in typed/racket/unsafe unsafe-require/typed)
(prefix-in te: type-expander)
phc-toolkit
(for-syntax (rename-in racket/base [... …])
racket/list
racket/syntax
racket/contract
syntax/parse
syntax/id-set
syntax/free-vars
type-expander/expander
phc-toolkit/untyped
"fully-expanded-grammar-no-set.rkt"))
(unsafe-require/typed
"pure-unsafe.rkt"
[promise/pure/maybe-stateful? (→ Any Boolean : Promise)]
[promise/pure/stateless? (→ Any Boolean : Promise)]
[make-promise/pure/stateful (∀ (a) (→ (→ a) (Promise a)))]
[make-promise/pure/stateless (∀ (a) (→ (→ a) (Promise a)))]
[declared-stateful-pure-function? (→ Any Boolean)]
[declared-stateless-pure-function? (→ Any Boolean)]
[declared-stateful-pure-function (∀ (A) (→ A A))]
[declared-stateless-pure-function (∀ (A) (→ A A))])
(unsafe-require/typed
racket/base
;; The type of vector->list was fixed by PR #437, the unsafe-require/typed
;; is left for compatibility with earlier versions.
[vector->list (∀ (a) (case→ (→ (Vectorof a) (Listof a))
(→ VectorTop (Listof Any))))]
[struct-constructor-procedure? (→ Any Boolean)]
[struct-predicate-procedure? (→ Any Boolean)]
[struct-accessor-procedure? (→ Any Boolean)])
(unsafe-require/typed racket/struct
[[struct->list unsafe-struct->list]
(→ Any (Listof Any))])
(provide pure/stateful
pure/stateless
pure-thunk/stateful
pure-thunk/stateless
define-pure/stateful
define-pure/stateless
built-in-pure-functions-set
(for-syntax built-in-pure-functions-free-id-set)
promise/pure/maybe-stateful?
promise/pure/stateless?
immutable/stateful/c
immutable/stateless/c
unsafe-declare-pure/stateless
unsafe-declare-allowed-in-pure/stateful)
(define-for-syntax built-in-pure-functions-free-id-set
(immutable-free-id-set
(syntax->list
#'(+ - * / modulo add1 sub1;; …
error
format values
promise/pure/maybe-stateful? promise/pure/stateless?
;; Does not have a type yet:
;; list*
cons car cdr list list? pair? length reverse ;; …
vector-ref vector-immutable vector-length vector->list vector? ;; …
hash-ref hash->list hash? ;; …
set-member? set->list set? ;; …
;; allow force, because we only allow capture of free variables
;; containing pure stateless promises, which are therefore safe
;; to force.
force
;; …
))))
(define-for-syntax (built-in-pure-function? id)
(free-id-set-member? built-in-pure-functions-free-id-set id))
(define-syntax (def-built-in-set stx)
(syntax-case stx ()
[(_ name)
#`(define name
(seteq . #,(free-id-set->list built-in-pure-functions-free-id-set)))]))
(def-built-in-set built-in-pure-functions-set)
(begin
(define-for-syntax unsafe-pure-functions-free-id-set/stateless
(mutable-free-id-set))
(: rw-unsafe-pure-functions-set/stateless (Boxof (Setof Procedure)))
(define rw-unsafe-pure-functions-set/stateless (box ((inst set Procedure))))
(define (unsafe-pure-functions-set/stateless)
(unbox rw-unsafe-pure-functions-set/stateless))
(define-syntax (unsafe-declare-pure/stateless stx)
(syntax-case stx ()
[(_ fn)
(begin
(free-id-set-add! unsafe-pure-functions-free-id-set/stateless #'fn)
#'(set-box! rw-unsafe-pure-functions-set/stateless
(set-add fn)))]))
(define-for-syntax (unsafe-pure-function?/stateless id)
(free-id-set-member? unsafe-pure-functions-free-id-set/stateless id)))
(begin
(define-for-syntax unsafe-allowed-functions-free-id-set/stateful
(mutable-free-id-set))
(: rw-unsafe-allowed-functions-set/stateful (Boxof (Setof Procedure)))
(define rw-unsafe-allowed-functions-set/stateful (box ((inst set Procedure))))
(define (unsafe-allowed-functions-set/stateful)
(unbox rw-unsafe-allowed-functions-set/stateful))
(define-syntax (unsafe-declare-allowed-in-pure/stateful stx)
(syntax-case stx ()
[(_ fn)
(identifier? #'fn)
(begin
(free-id-set-add! unsafe-allowed-functions-free-id-set/stateful #'fn)
#'(set-box! rw-unsafe-allowed-functions-set/stateful
(set-add fn)))]))
(define-for-syntax (unsafe-allowed-function?/stateful id)
(free-id-set-member? unsafe-allowed-functions-free-id-set/stateful id)))
(: check-immutable/error (→ Variable-Reference
(U 'stateful 'stateless)
(→ Any Boolean)))
(define ((check-immutable/error varref stateful/stateless) x)
(check-immutable!
x
varref
stateful/stateless
(λ () (error (~a "The " x " value was used within a free variable of a pure"
" expression or as the result of a pure thunk, but it is"
" not immutable.")))
(λ () (error (~a "The " x " value was used within a free variable of a pure"
" expression or as the result of a pure thunk, but I could"
" not verify that it is immutable.")))))
(: check-immutable! (→ Any
Variable-Reference
(U 'stateful 'stateless)
(→ Void)
(→ Void)
Boolean))
(define (check-immutable! x varref stateful/stateless not-immutable other)
(define (recur y)
(check-immutable! y varref stateful/stateless not-immutable other))
(define-syntax-rule (assert x p)
(if (p x) #t (begin (not-immutable) #f)))
(cond
;; Primitives without recursion
[(null? x) #t]
[(boolean? x) #t]
[(number? x) #t]
[(symbol? x) #t]
;; De facto immutable, with recursion
[(pair? x) (and (recur (car x))
(recur (cdr x)))]
[(set? x) (recur (set->list x))]
;; Might be immutable, with recursion
[(string? x) (assert x immutable?)]
[(bytes? x) (assert x immutable?)]
[(box? x) (and (assert x immutable?)
(recur x))]
[(vector? x) (assert x immutable?)
(recur (vector->list x))]
[(hash? x) (and (assert x immutable?)
(recur (hash->list x)))]
[(set? x) (recur (set->list x))]
;; Structs:
[(struct? x) (and (struct-instance-is-immutable? x)
(recur (unsafe-struct->list x)))]
;; Pure functions
[((if (eq? stateful/stateless 'stateful)
declared-stateful-pure-function?
declared-stateless-pure-function?) x) #t]
[(set-member? built-in-pure-functions-set x) #t]
[(set-member? (unsafe-pure-functions-set/stateless) x) #t]
;; delay/pure is only used in a safe way, unless the user requires
;; private files
[(eq? x make-promise/pure/stateful) #t]
[(eq? x make-promise/pure/stateless) #t]
;; Pure promises
;; We disallow (promise/pure/maybe-stateful? x) because if forced again,
;; the outside code may have a handle into some mutable data that we then
;; use. promise/pure/stateless? is fine.
[(promise/pure/stateless? x) #t]
;; accept struct construtors only if we can guarantee that the struct is
;; immutable (this means that the constructor's (object-name) must be
;; either 'st or 'make-st, where st is the struct type's name.
[(immutable-struct-constructor? x varref) #t]
[(struct-predicate-procedure? x) #t]
[(struct-accessor-procedure? x) #t]
;; To allow pure functions which return pure functions, we need to allow
;; check-immutable/c itself
[(eq? x check-immutable/error) #t]
;; Otherwise, fail early before mutation causes problems
[else (begin (other) #f)]))
(: immutable/stateful/c (→ Variable-Reference (→ Any Boolean)))
(define ((immutable/stateful/c varref) x)
(check-immutable! x varref 'stateful void void))
(: immutable/stateless/c (→ Variable-Reference (→ Any Boolean)))
(define ((immutable/stateless/c varref) x)
(check-immutable! x varref 'stateless void void))
(define-for-syntax (make-no-set!-transformer id)
(λ (stx)
(syntax-case stx (set!)
[(set-id . rest)
(free-identifier=? #'set-id #'set!)
(raise-syntax-error
'pure
(format (string-append "set! cannot be used in a pure expression to"
" mutate the free identifier ~a")
(syntax-e id))
stx
#'set-id)]
[self (identifier? #'self) id]
[(self . args)
(identifier? #'self)
(datum->syntax (syntax-local-identifier-as-binding #'self)
`(,id . ,#'args))])))
(begin-for-syntax
(define/contract (pure-impl self fn-stx check-result? stateful/stateless-sym)
(-> syntax? syntax? (or/c #f 'check-result) (or/c 'stateful 'stateless)
syntax?)
(define/with-syntax fn fn-stx)
(define/with-syntax stateful/stateless stateful/stateless-sym)
(define/with-syntax fully-expanded+lifts
;; TODO: stop on make-predicate (and remove those before free-vars,
;; they are safe)
(local-expand/capture-lifts #'fn 'expression '()))
(define/with-syntax (fully-expanded (marked-as-unsafe ...))
(syntax-case #'fully-expanded+lifts (begin)
[(begin single-expression) #'(single-expression ())]
[(begin lifted ... expression)
(for-each (λ (lifted1)
(syntax-case lifted1 (define-values
unsafe-pure-block/stateless
unsafe-operation-block/mutating)
[(define-values (_)
(unsafe-pure-block/stateless . rest))
#t]
[(define-values (_)
(unsafe-operation-block/mutating . rest))
(if (not (eq? stateful/stateless-sym 'stateful))
(raise-syntax-error
'pure
(format
(string-append "unsafe-operation/mutating"
" disallowed within"
" pure/stateless:\n~a")
(syntax->datum lifted1))
#'fn
lifted1)
#t)]
[_
(raise-syntax-error
'pure
(format
(string-append "lifted expressions are disallowed"
" within pure/stateful, pure/stateless"
" and similar forms (for now):\n~a")
(syntax->datum lifted1))
#'fn
lifted1)]))
(syntax->list #'(lifted ...)))
#'(expression (lifted ...))]))
(define marked-as-unsafe-ids
(immutable-free-id-set
(syntax-case #'(marked-as-unsafe ...) (define-values)
[((define-values (id ...) _expr) ...)
(syntax->list #'(id ... ...))])))
(when (eq? stateful/stateless-sym 'stateless)
(disallow-set!-in-expression #'fully-expanded))
(define/with-syntax (free …)
(filter-not (λ (x)
(or (built-in-pure-function? x)
(unsafe-pure-function?/stateless x)
(and (eq? stateful/stateless-sym 'stateful)
(unsafe-allowed-function?/stateful x))
(free-id-set-member? marked-as-unsafe-ids x)))
(free-vars #'fully-expanded #:module-bound? #t)))
(define/with-syntax (cached …) (generate-temporaries #'(free …)))
(define/with-syntax varref (datum->syntax self `(#%variable-reference)))
;; Prevent the mutation of the cached copy, by making it a macro which
;; rejects uses as the target of a set! .
#`(let ()
marked-as-unsafe ...
(let ([free free] …)
(let-syntax ([free (make-no-set!-transformer #'free)] …)
;; The input should always be stateless
(assert free (check-immutable/error varref 'stateless))
…
;; The result must be pure too, otherwise it could (I
;; suppose) cause problems with occurrence typing, if a
;; copy if mutated but not the other, and TR still
;; expects them to be equal?
;; By construction, it should be immutable, except for functions
;; (which can hold internal state), but TR won't assume that when
;; called twice, the same function will return the same result. For
;; extra security, the result is checked if #:check-result is
;; specified. Note that when #:check-result is specified, the pure
;; thunk cannot return functions.
#,(if check-result?
#'(λ ()
(let ([result (fully-expanded)])
;; The output may be stateful
(assert result
(check-immutable/error varref
'stateful/stateless))
result))
#'fully-expanded))))))
(define-syntax (pure/stateful stx)
(syntax-case stx ()
[(self expr) (pure-impl #'self #'expr #f 'stateful)]))
(define-syntax (pure/stateless stx)
(syntax-case stx ()
[(self expr) (pure-impl #'self #'expr #f 'stateless)]))
(define-syntax (pure-thunk/stateful stx)
(syntax-case stx ()
[(self fn) (pure-impl #'self #'fn #f 'stateful)]
[(self fn #:check-result) (pure-impl #'self #'fn 'check-result 'stateful)]))
(define-syntax (pure-thunk/stateless stx)
(syntax-case stx ()
[(self fn) (pure-impl #'self #'fn #f 'stateless)]
[(self fn #:check-result) (pure-impl #'self #'fn 'check-result 'stateless)])
)
(define-for-syntax (define-pure/impl stateful/stateless-sym)
(syntax-parser
[(self {~optional {~seq {~and fa #:∀} tvars}}
(name . args)
(~optional (~seq C:colon result-type))
body …)
#:with lam (if (free-identifier=? (datum->syntax #'self 'λ) #'te:λ)
#'te:λ
#'λ)
#:with (maybe-result-type …) (if (attribute result-type)
#'(C result-type)
#'())
#:with pure/? (if (eq? stateful/stateless-sym 'stateful)
#'pure/stateful
#'pure/stateless)
#:with declared-wrapper (if (eq? stateful/stateless-sym 'stateful)
#'declared-stateful-pure-function
#'declared-stateless-pure-function)
(quasisyntax/top-loc this-syntax
(define name
(declared-wrapper
(lam #,@(when-attr tvars #'(fa tvars)) args maybe-result-type …
(pure/? (let () body …))))))]))
(define-syntax define-pure/stateful (define-pure/impl 'stateful))
(define-syntax define-pure/stateless (define-pure/impl 'stateless))

36
private/pure-safe.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang typed/racket
(provide promise/pure/maybe-stateful?
promise/pure/stateless?
delay/pure/stateful
delay/pure/stateless)
(require typed/racket/unsafe
"pure-function.rkt"
racket/private/promise
(for-syntax racket/base
syntax/parse
phc-toolkit/untyped))
(unsafe-require/typed
"pure-unsafe.rkt"
[make-promise/pure/stateful (∀ (a) (→ (→ a) (Promise a)))]
[make-promise/pure/stateless (∀ (a) (→ (→ a) (Promise a)))])
(define-syntax (delay/pure/stateful/unsafe stx)
(make-delayer stx #'make-promise/pure/stateful '()))
(define-syntax (delay/pure/stateless/unsafe stx)
(make-delayer stx #'make-promise/pure/stateless '()))
(define-syntax delay/pure/stateful
(syntax-parser
[(_ e)
(syntax/top-loc this-syntax
(delay/pure/stateful/unsafe (pure/stateful e)))]))
(define-syntax delay/pure/stateless
(syntax-parser
[(_ e)
(syntax/top-loc this-syntax
(delay/pure/stateless/unsafe (pure/stateless e)))]))

25
private/pure-unsafe.rkt Normal file
View File

@ -0,0 +1,25 @@
#lang racket
(require racket/promise
racket/private/promise
(for-syntax racket/base))
(provide (rename-out [promise/pure/stateful? promise/pure/maybe-stateful?])
promise/pure/stateless?
make-promise/pure/stateful
make-promise/pure/stateless
(struct-out declared-stateful-pure-function)
(struct-out declared-stateless-pure-function))
(define-struct (promise/pure/stateful promise) ()
#:property prop:force (λ(p) ((pref p))))
(define-struct (promise/pure/stateless promise/pure/stateful) ()
#:property prop:force (λ(p) ((pref p))))
(define-struct declared-stateful-pure-function (f)
#:property prop:procedure (struct-field-index f))
(define-struct
(declared-stateless-pure-function declared-stateful-pure-function)
())

232
scribblings/delay-pure.scrbl Normal file
View File

@ -0,0 +1,232 @@
#lang scribble/manual
@require[racket/require
delay-pure
@for-syntax[racket/base
syntax/id-set]
@for-label[delay-pure
racket
(except-in (subtract-in typed/racket racket) :)
racket/promise
(only-in type-expander :)]]
@title{Pure functions and promises}
@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
@defmodule[delay-pure]
@deftogether[[@defform[(delay/pure/stateless expression)]
@defform[(delay/pure/stateful expression)]]]{
Produces a promise for @racket[expression] which does not cache its result,
like @racket[delay/name]. The @racket[delay/pure/stateless] form checks that
the @racket[expression] is pure by wrapping it with
@racket[(pure/stateless expression)]. The @racket[delay/pure/stateful] form
instead relies on @racket[(pure/stateful expression)].}
@defproc[(promise/pure/maybe-stateful? [v any/c]) boolean?]{
A predicate which recognizes promises created with both
@racket[delay/pure/stateless] and @racket[delay/pure/stateful].}
@defproc[(promise/pure/stateless? [v any/c]) boolean?]{
A predicate which recognizes promises created with
@racket[delay/pure/stateless], and rejects those created with
@racket[delay/pure/stateful].}
@deftogether[[@defform[(pure/stateless expression)]
@defform[(pure/stateful expression)]]]{
Checks that the @racket[expression] is pure. This is done by fully expanding
the expression, and checking at run-time that the free variables (including
functions) contain only immutable values and pure functions. There is a
hard-coded list of built-in functions which are known to be pure. The
functions created with @racket[define-pure/stateless] are also accepted (but
not those created with @racket[define-pure/stateful]), as well as
@racket[struct] accessors and predicates, and @racket[struct] constructors for
immutable structures.
The first form, @racket[pure/stateless], checks that once fully-expanded, the
@racket[expression] does not contain uses of @racket[set!]. Since the free
variables can never refer to stateful functions, this means that any function
present in the result is guaranteed be a @deftech{stateless} function. The
results of two calls to a @tech{stateless} function with the same arguments
should be indistinguishable, aside from the fact that they might not be
@racket[eq?]. In other words, a @tech{stateless} function will always return
the ``same'' (not necessarily @racket[eq?]) value given the same
(@racket[eq?]) arguments. If the result contains functions, these functions are
guaranteed to be @tech{stateless} too.
With the second form @racket[pure/stateful], uses of @racket[set!] are
allowed within the expression (but may not alter free variables). The
resulting value will be an immutable value which may contain both
@tech{stateless} and @deftech{stateful} functions. Stateful functions may be
closures over a value which is mutated using @racket[set!], and therefore
calling a @tech{stateful} function twice with the same (@racket[eq?])
arguments may produce different results. Since Typed/Racket does not use
occurrence typing on function calls, the guarantee that the result is
immutable until a function value is reached is enough to safely build
non-caching promises that return the ``same'' value, as far as occurrence
typing is concerned.
Promises created with @racket[delay/pure/stateless] and
@racket[delay/pure/stateful] re-compute their result each time, which yields
results that are not necessarily @racket[eq?]. This means that calling
@racket[eq?] twice on the same pair of expressions may not produce the same
result. Fortunately, occurrence typing in Typed/Racket does not rely on this
assumption, and does not "cache" the result of calls to @racket[eq?]. If this
behaviour were to change, this library would become unsound.
TODO: add a test in the test suite which checks that Typed/Racket does not
"cache" the result of @racket[eq?] calls, neither at the type level, nor at
the value level.}
@deftogether[[@defform*[[(pure-thunk/stateless thunk)
(pure-thunk/stateless thunk #:check-result)]]
@defform*[[(pure-thunk/stateful thunk)
(pure-thunk/stateful thunk #:check-result)]]]]{
Like @racket[pure/stateless] and @racket[pure/stateful], but the
@racket[_thunk] expression should produce a thunk. When
@racket[#:check-result] is specified, a run-time guard on the function's
result is added. The guard checks that the result is an immutable value. With
@racket[pure-thunk/stateless], the result guard only accepts immutable values,
possibly containing @tech{stateless} functions. With
@racket[pure-thunk/stateful], the result guard also accepts immutable values,
possibly containing @tech{stateful} functions.}
@deftogether[
[@defform*[#:literals (:)
[(define-pure/stateless (name . args) body ...)
(define-pure/stateless (name . args) : result-type body ...)]]
@defform*[#:literals (:)
[(define-pure/stateful (name . args) body ...)
(define-pure/stateful (name . args) : result-type body ...)]]]]{
Defines @racket[name] as a pure function. The @racket[define-pure/stateful]
form relies on @racket[pure/stateful], and therefore allows the function to
return a value containing @tech{stateful} functions. On the other hand,
@racket[define-pure/stateless] relies on @racket[pure/stateless], and
therefore only allows the return value to contain @tech{stateless} functions.}
@(define-syntax (show-pure-ids stx)
(with-syntax ([(id ...) (map (λ (id) (datum->syntax #'here (syntax-e id)))
(sort (free-id-set->list
built-in-pure-functions-free-id-set)
symbol<?
#:key syntax-e))])
#`(itemlist
(item (list (racket id)))
...)))
@defthing[built-in-pure-functions-set (and/c generic-set? set-eq? set?)]{
This set contains the built-in functions recognized as pure by this library.
For now only a few built-in functions are recognized as pure:
@(show-pure-ids)
Patches adding new functions to the set are welcome.}
@defthing[#:kind "for-syntax value"
built-in-pure-functions-free-id-set immutable-free-id-set?]{
This value is provided at level 1, and contains the identifiers of the
functions present in @racket[built-in-pure-functions-set].}
@defproc[((immutable/stateless/c [varref Variable-Reference]) [v Any]) Boolean]{
Returns a predicate which accepts only values which are immutable, possibly
containing @tech{stateless} functions, but not @tech{stateful} functions.
This predicate detects whether the functions contained within the value
@racket[v] are pure or not, based on the @racket[built-in-pure-functions-set]
set and a few special cases:
@itemlist[
@item{The low-level functions used to build pure promises are always
accepted. Their valid use is guaranteed by the macros wrapping them.}
@item{Predicates for @racket[struct] types are always accepted}
@item{Field accessors for @racket[struct] types are always accepted}
@item{Constructors for @racket[struct] types are accepted only if
@racket[immutable/stateless/c] can determine that the struct type is
immutable.}]
There seems to be no combination of built-in functions in Racket which would
reliably associate a struct constructor (as a value) with its corresponding
struct type. Instead, @racket[immutable/stateless/c] uses a heuristic based on
@racket[object-name]: if @racket[struct-constructor-procedure?] returns
@racket[#true] for a function, and that function's @racket[object-name] is
@racket[st] or @racket[make-st], then @racket[st] is expected to be an
identifier with static struct type information.
To achieve this, it is necessary to access the call-site's namespace, which is
done via the @racket[varref] parameter. Simply supplying the result of
@racket[(#%variable-reference)] should be enough.}
@defproc[((immutable/stateful/c [varref Variable-Reference]) [v Any]) Boolean]{
Returns a predicate which accepts only values which are immutable, possibly
containing both @tech{stateful} and @tech{stateless} functions.
This predicate needs to access the call-site's namespace, which is
done via the @racket[varref] parameter. Simply supplying the result of
@racket[(#%variable-reference)] should be enough.
See the documentation for @racket[immutable/stateless/c] for an explanation
of the reason for this need.}
@defform[(unsafe-pure/stateless expression)]{
Indicates that the expression should be trusted as allowable within a
@racket[pure/stateless] or @racket[pure/stateful] block or one of their
derivatives. No check is performed on the expression.
The @racket[unsafe-pure/stateless] form can be used within
@racket[pure/stateless], @racket[pure/stateful] and their derivatives, to
prevent any check on a portion of code.
The expression should be a pure, stateless expression.
Note that in the current implementation, the @racket[expression] is lifted
(in the sense of @racket[syntax-local-lift-expression].}
@defform[(unsafe-operation/mutating expression)]{
Indicates that the expression should be trusted as allowable within a
@racket[pure/stateful] block, or one of its derivatives. No check is performed
on the expression.
The @racket[expression] should not vary its outputs and effects based on
external state (i.e. its outputs and effects should depend only on the
arguments passed to it).
The @racket[expression] function may internally use mutation. It may return
freshly-created stateful objects (closures over freshly-created mutable
variables, closures over mutable arguments, and mutable data structure which
are freshly created or extracted from the arguments). It may mutate any
mutable data structure passed as an argument.
Note that in the current implementation, the @racket[expression] is lifted
(in the sense of @racket[syntax-local-lift-expression].}
@defform[(unsafe-declare-pure/stateless identifier)]{
Declares that the given identifier should be trusted as a stateless pure
function. The given function is subsequently treated like the functions
present in @racket[built-in-pure-functions-set].
Note that this has a global effect. For one-off exceptions, especially when
it's not 100% clear whether the function is always pure and stateless, prefer
@racket[unsafe-pure/stateless].}
@defform[(unsafe-declare-allowed-in-pure/stateful identifier)]{
Declares that the given identifier should be trusted as a function that can
be used within @racket[pure/stateful] and its derivatives.
The @racket[identifier] function should not vary its outputs and effects
based on external state (i.e. its outputs and effects should depend only on
the arguments passed to it).
The @racket[identifier] function may internally use mutation. It may return
freshly-created stateful objects (closures over freshly-created mutable
variables, closures over mutable arguments, and mutable data structure which
are freshly created or extracted from the arguments). It may mutate any
mutable data structure passed as an argument.
Note that this has a global effect. For one-off exceptions, prefer
@racket[unsafe-operation/mutating].}

13
test/test-immutable-struct-constructor-mod.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang typed/racket
;; This file is used by test-immutable-struct-constructor.rkt .
(provide (struct-out st3-mod)
(struct-out st4-mod))
(struct st3-mod ([a : Number]) #:transparent)
(struct st4-mod ([a : Number])
#:constructor-name make-st4-mod
#:type-name st4-mod-type
#:transparent)

13
test/test-immutable-struct-constructor-mod2.rkt Normal file
View File

@ -0,0 +1,13 @@
#lang typed/racket
;; This file is used by test-immutable-struct-constructor.rkt .
(provide (struct-out st5-mod)
(struct-out st6-mod))
(struct st5-mod ([a : Number]) #:transparent)
(struct st6-mod ([a : Number])
#:constructor-name make-st6-mod
#:type-name st6-mod-type
#:transparent)

47
test/test-immutable-struct-constructor.rkt Normal file
View File

@ -0,0 +1,47 @@
#lang typed/racket
(require delay-pure/private/immutable-struct-constructor
"test-immutable-struct-constructor-mod.rkt"
typed/rackunit)
(struct st1 ([a : Number]) #:transparent)
(struct st2 ([a : Number])
#:constructor-name make-st2
#:type-name st2-type
#:transparent)
;; From this module
(check-true (immutable-struct-constructor? st1 (#%variable-reference)))
(check-true (immutable-struct-constructor? make-st2 (#%variable-reference)))
;; From another module
(check-true (immutable-struct-constructor? st3-mod (#%variable-reference)))
(check-true (immutable-struct-constructor? make-st4-mod (#%variable-reference)))
;; From a macro
(define-syntax (test-from-macro _)
#'(begin
;; From this module
(check-true (immutable-struct-constructor? st1
(#%variable-reference)))
(check-true (immutable-struct-constructor? make-st2
(#%variable-reference)))
;; From another module
(check-true (immutable-struct-constructor? st3-mod
(#%variable-reference)))
(check-true (immutable-struct-constructor? make-st4-mod
(#%variable-reference)))))
(test-from-macro)
;; From a macro, using a module which is required by the macro
(define-syntax (test-required-from-macro _)
#'(begin
(require "test-immutable-struct-constructor-mod2.rkt")
;; From another module
(check-true (immutable-struct-constructor? st3-mod
(#%variable-reference)))
(check-true (immutable-struct-constructor? make-st4-mod
(#%variable-reference)))))
(test-required-from-macro)

42
test/test-pure-function.rkt Normal file
View File

@ -0,0 +1,42 @@
#lang typed/racket
(require delay-pure
typed/rackunit
syntax/macro-testing)
(check-equal? (let ([y : Number 123])
(define f (pure/stateless (λ ([x : Number]) (+ x y))))
(set! y 0)
(f 1))
124)
(check-exn #px"pure: set! is disallowed within pure/stateless and similar forms"
(λ ()
(convert-compile-time-error
(let ()
(define f (pure/stateless
(λ ()
(let ([x 1])
(λ ()
(let ([y x])
(set! x 0)
y))))))
(define g (f))
(list (g) (g))))))
(check-equal? (let ()
(define f (pure/stateful
(λ ()
(let ([x 1])
(λ ()
(let ([y x])
(set! x 0)
y))))))
(define g (f))
(list (g) (g)))
'(1 0))
;; I'm So Meta Even This Acronym
(check-equal? (let ([x 1])
(pure/stateless (pure/stateless x)))
1)

30
test/test-pure-lifted.rkt Normal file
View File

@ -0,0 +1,30 @@
#lang typed/racket
(require delay-pure
typed/rackunit
syntax/macro-testing)
(define-syntax (lft stx)
(syntax-case stx ()
[(_ e)
(syntax-local-lift-expression #'e)]))
(check-exn (regexp (string-append "lifted expressions are disallowed within"
" pure/stateful, pure/stateless and similar"
" forms \\(for now\\)"))
(λ ()
(convert-compile-time-error
(let ()
(define x 1)
(pure/stateless (+ 2 (lft (begin (set! x (add1 x)) x)) 3))))))
(check-exn (regexp (string-append "lifted expressions are disallowed within"
" pure/stateful, pure/stateless and similar"
" forms \\(for now\\)"))
(λ ()
(convert-compile-time-error
(let ()
(define x 1)
(pure/stateful (+ 2 (lft (begin (set! x (add1 x)) x)) 3))))))

70
test/test-pure-safe.rkt Normal file
View File

@ -0,0 +1,70 @@
#lang typed/racket
(module test typed/racket
(require delay-pure
typed/rackunit)
(check-equal? (force (let ([x (vector-immutable 1 2 3)])
(delay/pure/stateless (vector-ref x 0))))
1)
(check-equal? (force (force (let ([x (vector-immutable 1 2 3)])
(delay/pure/stateless
(delay/pure/stateless (vector-ref x 0))))))
1)
(define f0
(let ([x (vector-immutable 'a 'b 'c)])
(let ()
(: f (→ Integer
(Listof Integer)
(Rec R (List* Integer Symbol (Promise R)))))
(define-pure/stateless (f [n : Integer] [big : (Listof Integer)])
: (Rec R (List* Integer Symbol (Promise R)))
(cons (length big)
(cons (vector-ref x (modulo n 3))
(delay/pure/stateless (f (add1 n)
(reverse (cons (length big)
big)))))))
(f 0 '()))))
;; Check that the first 100 elements are as expected:
(check-equal? (let rec : (Listof (List Integer Symbol)) ([i 0] [fi f0])
(if (>= i 100)
'()
(cons (list (car fi) (cadr fi))
(rec (add1 i) (force (cddr fi))))))
(for/list : (Listof (List Integer Symbol))
([a (in-list (range 100))]
[b (in-cycle (in-list '(a b c)))])
(list a b)))
(: travel-far (→ Number
(Rec R (List* Integer Symbol (Promise R)))
(List Integer Symbol)))
(define (travel-far i fi)
(if (= i 0)
(list (car fi) (cadr fi))
(travel-far (sub1 i) (force (cddr fi)))))
(check-equal? (travel-far 0 f0) '(0 a))
(check-equal? (travel-far 1 f0) '(1 b))
(check-equal? (travel-far 2 f0) '(2 c))
(check-equal? (travel-far 3 f0) '(3 a))
(check-equal? (travel-far 99 f0) '(99 a))
(check-equal? (travel-far 1000 f0) '(1000 b))
;; Test showing that the promise is not cached: we follow a very long sequence
;; of recursive promises, while still holding a reference to the first in f0,
;; if caching occurs we will go out of memory.
;; Since the state of each promise contains a fresh list (reversed from the
;; previous promise's state with an extra element consed in front), the total
;; size would be quadratic in the number of steps if all the intermediate
;; promises were cached.
;; This test runs for about 75 seconds on my machine. It allocates at least
;; (* 50000 50000 1/2) cons cells, which, with 64 bits = 8 bytes per cons cell
;; amounts to (/ (* 50000 50000 1/2 8) (* 1024 1024 1024)) ≅ 9 GiB of RAM,
;; which should be enough to make the travis build fail if caching occurs.
(module config info
(define timeout 600))
(check-equal? (travel-far 50000 f0) '(50000 c)))

52
test/test-unsafe.rkt Normal file
View File

@ -0,0 +1,52 @@
#lang typed/racket
(require delay-pure
syntax/macro-testing
typed/rackunit)
;; unsafe-pure/stateless within pure-thunk/stateless
(let ()
(define x 1)
(define f
(pure-thunk/stateless
(λ ()
(+ (unsafe-pure/stateless (set! x (add1 x))
x)
1))))
(check-equal? (list (f) (f) (f)) '(3 4 5)))
;; unsafe-pure/stateless within pure-thunk/stateful
(let ()
(define x 1)
(define f
(pure-thunk/stateful
(λ ()
(+ (unsafe-pure/stateless (set! x (add1 x))
x)
1))))
(check-equal? (list (f) (f) (f)) '(3 4 5)))
;; unsafe-operation/mutating within pure-thunk/stateless
(check-exn #px"unsafe-operation/mutating disallowed within pure/stateless"
(λ ()
(convert-compile-time-error
(let ()
(define x 1)
(define f
(pure-thunk/stateless
(λ ()
(+ (unsafe-operation/mutating (set! x (add1 x))
x)
1))))
(check-equal? (list (f) (f) (f)) '(3 4 5))))))
;; unsafe-operation/mutating within pure-thunk/stateful
(let ()
(define x 1)
(define f
(pure-thunk/stateful
(λ ()
(+ (unsafe-operation/mutating (set! x (add1 x))
x)
1))))
(check-equal? (list (f) (f) (f)) '(3 4 5)))