commit fb38440010319d30686bfc8a458dea88086f61cf Author: Georges Dupéron Date: Sat Oct 8 23:19:27 2016 +0200 Squashed old commits. diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1a59348 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*~ +\#* +.\#* +.DS_Store +compiled/ +/doc/ diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..5fd7e5b --- /dev/null +++ b/.travis.yml @@ -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. \ No newline at end of file diff --git a/LICENSE-more.md b/LICENSE-more.md new file mode 100644 index 0000000..e4716f7 --- /dev/null +++ b/LICENSE-more.md @@ -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. diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 index 0000000..670154e --- /dev/null +++ b/LICENSE.txt @@ -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 + diff --git a/README.md b/README.md new file mode 100644 index 0000000..a94f238 --- /dev/null +++ b/README.md @@ -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. diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..992f0ff --- /dev/null +++ b/info.rkt @@ -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")) diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..c7625fe --- /dev/null +++ b/main.rkt @@ -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) \ No newline at end of file diff --git a/private/fully-expanded-grammar-no-set.rkt b/private/fully-expanded-grammar-no-set.rkt new file mode 100644 index 0000000..de9b79b --- /dev/null +++ b/private/fully-expanded-grammar-no-set.rkt @@ -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)) \ No newline at end of file diff --git a/private/immutable-struct-constructor.rkt b/private/immutable-struct-constructor.rkt new file mode 100644 index 0000000..3f39d2d --- /dev/null +++ b/private/immutable-struct-constructor.rkt @@ -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])))))) diff --git a/private/pure-exception.rkt b/private/pure-exception.rkt new file mode 100644 index 0000000..c61a2c7 --- /dev/null +++ b/private/pure-exception.rkt @@ -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))])) \ No newline at end of file diff --git a/private/pure-function.rkt b/private/pure-function.rkt new file mode 100644 index 0000000..15cfe31 --- /dev/null +++ b/private/pure-function.rkt @@ -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)) diff --git a/private/pure-safe.rkt b/private/pure-safe.rkt new file mode 100644 index 0000000..c42e884 --- /dev/null +++ b/private/pure-safe.rkt @@ -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)))])) diff --git a/private/pure-unsafe.rkt b/private/pure-unsafe.rkt new file mode 100644 index 0000000..e2266b3 --- /dev/null +++ b/private/pure-unsafe.rkt @@ -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) + ()) \ No newline at end of file diff --git a/scribblings/delay-pure.scrbl b/scribblings/delay-pure.scrbl new file mode 100644 index 0000000..f71d135 --- /dev/null +++ b/scribblings/delay-pure.scrbl @@ -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= 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))) \ No newline at end of file diff --git a/test/test-unsafe.rkt b/test/test-unsafe.rkt new file mode 100644 index 0000000..662286d --- /dev/null +++ b/test/test-unsafe.rkt @@ -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)))