From 109659c456ca011163ed2dc909a29e35b63a276d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Thu, 27 Apr 2017 23:38:55 +0200 Subject: [PATCH] Squashed commits --- .gitignore | 6 + .gitmodules | 0 .travis.yml | 63 +++ LICENSE | 13 + README.md | 23 + README.md.old | 33 ++ aliases.rkt | 41 ++ backtrace.rkt | 14 + compat.rkt | 21 + cond-let.rkt | 19 + contract.rkt | 51 ++ eval-get-values.rkt | 17 + fixnum.rkt | 13 + generate-indices.rkt | 23 + ids.rkt | 321 ++++++++++++ in.rkt | 13 + info.rkt | 21 + is-typed.rkt | 4 + is-untyped.rkt | 4 + licenses/bsd.txt | 19 + licenses/lgpl-3.0--license.txt | 165 ++++++ light-no-check.rkt | 46 ++ list-lang.rkt | 16 + list.rkt | 103 ++++ logn-id.rkt | 82 +++ main.rkt | 45 ++ meta-struct.rkt | 131 +++++ misc.rkt | 75 +++ multiassoc-syntax.rkt | 36 ++ not-implemented-yet.rkt | 19 + partial-include.rkt | 51 ++ percent.rkt | 78 +++ perf.rkt.ods | Bin 0 -> 48074 bytes perfs.untyped.unsilent.txt | 98 ++++ repeat-stx.rkt | 114 ++++ require-provide.rkt | 22 + scribblings/aliases-untyped.scrbl | 29 ++ scribblings/aliases.scrbl | 31 ++ scribblings/backtrace-untyped.scrbl | 11 + scribblings/backtrace.scrbl | 11 + scribblings/compat-untyped.scrbl | 16 + scribblings/compat.scrbl | 23 + scribblings/cond-let-untyped.scrbl | 10 + scribblings/cond-let.scrbl | 11 + scribblings/contract-untyped.scrbl | 10 + scribblings/contract.scrbl | 33 ++ scribblings/eval-get-values-untyped.scrbl | 10 + scribblings/eval-get-values.scrbl | 11 + scribblings/fixnum-untyped.scrbl | 10 + scribblings/fixnum.scrbl | 20 + scribblings/for-star-list-star.scrbl | 33 ++ scribblings/format-id-record-untyped.scrbl | 124 +++++ scribblings/generate-indices-untyped.scrbl | 10 + scribblings/generate-indices.scrbl | 11 + scribblings/ids-untyped.scrbl | 10 + scribblings/ids.scrbl | 76 +++ scribblings/in-untyped.scrbl | 10 + scribblings/in.scrbl | 11 + scribblings/list-lang.scrbl | 6 + scribblings/list-untyped.scrbl | 10 + scribblings/list.scrbl | 11 + scribblings/logn-id-untyped.scrbl | 10 + scribblings/logn-id.scrbl | 11 + scribblings/meta-struct-untyped.scrbl | 23 + scribblings/meta-struct.scrbl | 168 ++++++ scribblings/misc-untyped.scrbl | 10 + scribblings/misc.scrbl | 62 +++ scribblings/multiassoc-syntax-untyped.scrbl | 11 + scribblings/multiassoc-syntax.scrbl | 12 + scribblings/not-implemented-yet-untyped.scrbl | 10 + scribblings/not-implemented-yet.scrbl | 49 ++ scribblings/percent-untyped.scrbl | 10 + scribblings/percent.scrbl | 70 +++ scribblings/phc-toolkit.scrbl | 76 +++ scribblings/repeat-stx-untyped.scrbl | 10 + scribblings/repeat-stx.scrbl | 11 + scribblings/require-provide-untyped.scrbl | 10 + scribblings/require-provide.scrbl | 11 + scribblings/sequence-untyped.scrbl | 10 + scribblings/sequence.scrbl | 11 + scribblings/set-untyped.scrbl | 10 + scribblings/set.scrbl | 11 + scribblings/stx-patching-srcloc.scrbl | 84 +++ scribblings/stx-untyped-only.scrbl | 44 ++ scribblings/stx-untyped.scrbl | 47 ++ scribblings/stx.scrbl | 118 +++++ .../syntax-parse-pattern-expanders.scrbl | 87 ++++ scribblings/syntax-parse-untyped.scrbl | 22 + scribblings/syntax-parse.scrbl | 101 ++++ scribblings/template.scrbl | 492 ++++++++++++++++++ scribblings/test-framework-untyped.scrbl | 10 + scribblings/test-framework.scrbl | 11 + scribblings/threading-untyped.scrbl | 10 + scribblings/threading.scrbl | 11 + .../tmpl-multiassoc-syntax-untyped.scrbl | 10 + scribblings/tmpl-multiassoc-syntax.scrbl | 28 + scribblings/tmpl-untyped.scrbl | 10 + scribblings/tmpl.scrbl | 11 + .../type-inference-helpers-untyped.scrbl | 10 + scribblings/type-inference-helpers.scrbl | 16 + .../typed-rackunit-extensions-untyped.scrbl | 10 + scribblings/typed-rackunit-extensions.scrbl | 77 +++ scribblings/typed-rackunit-untyped.scrbl | 10 + scribblings/typed-rackunit.scrbl | 106 ++++ scribblings/typed-untyped-untyped.scrbl | 10 + scribblings/typed-untyped.scrbl | 11 + scribblings/untyped.scrbl | 62 +++ scribblings/utils.rkt | 18 + scribblings/values-untyped.scrbl | 10 + scribblings/values.scrbl | 11 + sequence.rkt | 268 ++++++++++ set.rkt | 6 + stx.rkt | 441 ++++++++++++++++ stx/fold-typed+prefab.rkt.does-not-work | 57 ++ stx/fold.rkt | 90 ++++ stx/prefab.rkt | 70 +++ syntax-parse.rkt | 296 +++++++++++ test-framework.rkt | 60 +++ test/list-lang-test.rkt | 12 + test/list-test.rkt | 145 ++++++ test/meta-struct-test.rkt | 79 +++ test/test-define-temp-ids.rkt | 26 + test/test-fixnum.rkt | 9 + test/test-format-id-record-inject.rkt | 69 +++ test/test-format-id-record.rkt | 89 ++++ test/test-ids.rkt | 58 +++ test/test-stx.rkt | 99 ++++ test/test-syntax-parse.rkt | 72 +++ threading.rkt | 23 + tmpl-multiassoc-syntax.rkt | 25 + tmpl.rkt | 14 + todo.rkt | 15 + type-inference-helpers.rkt | 50 ++ typed-rackunit-extensions.rkt | 145 ++++++ typed-rackunit.rkt | 171 ++++++ typed-untyped.rkt | 230 ++++++++ unstable.rkt | 148 ++++++ untyped-only.rkt | 3 + untyped-only/for-star-list-star.rkt | 71 +++ untyped-only/format-id-record.rkt | 239 +++++++++ untyped-only/quasitemplate.rkt | 85 +++ untyped-only/stx.rkt | 23 + untyped-only/syntax-parse.rkt | 92 ++++ untyped.rkt | 4 + untyped/aliases.rkt | 4 + untyped/backtrace.rkt | 2 + untyped/compat.rkt | 2 + untyped/cond-let.rkt | 2 + untyped/contract.rkt | 2 + untyped/eval-get-values.rkt | 2 + untyped/fixnum.rkt | 2 + untyped/for-star-list-star.rkt | 2 + untyped/format-id-record.rkt | 2 + untyped/generate-indices.rkt | 2 + untyped/ids.rkt | 2 + untyped/in.rkt | 2 + untyped/list.rkt | 2 + untyped/logn-id.rkt | 2 + untyped/main.rkt | 2 + untyped/meta-struct.rkt | 2 + untyped/misc.rkt | 2 + untyped/multiassoc-syntax.rkt | 2 + untyped/not-implemented-yet.rkt | 2 + untyped/percent.rkt | 2 + untyped/repeat-stx.rkt | 2 + untyped/require-provide.rkt | 2 + untyped/sequence.rkt | 2 + untyped/set.rkt | 2 + untyped/stx.rkt | 2 + untyped/syntax-parse.rkt | 2 + untyped/test-framework.rkt | 2 + untyped/threading.rkt | 2 + untyped/tmpl-multiassoc-syntax.rkt | 2 + untyped/tmpl.rkt | 2 + untyped/type-inference-helpers.rkt | 2 + untyped/typed-rackunit-extensions.rkt | 2 + untyped/typed-rackunit.rkt | 2 + untyped/typed-untyped.rkt | 2 + untyped/values.rkt | 2 + values.rkt | 51 ++ 180 files changed, 7808 insertions(+) create mode 100644 .gitignore create mode 100644 .gitmodules create mode 100644 .travis.yml create mode 100644 LICENSE create mode 100644 README.md create mode 100644 README.md.old create mode 100644 aliases.rkt create mode 100644 backtrace.rkt create mode 100644 compat.rkt create mode 100644 cond-let.rkt create mode 100644 contract.rkt create mode 100644 eval-get-values.rkt create mode 100644 fixnum.rkt create mode 100644 generate-indices.rkt create mode 100644 ids.rkt create mode 100644 in.rkt create mode 100644 info.rkt create mode 100644 is-typed.rkt create mode 100644 is-untyped.rkt create mode 100644 licenses/bsd.txt create mode 100644 licenses/lgpl-3.0--license.txt create mode 100644 light-no-check.rkt create mode 100644 list-lang.rkt create mode 100644 list.rkt create mode 100644 logn-id.rkt create mode 100644 main.rkt create mode 100644 meta-struct.rkt create mode 100644 misc.rkt create mode 100644 multiassoc-syntax.rkt create mode 100644 not-implemented-yet.rkt create mode 100644 partial-include.rkt create mode 100644 percent.rkt create mode 100644 perf.rkt.ods create mode 100644 perfs.untyped.unsilent.txt create mode 100644 repeat-stx.rkt create mode 100644 require-provide.rkt create mode 100644 scribblings/aliases-untyped.scrbl create mode 100644 scribblings/aliases.scrbl create mode 100644 scribblings/backtrace-untyped.scrbl create mode 100644 scribblings/backtrace.scrbl create mode 100644 scribblings/compat-untyped.scrbl create mode 100644 scribblings/compat.scrbl create mode 100644 scribblings/cond-let-untyped.scrbl create mode 100644 scribblings/cond-let.scrbl create mode 100644 scribblings/contract-untyped.scrbl create mode 100644 scribblings/contract.scrbl create mode 100644 scribblings/eval-get-values-untyped.scrbl create mode 100644 scribblings/eval-get-values.scrbl create mode 100644 scribblings/fixnum-untyped.scrbl create mode 100644 scribblings/fixnum.scrbl create mode 100644 scribblings/for-star-list-star.scrbl create mode 100644 scribblings/format-id-record-untyped.scrbl create mode 100644 scribblings/generate-indices-untyped.scrbl create mode 100644 scribblings/generate-indices.scrbl create mode 100644 scribblings/ids-untyped.scrbl create mode 100644 scribblings/ids.scrbl create mode 100644 scribblings/in-untyped.scrbl create mode 100644 scribblings/in.scrbl create mode 100644 scribblings/list-lang.scrbl create mode 100644 scribblings/list-untyped.scrbl create mode 100644 scribblings/list.scrbl create mode 100644 scribblings/logn-id-untyped.scrbl create mode 100644 scribblings/logn-id.scrbl create mode 100644 scribblings/meta-struct-untyped.scrbl create mode 100644 scribblings/meta-struct.scrbl create mode 100644 scribblings/misc-untyped.scrbl create mode 100644 scribblings/misc.scrbl create mode 100644 scribblings/multiassoc-syntax-untyped.scrbl create mode 100644 scribblings/multiassoc-syntax.scrbl create mode 100644 scribblings/not-implemented-yet-untyped.scrbl create mode 100644 scribblings/not-implemented-yet.scrbl create mode 100644 scribblings/percent-untyped.scrbl create mode 100644 scribblings/percent.scrbl create mode 100644 scribblings/phc-toolkit.scrbl create mode 100644 scribblings/repeat-stx-untyped.scrbl create mode 100644 scribblings/repeat-stx.scrbl create mode 100644 scribblings/require-provide-untyped.scrbl create mode 100644 scribblings/require-provide.scrbl create mode 100644 scribblings/sequence-untyped.scrbl create mode 100644 scribblings/sequence.scrbl create mode 100644 scribblings/set-untyped.scrbl create mode 100644 scribblings/set.scrbl create mode 100644 scribblings/stx-patching-srcloc.scrbl create mode 100644 scribblings/stx-untyped-only.scrbl create mode 100644 scribblings/stx-untyped.scrbl create mode 100644 scribblings/stx.scrbl create mode 100644 scribblings/syntax-parse-pattern-expanders.scrbl create mode 100644 scribblings/syntax-parse-untyped.scrbl create mode 100644 scribblings/syntax-parse.scrbl create mode 100644 scribblings/template.scrbl create mode 100644 scribblings/test-framework-untyped.scrbl create mode 100644 scribblings/test-framework.scrbl create mode 100644 scribblings/threading-untyped.scrbl create mode 100644 scribblings/threading.scrbl create mode 100644 scribblings/tmpl-multiassoc-syntax-untyped.scrbl create mode 100644 scribblings/tmpl-multiassoc-syntax.scrbl create mode 100644 scribblings/tmpl-untyped.scrbl create mode 100644 scribblings/tmpl.scrbl create mode 100644 scribblings/type-inference-helpers-untyped.scrbl create mode 100644 scribblings/type-inference-helpers.scrbl create mode 100644 scribblings/typed-rackunit-extensions-untyped.scrbl create mode 100644 scribblings/typed-rackunit-extensions.scrbl create mode 100644 scribblings/typed-rackunit-untyped.scrbl create mode 100644 scribblings/typed-rackunit.scrbl create mode 100644 scribblings/typed-untyped-untyped.scrbl create mode 100644 scribblings/typed-untyped.scrbl create mode 100644 scribblings/untyped.scrbl create mode 100644 scribblings/utils.rkt create mode 100644 scribblings/values-untyped.scrbl create mode 100644 scribblings/values.scrbl create mode 100644 sequence.rkt create mode 100644 set.rkt create mode 100644 stx.rkt create mode 100644 stx/fold-typed+prefab.rkt.does-not-work create mode 100644 stx/fold.rkt create mode 100644 stx/prefab.rkt create mode 100644 syntax-parse.rkt create mode 100644 test-framework.rkt create mode 100644 test/list-lang-test.rkt create mode 100644 test/list-test.rkt create mode 100644 test/meta-struct-test.rkt create mode 100644 test/test-define-temp-ids.rkt create mode 100644 test/test-fixnum.rkt create mode 100644 test/test-format-id-record-inject.rkt create mode 100644 test/test-format-id-record.rkt create mode 100644 test/test-ids.rkt create mode 100644 test/test-stx.rkt create mode 100644 test/test-syntax-parse.rkt create mode 100644 threading.rkt create mode 100644 tmpl-multiassoc-syntax.rkt create mode 100644 tmpl.rkt create mode 100644 todo.rkt create mode 100644 type-inference-helpers.rkt create mode 100644 typed-rackunit-extensions.rkt create mode 100644 typed-rackunit.rkt create mode 100644 typed-untyped.rkt create mode 100644 unstable.rkt create mode 100644 untyped-only.rkt create mode 100644 untyped-only/for-star-list-star.rkt create mode 100644 untyped-only/format-id-record.rkt create mode 100644 untyped-only/quasitemplate.rkt create mode 100644 untyped-only/stx.rkt create mode 100644 untyped-only/syntax-parse.rkt create mode 100644 untyped.rkt create mode 100644 untyped/aliases.rkt create mode 100644 untyped/backtrace.rkt create mode 100644 untyped/compat.rkt create mode 100644 untyped/cond-let.rkt create mode 100644 untyped/contract.rkt create mode 100644 untyped/eval-get-values.rkt create mode 100644 untyped/fixnum.rkt create mode 100644 untyped/for-star-list-star.rkt create mode 100644 untyped/format-id-record.rkt create mode 100644 untyped/generate-indices.rkt create mode 100644 untyped/ids.rkt create mode 100644 untyped/in.rkt create mode 100644 untyped/list.rkt create mode 100644 untyped/logn-id.rkt create mode 100644 untyped/main.rkt create mode 100644 untyped/meta-struct.rkt create mode 100644 untyped/misc.rkt create mode 100644 untyped/multiassoc-syntax.rkt create mode 100644 untyped/not-implemented-yet.rkt create mode 100644 untyped/percent.rkt create mode 100644 untyped/repeat-stx.rkt create mode 100644 untyped/require-provide.rkt create mode 100644 untyped/sequence.rkt create mode 100644 untyped/set.rkt create mode 100644 untyped/stx.rkt create mode 100644 untyped/syntax-parse.rkt create mode 100644 untyped/test-framework.rkt create mode 100644 untyped/threading.rkt create mode 100644 untyped/tmpl-multiassoc-syntax.rkt create mode 100644 untyped/tmpl.rkt create mode 100644 untyped/type-inference-helpers.rkt create mode 100644 untyped/typed-rackunit-extensions.rkt create mode 100644 untyped/typed-rackunit.rkt create mode 100644 untyped/typed-untyped.rkt create mode 100644 untyped/values.rkt create mode 100644 values.rkt diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..adfb974 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +*~ +\#* +.\#* +.DS_Store +compiled +/doc/ \ No newline at end of file diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..e69de29 diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..8f0a8af --- /dev/null +++ b/.travis.yml @@ -0,0 +1,63 @@ +language: c + +# Based from: https://github.com/greghendershott/travis-racket + +# Optional: Remove to use Travis CI's older infrastructure. +sudo: false + +env: + global: + # Supply a global RACKET_DIR environment variable. This is where + # Racket will be installed. A good idea is to use ~/racket because + # that doesn't require sudo to install and is therefore compatible + # with Travis CI's newer container infrastructure. + - RACKET_DIR=~/racket + matrix: + # Supply at least one RACKET_VERSION environment variable. This is + # used by the install-racket.sh script (run at before_install, + # below) to select the version of Racket to download and install. + # + # Supply more than one RACKET_VERSION (as in the example below) to + # create a Travis-CI build matrix to test against multiple Racket + # versions. + #- RACKET_VERSION=6.0 + #- RACKET_VERSION=6.1 + #- RACKET_VERSION=6.1.1 + #- RACKET_VERSION=6.2 + #- RACKET_VERSION=6.3 + #- RACKET_VERSION=6.4 # scribble bug prevents compiling the docs for the "type-expander" dependency. + - RACKET_VERSION=6.5 + - RACKET_VERSION=6.6 + - RACKET_VERSION=6.7 + - RACKET_VERSION=6.8 + - RACKET_VERSION=HEAD + +matrix: + allow_failures: + - env: RACKET_VERSION=6.0 + - env: RACKET_VERSION=6.1 + - env: RACKET_VERSION=6.1.1 + - env: RACKET_VERSION=6.2 + - env: RACKET_VERSION=6.3 + fast_finish: true + +before_install: +- git clone https://github.com/greghendershott/travis-racket.git +- cat travis-racket/install-racket.sh | bash # pipe to bash not sh! +- export PATH="${RACKET_DIR}/bin:${PATH}" #install-racket.sh can't set for us + +install: + - raco pkg install -j 2 --deps search-auto + +before_script: + +# Here supply steps such as raco make, raco test, etc. You can run +# `raco pkg install --deps search-auto phc-toolkit` to install any required +# packages without it getting stuck on a confirmation prompt. +script: + - raco test -p phc-toolkit + - raco setup --check-pkg-deps --no-zo --no-launcher --no-install --no-post-install --no-docs --pkgs phc-toolkit + +after_success: + - raco pkg install --deps search-auto cover cover-codecov + - raco cover -b -f codecov -d $TRAVIS_BUILD_DIR/coverage . diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..e05eb83 --- /dev/null +++ b/LICENSE @@ -0,0 +1,13 @@ +This software was initially written as part of a project at Cortus, S.A.S. which +can be reached at 97 Rue de Freyr, 34000 Montpellier, France. + +This software is licensed under the GNU Lesser General Public License (LGPL) or +under the BSD license, at your option. Both licenses can be found in the +`licenses/` folder. + +This double-licensing has been chosen in order to make it possible to integrate +the type-expander library with Typed/Racket +(https://github.com/racket/typed-racket) and/or Racket +(https://github.com/racket/racket), which are both under the LGPL license, as +well as integrate the graph library with the Nanopass Compiler Framework +(https://github.com/akeep/nanopass-framework), which is under the BSD license. \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..9eee018 --- /dev/null +++ b/README.md @@ -0,0 +1,23 @@ +[![Build Status,](https://img.shields.io/travis/jsmaniac/phc-toolkit/master.svg)](https://travis-ci.org/jsmaniac/phc-toolkit) +[![Coverage Status,](https://img.shields.io/codecov/c/github/jsmaniac/phc-toolkit/master.svg)](https://codecov.io/gh/jsmaniac/phc-toolkit) +[![Build Stats,](https://img.shields.io/badge/build-stats-blue.svg)](http://jsmaniac.github.io/travis-stats/#jsmaniac/phc-toolkit) +[![Maintained as of 2017,](https://img.shields.io/maintenance/yes/2017.svg)](https://github.com/jsmaniac/phc-toolkit/issues) +[![Online Documentation.](https://img.shields.io/badge/docs-online-blue.svg)](http://docs.racket-lang.org/phc-toolkit/) + +phc-toolkit +=========== + +This is a collection of minor addendums to Racket and Typed/Racket's +standard libraries. It is used by the jsmaniac/phc project. + +Although most functions are unlikely to change, this library should +not be considered stable. Some functions need an overhaul, and the +typed/untyped mechanism used to provide both a typed and an untyped +version of each file might change in the future. + +Installation +------------ + +``` +raco pkg install --deps search-auto phc-toolkit +``` diff --git a/README.md.old b/README.md.old new file mode 100644 index 0000000..7ca1d4e --- /dev/null +++ b/README.md.old @@ -0,0 +1,33 @@ +Library functions and utilities +------------------------------- + +* `eval-get-values.rkt` + + Wrapper for the racket `eval` function that allows the evaluation of code + with multiple return values in typed/racket. + +* `main.rkt` + + Utilities that complement racket and typed/racket's standard libraries. + +* `untyped-only/for-star-list-star.rkt` + + A utility macro similar to `for*/list` to iterate over collections and return + a list of results, but which can return nested lists instead of just a flat + one. + +* `test-framework.rkt` + + Some wrappers and utilities that allow easier use of the rackunit test + framework from typed/racket files. + +* `list-lang.rkt` + + Tiny programming language extension that allows constructing a list with the + contents of all trailing lines in the file. This makes appending data to the + list easy, as there is no need to remove the last closing parentheses and add + them back afterwards — simply appending an s-expression to the file works. + Alternatively, one could avoid using this language by appending an + instruction of the form: + + (set! list (cons item list)) diff --git a/aliases.rkt b/aliases.rkt new file mode 100644 index 0000000..c0a8310 --- /dev/null +++ b/aliases.rkt @@ -0,0 +1,41 @@ +#lang typed/racket/base (require phc-toolkit/is-typed) +(provide (all-from-out racket/match) + ∘ + … + …+ + attr + when-attr + @ + match-λ + match-λ* + match-λ** + generate-temporary + true? + false?) + +(require racket/match) + +(require (only-in racket/base + [compose ∘] + [... …]) + (only-in racket/bool + false?) + (only-in syntax/parse + [...+ …+]) + (only-in phc-toolkit/untyped-only/syntax-parse + [attribute* attr] + [attribute* @])) + +(define-syntax-rule (when-attr a e) + (if (attr a) e #'())) + +(require (only-in racket/match + [match-lambda match-λ] + [match-lambda* match-λ*] + [match-lambda** match-λ**])) + +(require/typed racket/syntax [generate-temporary (→ Any Identifier)]) + +(if-typed + (require (only-in alexis/bool true?)) + (require (only-in typed/alexis/bool true?))) \ No newline at end of file diff --git a/backtrace.rkt b/backtrace.rkt new file mode 100644 index 0000000..f39f464 --- /dev/null +++ b/backtrace.rkt @@ -0,0 +1,14 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide show-backtrace + with-backtrace) + + (define backtrace (make-parameter '())) + + (define-syntax-rule (with-backtrace push . body) + (parameterize ([backtrace (cons push (backtrace))]) + . body)) + + (define (show-backtrace) + (pretty-write (backtrace)))) \ No newline at end of file diff --git a/compat.rkt b/compat.rkt new file mode 100644 index 0000000..e60c0c1 --- /dev/null +++ b/compat.rkt @@ -0,0 +1,21 @@ +#lang typed/racket +;; Compatibility functions for Racket version 6.5. + +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (require (only-in racket/syntax with-disappeared-uses)) + (require/typed racket/syntax + [record-disappeared-uses + ;; This is the type in v. 6.5. Later versions allow + ;; (U Identifier (Listof Identifier)). The wrapper below + ;; generalizes that type. + (→ (Listof Identifier) Any)]) + (provide with-disappeared-uses* + record-disappeared-uses*) + + (define-syntax-rule (with-disappeared-uses* . body) + (with-disappeared-uses (let () . body))) + + (: record-disappeared-uses* (→ (U Identifier (Listof Identifier)) Any)) + (define (record-disappeared-uses* ids) + (record-disappeared-uses (if (list? ids) ids (list ids))))) diff --git a/cond-let.rkt b/cond-let.rkt new file mode 100644 index 0000000..7ea3751 --- /dev/null +++ b/cond-let.rkt @@ -0,0 +1,19 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide cond-let) + + (require (for-syntax syntax/parse + phc-toolkit/untyped/aliases)) + + (define-syntax (cond-let stx) + (syntax-parse stx + [(_) + #'(typecheck-fail #,stx)] + [(_ #:let bindings:expr clause …) + #'(let bindings (cond-let clause …))] + [(_ [condition:expr (~seq #:else-let binding …) … . body] clause …) + #'(if condition + (begin . body) + (let (binding … …) + (cond-let clause …)))]))) \ No newline at end of file diff --git a/contract.rkt b/contract.rkt new file mode 100644 index 0000000..bf5b48b --- /dev/null +++ b/contract.rkt @@ -0,0 +1,51 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (require racket/contract + (for-syntax syntax/parse + racket/contract)) + + (provide define-for-syntax/contract? + define/contract? + regexp-match/c + id/c) + + (begin-for-syntax + (define-splicing-syntax-class freevar + (pattern {~and {~or {~seq #:freevar id contract-expr} + {~seq #:freevars ([ids contract-exprs] ...)} + {~seq}} + {~seq fv ...}}))) + + (begin-for-syntax + (define enable-contracts (make-parameter #t))) + + (define-syntax define-for-syntax/contract? + (syntax-parser + [(_ id/head contract-expr fv:freevar . body) + (if (enable-contracts) + #'(begin-for-syntax + (define/contract id/head contract-expr fv.fv ... . body)) + #'(define-for-syntax id/head . body))])) + + (define-syntax define/contract? + (syntax-parser + [(_ id/head contract-expr fv:freevar . body) + (if (enable-contracts) + #'(define/contract id/head contract-expr fv.fv ... . body) + #'(define id/head . body))])) + + (module m-contracts racket/base + (require racket/contract) + + (provide regexp-match/c + id/c) + + (define (regexp-match/c rx) + (and/c (or/c string? bytes? path? input-port?) + (λ (s) (regexp-match? rx s)))) + + (define (id/c id) + (and/c identifier? (λ (i) (free-identifier=? i id))))) + + (require 'm-contracts)) \ No newline at end of file diff --git a/eval-get-values.rkt b/eval-get-values.rkt new file mode 100644 index 0000000..f40c80f --- /dev/null +++ b/eval-get-values.rkt @@ -0,0 +1,17 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (module m racket/base + (provide eval-get-values) + + (define (eval-get-values expr [namespace (current-namespace)]) + (call-with-values (λ () (eval expr namespace)) list))) + + (require "typed-untyped.rkt") + (if-typed + (begin + (require typed/racket/unsafe) + (unsafe-require/typed 'm [eval-get-values (->* (Any) (Namespace) (Listof Any))])) + (require 'm)) + + (provide eval-get-values)) \ No newline at end of file diff --git a/fixnum.rkt b/fixnum.rkt new file mode 100644 index 0000000..a479152 --- /dev/null +++ b/fixnum.rkt @@ -0,0 +1,13 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide fxxor fxxor2) + + ;; For fxxor, used to compute hashes. + ;; The type obtained just by writing (require racket/fixnum) is wrong, so we + ;; get a more precise one. + (require/typed racket/fixnum [(fxxor fxxor2) (→ Fixnum Fixnum Fixnum)]) + + (: fxxor (→ Fixnum * Fixnum)) + (define (fxxor . args) + (foldl fxxor2 0 args))) \ No newline at end of file diff --git a/generate-indices.rkt b/generate-indices.rkt new file mode 100644 index 0000000..9cce1fc --- /dev/null +++ b/generate-indices.rkt @@ -0,0 +1,23 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide generate-indices) + + (require "typed-untyped.rkt") + (require-typed/untyped "sequence.rkt") + (: generate-indices (∀ (T) (case→ (→ Integer (Syntax-Listof T) + (Listof Integer)) + (→ (Syntax-Listof T) + (Listof Nonnegative-Integer))))) + + (define generate-indices + (case-lambda + [(start stx) + (for/list ([v (my-in-syntax stx)] + [i (in-naturals start)]) + i)] + [(stx) + (for/list ([v (my-in-syntax stx)] + [i : Nonnegative-Integer + (ann (in-naturals) (Sequenceof Nonnegative-Integer))]) + i)]))) \ No newline at end of file diff --git a/ids.rkt b/ids.rkt new file mode 100644 index 0000000..c8ed503 --- /dev/null +++ b/ids.rkt @@ -0,0 +1,321 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test #:untyped-first + (provide !temp + (rename-out [!temp &]) + format-ids + hyphen-ids + format-temp-ids + #|!temp|# + define-temp-ids) + + (require "typed-untyped.rkt" + "untyped-only/syntax-parse.rkt") + (require-typed/untyped "sequence.rkt") + (if-typed (require phc-toolkit/aliases) + (require phc-toolkit/untyped/aliases)) + (begin-for-syntax (require "typed-untyped.rkt" + "untyped-only/format-id-record.rkt") + (if-typed (require phc-toolkit/aliases) + (require phc-toolkit/untyped/aliases))) + + (module m-!temp racket + (provide !temp) + + (require syntax/parse + syntax/parse/experimental/template) + + (define-template-metafunction (!temp stx) + (syntax-parse stx + [(_ id:id) + #:with (temp) (generate-temporaries #'(id)) + #'temp] + #|[(_ . id:id) + #:with (temp) (generate-temporaries #'(id)) + #'temp] + [(_ id:id ...) + (generate-temporaries #'(id ...))]|#))) + (require 'm-!temp) + + (require/typed racket/syntax + [format-id (→ Syntax String (U String Identifier) * + Identifier)]) + (require (only-in racket/syntax define/with-syntax) + (only-in syntax/stx stx-map) + (for-syntax racket/base + racket/format + racket/syntax + syntax/parse + syntax/parse/experimental/template)) + ;(require racket/sequence) ;; in-syntax + + (define-type S-Id-List + (U String + Identifier + (Listof String) + (Listof Identifier) + (Syntaxof (Listof Identifier)))) + + ; TODO: format-ids doesn't accept arbitrary values. Should we change it? + ; + (: format-ids (→ (U Syntax (→ (U String Identifier) * Syntax)) + String + S-Id-List * + (Listof Identifier))) + (define (format-ids lex-ctx format . vs) + (let* ([seqs + (map (λ ([v : S-Id-List]) + (cond + [(string? v) (in-cycle (in-value v))] + [(identifier? v) (in-cycle (in-value v))] + [(list? v) (in-list v)] + [else (in-list (syntax->list v))])) + vs)] + [justconstants (andmap (λ (x) (or (string? x) (identifier? x))) vs)] + [seqlst (apply sequence-list seqs)]) + (for/list : (Listof Identifier) + ([items seqlst] + [bound-length (if justconstants + (in-value 'yes) + (in-cycle (in-value 'no)))]) + + (apply format-id + (if (procedure? lex-ctx) (apply lex-ctx items) lex-ctx) + format + items)))) + + (: hyphen-ids (→ (U Syntax (→ (U String Identifier) * Syntax)) + S-Id-List * + (Listof Identifier))) + + (define (hyphen-ids lex-ctx . vs) + (apply format-ids + lex-ctx + (string-join (map (λ _ "~a") vs) "-") + vs)) + + (: format-temp-ids (→ String + S-Id-List * + (Listof Identifier))) + + (define (format-temp-ids format . vs) + ;; Introduce the binding in a fresh scope. + (apply format-ids + (λ _ ((make-syntax-introducer) (if (syntax? format) + format + (datum->syntax #f '())))) + format + vs)) + + (: to-identifier (→ Any Identifier)) + (define (to-identifier v) + (cond + [(identifier? v) v] + [(syntax? v) (datum->syntax v (to-symbol (syntax-e v)))] + [else (datum->syntax #f (to-symbol v))])) + + (: to-symbol (→ Any Symbol)) + (define (to-symbol v) + (cond + [(symbol? v) v] + [(string? v) (string->symbol v)] + [(number? v) (string->symbol (format "~a" v))] + [else (syntax-e (generate-temporary v))])) + + (: generate-string (→ String)) + (define (generate-string) + (symbol->string + (syntax-e + (generate-temporary "")))) + + (require (for-syntax (submod "stx.rkt" untyped))) + + + (: curried-map-on-attribute-step + (∀ (A B) (→ (→ A B) + (case→ (→ #f #f) + (→ (Listof A) (Listof B)) + (→ (U #f (Listof A)) + (U #f (Listof B))))))) + (define ((curried-map-on-attribute-step f) l) + (if (eq? l #f) + l + (map f l))) + + (: curried-map-on-attribute-last + (∀ (A B) (→ (→ (Syntaxof A) B) + (case→ (→ #f #f) + (→ (Syntaxof A) B) + (→ (U #f (Syntaxof A)) (U #f B)))))) + (define ((curried-map-on-attribute-last f) v) + (if (eq? v #f) + v + (f v))) + + ;; (map-on-attribute f depth) + (define-syntax (map-on-attribute stx) + (syntax-case stx () + [(_ f 0) + #'(curried-map-on-attribute-last f)] + [(_ f depth) + #`(curried-map-on-attribute-step + (map-on-attribute f + #,(sub1 (syntax-e #'depth))))])) + + (begin-for-syntax + (define-syntax-class dotted + (pattern id:id + #:attr make-dotted + (λ (x) x) + #:attr wrap + (λ (x f) (f x #t)) + #:attr depth 0 + #:with stx-depth #'0) + (pattern (nested:dotted (~literal ...));(~and dots (~literal ...)) ...+) + #:with id #'nested.id + #:attr make-dotted + (λ (x) #`(#,((attribute nested.make-dotted) x) (... ...))) + #:attr wrap + (λ (x f) (f ((attribute nested.wrap) x f) #f)) + #:attr depth (add1 (attribute nested.depth)) + #:with stx-depth #`#,(add1 (attribute nested.depth)))) + + (define-syntax-class simple-format + (pattern format + #:when (string? (syntax-e #'format)) + #:when (regexp-match #rx"^([^~]|~~)*~a([^~]|~~)*$" + (syntax-e #'format))))) + + ;; This macro should really be heavily refactored. + ;; TODO: merge all cases thanks to format-id/record and syntax classes. + (define-syntax (define-temp-ids stx) + (with-arrows + (syntax-parse stx + #| + ;; TODO : factor this with the next case. + [(_ format ((base:id (~literal ...)) (~literal ...))) + #:when (string? (syntax-e #'format)) + (with-syntax ([pat (format-id #'format (syntax-e #'format) #'base)]) + #'(define/with-syntax ((pat (... ...)) (... ...)) + (stx-map (curry format-temp-ids format) + #'((base (... ...)) (... ...)))))] +|# + + ;; Multiple formats + [(_ {~and {~optional #:concise} {~seq maybe-concise …}} + (format:simple-format …) + (~and (~seq options …) + (~seq base:dotted + (~or (~seq #:first-base first-base) + (~optional (~seq #:first first))) + (~optional (~seq #:prefix prefix))))) + #'(begin (define-temp-ids maybe-concise … format options …) …)] + + ;; New features (arrows and #:first) special-cased for now + ;; TODO: make these features more general. + + ;; With #:first-base, translated to #:first + [(_ {~and {~optional #:concise} {~seq maybe-concise …}} + format:simple-format base:dotted + #:first-base first-base + (~optional (~seq #:prefix prefix))) + #:with first (format-id/record #'format #'format #'first-base) + (template + (define-temp-ids maybe-concise … format base + #:first first + (?? (?@ #:prefix prefix))))] + + ;; Base case with a simple format "...~a...". + [(_ {~optional {~and #:concise concise?}} + format:simple-format + base:dotted + (~optional (~seq #:first first)) + (~optional (~seq #:first… first…)) + (~optional (~seq #:prefix prefix))) + (let* ([base-len (string-length (symbol->string (syntax-e #'base.id)))]) + (define/with-syntax pat + (format-id/record #'format #'format #'base.id)) + (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat)) + + (define/with-syntax maybe-generate-temporary + (if (attribute concise?) + #'to-identifier + #'generate-temporary)) + (define/with-syntax format-temp-ids-last + (template + (λ (x) + (car (format-temp-ids (?? (?@ (string-append "~a:" format) prefix) + format) + (maybe-generate-temporary x)))))) + (define/with-syntax format-temp-ids* + #'(map-on-attribute format-temp-ids-last base.stx-depth)) + (define/with-syntax (tmp-valvar) (generate-temporaries #`(base.id))) + (define/with-syntax do-define-pat + (syntax-parse (attribute-info #'base.id '(pvar attr)) + [({~datum attr} valvar depth name syntax?) + #'(define-raw-attribute pat + tmp-valvar + (format-temp-ids* valvar) + depth + syntax?)] + [({~datum pvar} valvar depth) + #'(define-raw-syntax-mapping pat + tmp-valvar + (format-temp-ids* valvar) + depth)])) + (define/with-syntax do-define-first… + (if (attribute first…) + (let () + (define/with-syntax (tmp-first-valvar) + (generate-temporaries #`(base.id))) + (syntax-parse (attribute-info #'base.id '(pvar attr)) + [({~datum attr} valvar depth name syntax?) + ;; TODO: always define an attribute, but don't use + ;; define-raw-attribute, instead use the copy-attribute + ;; code from subtemplate. + #`(define-raw-attribute first… + tmp-first-valvar + (car tmp-valvar) + #,(sub1 (syntax-e #'depth)) + syntax?)] + [({~datum pvar} valvar depth) + #`(define-raw-syntax-mapping first… + tmp-first-valvar + (car tmp-valvar) + #,(sub1 (syntax-e #'depth)))])) + #'(begin))) + (define/with-syntax do-define-first + (if (attribute first) + #'(define/with-syntax (first . _) + #'pat-dotted) + #'(begin))) + #'(begin do-define-pat + do-define-first + do-define-first…))] + + ;; Simplistic handling when the format contains no ~ at all. + ;; (TODO: should allow ~~) + [(_ {~optional {~and #:concise concise?}} format base:dotted) + #:when (string? (syntax-e #'format)) + #:when (regexp-match #rx"^([^~]|~~)*$" (syntax-e #'format)) + (define/with-syntax pat (format-id/record #'format #'format)) + (define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat)) + (define/with-syntax format-temp-ids* + ((attribute base.wrap) #`(λ (x) + #,(if (attribute concise?) + #'(car (format-temp-ids + (string-append format))) + #'(car (format-temp-ids + (string-append format "-~a") + (generate-string))))) + (λ (x deepest?) + (if deepest? + x + #`(curry stx-map #,x))))) + #'(define/with-syntax pat-dotted + (format-temp-ids* #'base))] + + ;; Very simplistic handling when the name is explicitly given. + [(_ {~optional {~and #:concise concise?}} + name:id format:expr . vs) + #`(define/with-syntax name (format-temp-ids format . vs))])))) \ No newline at end of file diff --git a/in.rkt b/in.rkt new file mode 100644 index 0000000..5422a9d --- /dev/null +++ b/in.rkt @@ -0,0 +1,13 @@ +#lang racket/base + +(provide in) + +(require racket/stxparam + (for-syntax racket/base)) + +(define-syntax-parameter in + (λ (stx) + (raise-syntax-error + 'in + "used out of context. It can only be used in some forms." + stx))) \ No newline at end of file diff --git a/info.rkt b/info.rkt new file mode 100644 index 0000000..87a60ee --- /dev/null +++ b/info.rkt @@ -0,0 +1,21 @@ +#lang info +(define collection "phc-toolkit") +(define deps '("base" + "rackunit-lib" + "alexis-util" + "typed-racket-lib" + "typed-racket-more" + "reprovide-lang" + "type-expander" + "hyper-literate")) +(define build-deps '("scribble-lib" + "racket-doc" + "typed-racket-doc" + "predicates" + "rackunit-doc" + "scribble-math" + "drracket")) +(define scribblings '(("scribblings/phc-toolkit.scrbl" (multi-page)))) +(define pkg-desc "My toolkit") +(define version "1.1") +(define pkg-authors '(|Georges Dupéron|)) diff --git a/is-typed.rkt b/is-typed.rkt new file mode 100644 index 0000000..96c2382 --- /dev/null +++ b/is-typed.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(provide if-typed) +;; if-typed +(define-syntax-rule (if-typed t u) t) \ No newline at end of file diff --git a/is-untyped.rkt b/is-untyped.rkt new file mode 100644 index 0000000..a9d29b6 --- /dev/null +++ b/is-untyped.rkt @@ -0,0 +1,4 @@ +#lang racket/base +(provide if-typed) +;; if-typed +(define-syntax-rule (if-typed t u) u) \ No newline at end of file diff --git a/licenses/bsd.txt b/licenses/bsd.txt new file mode 100644 index 0000000..21a8f5c --- /dev/null +++ b/licenses/bsd.txt @@ -0,0 +1,19 @@ +Copyright (c) 2000-2015 Dipanwita Sarkar, Andrew W. Keep, R. Kent Dybvig, Oscar Waddell + +Permission is hereby granted, free of charge, to any person obtaining a +copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/licenses/lgpl-3.0--license.txt b/licenses/lgpl-3.0--license.txt new file mode 100644 index 0000000..65c5ca8 --- /dev/null +++ b/licenses/lgpl-3.0--license.txt @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/light-no-check.rkt b/light-no-check.rkt new file mode 100644 index 0000000..3948a8e --- /dev/null +++ b/light-no-check.rkt @@ -0,0 +1,46 @@ +#lang racket/base + +(provide (except-out (all-from-out racket/base) + define) + (rename-out [new-: :] + [new-define-type define-type] + [new-define define] + [new-require/typed require/typed])) + +(require (for-syntax racket/base)) + +(begin-for-syntax + (define (process-arg stx) + (syntax-case stx (new-:) + [id/kw (or (identifier? #'id/kw) (keyword? (syntax-e #'id/kw))) #'id/kw] + [[_ _] stx] ;; [arg default] + [[arg new-: _] #'arg] + [[arg new-: _ default] #'[arg default]])) + (define (process-curried stx) + (syntax-case stx () + [id (identifier? #'id) #'id] + [(recur arg ...) + (with-syntax ([recur.no-types (process-curried #'recur)] + [(arg.no-types ...) + (map process-arg (syntax->list #'(arg ...)))]) + #'(recur.no-types arg.no-types ...))]))) + +(define-syntax (new-: stx) #'(begin)) +(define-syntax (new-define-type stx) #'(begin)) +(define-syntax (new-define stx) + (syntax-case stx (new-:) + [(_ #:∀ _ curried new-: _ e ...) + (with-syntax ([curried.no-types (process-curried #'curried)]) + #'(define curried.no-types e ...))] + [(_ #:∀ _ curried e ...) + (with-syntax ([curried.no-types (process-curried #'curried)]) + #'(define curried.no-types e ...))] + [(_ curried new-: _ e ...) + (with-syntax ([curried.no-types (process-curried #'curried)]) + #'(define curried.no-types e ...))] + [(_ curried e ...) + (with-syntax ([curried.no-types (process-curried #'curried)]) + #'(define curried.no-types e ...))])) + +(define-syntax-rule (new-require/typed mod [id τ] ...) + (require (only-in mod id ...))) \ No newline at end of file diff --git a/list-lang.rkt b/list-lang.rkt new file mode 100644 index 0000000..6575f87 --- /dev/null +++ b/list-lang.rkt @@ -0,0 +1,16 @@ +#lang racket + +(require typed/racket);(only-meta-in 0 typed/racket)) + +(provide (except-out (all-from-out typed/racket) + #%module-begin) + (rename-out [module-begin #%module-begin])) + +(require (for-syntax syntax/parse)) + +(define-syntax (module-begin stx) + (syntax-parse stx + [(_ forms ... ((~literal define-list-values) name rest ...) values ...) + #'(#%module-begin (define-for-syntax name '(values ...)) + (define name rest ... '(values ...)) + forms ...)])) \ No newline at end of file diff --git a/list.rkt b/list.rkt new file mode 100644 index 0000000..7637362 --- /dev/null +++ b/list.rkt @@ -0,0 +1,103 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (define-syntax (skip<=6.6 stx) + (syntax-case stx () + [(_ . rest) + (if (or (regexp-match #px"^6(\\.[012345](\\..*|)|)$" (version)) + (regexp-match #px"^6.6$" (version)) + (regexp-match #px"^[123245]\\..*$" (version))) + #'(begin) + #'(begin . rest))])) + + (skip<=6.6 + (provide replace-first)) + + (provide indexof + map+fold + AListof + List3-Maybe + List3 + Listof*) + + (define-type (AListof K V) (Listof (Pairof K V))) + (define-match-expander alistof + (λ (stx) + (syntax-case stx () + [(keys-pat vals-pat) + #'(list (cons keys-pat vals-pat) …)]))) + + (: indexof (∀ (A B) (->* [A (Listof B)] [(→ A B Any)] (U #f Integer)))) + (define (indexof elt lst [compare equal?]) + (let rec ([lst lst] [index 0]) + (if (null? lst) + #f + (if (compare elt (car lst)) + index + (rec (cdr lst) (+ index 1)))))) + + (define-type (List3-Maybe Start Mid End) + (Listof* Start + (U Null + (Pairof Mid (Listof End))))) + + (define-type (List3 Start Mid End) + (Listof* Start + (Pairof Mid (Listof End)))) + + (define-type (Listof* Start End) + (Rec R (U (Pairof Start R) + End))) + + (skip<=6.6 + (: replace-first (∀ (A B1 B2 C D) + (case→ + (→ C + (Listof (U A B1)) + (→ (U A B1) Any : #:+ B1 #:- (! B1)) + (List3-Maybe A C (U A B1))) + (→ C + (Listof* A (U Null (Pairof B2 D))) + (→ (U A B2) Any : #:+ (! A) ;; ∴ (and (! A) B2) + #:- (! B2)) + (Listof* A (U Null (Pairof C D)))) + (→ C + (Listof* A (Pairof B2 D)) + (→ (U A B2) Any : #:+ (! A) ;; ∴ (and (! A) B2) + #:- (! B2)) + (Listof* A (Pairof C D))) + (→ C + (Listof A) + (→ (U A B1) Any) + (List3-Maybe A C (U A B1))) + (→ A + C + (Listof A) + (List3-Maybe A C (U A B1))) + (→ A + C + (Listof A) + (→ A (U A B1) Any) + (List3-Maybe A C (U A B1)))))) + (define (replace-first a1 a2 a3 [a4 eq?]) + (if (list? a3) + (replace-first a2 a3 (λ ([x : (U A B1)]) (a4 a1 x))) + (let ([to a1] + [pred? a3]) + (let rec ([l a2]) + (if (null? l) + '() + (if (pred? (car l)) + (cons to (cdr l)) + (cons (car l) + (rec (cdr l)))))))))) + + (: map+fold (∀ (E R A) (→ (→ E A (values R A)) A (Listof E) + (Values (Listof R) A)))) + (define (map+fold f init-acc lst) + (if (null? lst) + (values '() init-acc) + (let*-values ([(item new-acc) (f (car lst) init-acc)] + [(new-lst last-acc) (map+fold f new-acc (cdr lst))]) + (values (cons item new-lst) + last-acc))))) \ No newline at end of file diff --git a/logn-id.rkt b/logn-id.rkt new file mode 100644 index 0000000..24b36cf --- /dev/null +++ b/logn-id.rkt @@ -0,0 +1,82 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide define-logn-ids) + + (require (for-syntax syntax/parse + racket/syntax + racket/function + racket/match + syntax/stx) + "typed-untyped.rkt") + + (begin-for-syntax + (define (insert make-node v ts) + (match ts + [`() `((,v))] + [`(() . ,b) `((,v) . ,b)] + [`((,a) . ,b) `(() . ,(insert make-node (make-node v a) b))])) + + (define (merge-trees make-node ts) + (match ts + [`{[,a]} a] + [`{[,a] [] . ,rest} (merge-trees make-node `{[,a] . ,rest})] + [`{[] . ,rest} (merge-trees make-node rest)] + [`{[,a] [,b] . ,rest} (merge-trees make-node + `{[,(make-node a b)] . ,rest})])) + + (define (make-binary-tree l make-node make-leaf) + (merge-trees make-node + (foldl (curry insert make-node) + '() + (map make-leaf l))))) + + (define-syntax (define-logn-ids stx) + (syntax-parse stx + [(_ matcher:id [id:id ty:id] ...) + (define/with-syntax (tmp ...) (generate-temporaries #'(id ...))) + (define bt + (make-binary-tree (syntax->list #'([ty id . tmp] ...)) + (λ (x y) `(node ,(generate-temporary) ,x ,y)) + (λ (x) `(leaf ,(stx-car x) + ,(generate-temporary (stx-car x)) + ,(stx-car (stx-cdr x)) + ,(stx-cdr (stx-cdr x)))))) + (define (make-structs bt parent) + (match bt + [`(node ,s ,a ,b) #`(begin (struct #,s #,@parent ()) + #,(make-structs a (list s)) + #,(make-structs b (list s)))] + [`(leaf ,t ,s ,a ,_) #`(begin (struct #,s #,@parent + () + #:type-name #,t) + (define #,a (#,s)))])) + (define (make-btd bt) + (match bt + [`(node ,s ,(and a `(,_ ,sa . ,_)) ,b) + #`(if (if-typed ((make-predicate #,sa) v-cache) + #,(format-id sa "~a?" sa)) + #,(make-btd a) + #,(make-btd b))] + [`(leaf ,s ,a ,t ,tmp) + tmp])) + #`(begin #,(make-structs bt #'()) + (define-syntax (matcher stx) + (syntax-parse stx + [(_ v:expr [(~literal id) tmp] ...) + #'(let ([v-cache v]) + #,(make-btd bt))])))])) + + (module* test typed/racket + (require (submod "..") + typed/rackunit) + + (define-logn-ids match-x [a A] [b B] [c C] [d D] [e E]) + + (check-equal? (match-x (ann b (U A B C D E)) + [a 1] + [b 2] + [c 3] + [d 4] + [e 5]) + 2))) \ No newline at end of file diff --git a/main.rkt b/main.rkt new file mode 100644 index 0000000..f574408 --- /dev/null +++ b/main.rkt @@ -0,0 +1,45 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (require "typed-untyped.rkt") + (provide (all-from-out "typed-untyped.rkt")) + + (if-typed + (begin (require "aliases.rkt") + (provide (all-from-out "aliases.rkt"))) + (begin (require "untyped/aliases.rkt") + (provide (all-from-out "untyped/aliases.rkt")))) + + ;(require/provide (typed/untyped "fixnum.rkt" …)) + (require/provide-typed/untyped + "misc.rkt" + "require-provide.rkt" + "fixnum.rkt" + "typed-rackunit.rkt" + "typed-rackunit-extensions.rkt" + "syntax-parse.rkt" + "tmpl.rkt" + "threading.rkt" + "sequence.rkt" + "repeat-stx.rkt" + "stx.rkt" + "list.rkt" + "values.rkt" + "ids.rkt" + "generate-indices.rkt" + "set.rkt" + "type-inference-helpers.rkt" + "percent.rkt" + "not-implemented-yet.rkt" + "cond-let.rkt" + "multiassoc-syntax.rkt" + "tmpl-multiassoc-syntax.rkt" + "logn-id.rkt" + "compat.rkt" + "eval-get-values.rkt" + "meta-struct.rkt" + "contract.rkt") + + (when-untyped + (require/provide "untyped/for-star-list-star.rkt" + "untyped/format-id-record.rkt"))) \ No newline at end of file diff --git a/meta-struct.rkt b/meta-struct.rkt new file mode 100644 index 0000000..24cd87f --- /dev/null +++ b/meta-struct.rkt @@ -0,0 +1,131 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (require (for-syntax syntax/parse/experimental/template + syntax/parse + racket/syntax)) + + (begin-for-syntax + (provide meta-struct? + (struct-out meta-struct-info) + get-meta-struct-info + ;; More provided by `shorthand` in the code below + meta-struct-subtype? + struct-type-id-is-immutable?)) + (provide struct-predicate + struct-constructor + struct-accessor + struct-type-is-immutable? + struct-instance-is-immutable?) + + (module info racket/base + (require racket/struct-info) + + (provide meta-struct? + (struct-out meta-struct-info) + get-meta-struct-info) + + (define (meta-struct? s) + (and (identifier? s) + (let ([v (syntax-local-value s (λ _ #f))]) + (and v (struct-info? v))))) + + (struct meta-struct-info + (type-descriptor + constructor + predicate + accessors + mutators + super-type) + #:transparent) + + (define (get-meta-struct-info s + #:srcloc [srcloc #f] + #:fallback [fallback #f]) + (if (meta-struct? s) + (apply meta-struct-info + (extract-struct-info (syntax-local-value s))) + (if fallback + (fallback) + (raise-syntax-error 'get-struct-info + "not a structure definition" + (or srcloc s) + s))))) + + (require 'info + (for-syntax 'info)) + + (define-syntax (shorthand stx) + (syntax-case stx () + [(_ base) + (with-syntax ([name (format-id #'base "meta-struct-~a" #'base)] + [accessor (format-id #'base "meta-struct-info-~a" #'base)] + [tmpl (format-id #'base "!struct-~a" #'base)]) + #'(begin-for-syntax + (provide name tmpl) + (define-template-metafunction (tmpl stx) + (syntax-parse stx + [(_ s + (~optional (~seq #:srcloc srcloc)) + (~optional (~seq #:fallback fallback))) + (accessor + (get-meta-struct-info #'s #:srcloc (attribute srcloc)))])) + (define (name s #:srcloc [srcloc #f] #:fallback [fallback #f]) + (define err (gensym)) + (define val + (get-meta-struct-info s + #:srcloc srcloc + #:fallback (and fallback (λ () err)))) + (if (and (eq? val err) fallback) + (fallback) + (accessor val)))))])) + + (shorthand type-descriptor) + (shorthand constructor) + (shorthand predicate) + (shorthand accessors) + (shorthand mutators) + (shorthand super-type) + + (define-syntax (struct-predicate stx) + (syntax-case stx () + [(_ s) (meta-struct-info-predicate (get-meta-struct-info #'s))])) + (define-syntax (struct-constructor stx) + (syntax-case stx () + [(_ s) (meta-struct-info-constructor (get-meta-struct-info #'s))])) + (define-syntax (struct-accessor stx) + (syntax-case stx () + [(_ s field) + (identifier? #'field) + (begin + (record-disappeared-uses (list #'s #'field)) + (format-id #'s "~a-~a" #'s #'field))] + [(_ s i) + (exact-positive-integer? (syntax-e #'i)) + (list-ref (meta-struct-info-accessors (get-meta-struct-info #'s)) + (syntax-e #'i))])) + + (define-for-syntax (meta-struct-subtype? sub super) + (or (equal? (meta-struct-type-descriptor sub) + (meta-struct-type-descriptor super)) + (let ((up (meta-struct-super-type sub))) + (and (meta-struct? up) + (meta-struct-subtype? up super))))) + + (define-for-syntax (struct-type-id-is-immutable? id) + (andmap not (meta-struct-mutators id))) + + (define (struct-type-is-immutable? [st : Struct-TypeTop]) : Boolean + (let-values ([(_1 nfields _3 _4 _5 immutable-idx super not-most-specific?) + (struct-type-info st)]) + (and (not not-most-specific?) + (equal? (sort immutable-idx <) + (range nfields)) + (if super (struct-type-is-immutable? super) #t)))) + + (define (struct-instance-is-immutable? v) + + (let-values ([(st not-most-specific?) (struct-info v)]) + (and (not not-most-specific?) + st + (struct-type-is-immutable? st))))) \ No newline at end of file diff --git a/misc.rkt b/misc.rkt new file mode 100644 index 0000000..e493cc1 --- /dev/null +++ b/misc.rkt @@ -0,0 +1,75 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide hash-set** + ;string-set! + ;string-copy! + ;string-fill! + with-output-file + or?) + + (require (for-syntax syntax/parse syntax/parse/experimental/template)) + + ;; hash-set**: hash-set a list of K V pairs. + (begin + (: hash-set** (∀ (K V) + (→ (HashTable K V) (Listof (Pairof K V)) (HashTable K V)))) + (define (hash-set** h l) + (if (null? l) + h + (hash-set** (hash-set h (caar l) (cdar l)) (cdr l))))) + + ;; Disable string mutation + (begin + (define-syntax (string-set! stx) + (raise-syntax-error 'string-set! "Do not mutate strings." stx)) + (define-syntax (string-copy! stx) + (raise-syntax-error 'string-copy! "Do not mutate strings." stx)) + (define-syntax (string-fill! stx) + (raise-syntax-error 'string-fill! "Do not mutate strings." stx))) + + ;; with-output-file + (begin + #| + (define-syntax (with-output-file stx) + (syntax-parse stx + [(_ filename:expr (~optional (~seq #:mode mode:expr)) + (~optional (~seq #:exists exists:expr)) + body ...) + (template (with-output-to-file filename + (λ () body ...) + (?? (?@ #:mode mode)) + (?? (?@ #:exists exists))))])) + |# + + (define-syntax (with-output-file stx) + (syntax-parse stx + [(_ [var:id filename:expr] + (~optional (~seq #:mode mode:expr)) + (~optional (~seq #:exists exists:expr)) + body ...) + (template (call-with-output-file filename + (λ (var) body ...) + (?? (?@ #:mode mode)) + (?? (?@ #:exists exists))))]))) + + #;(: or? (∀ (A B) (case→ (→ (→ A A)) + (→ (→ A B) (→ A B) * (→ A B))))) + #;(define or? + (case-lambda + [() (λ (a) + a)] + [(f . f*) (λ (a) + (let ([b (f a)]) + (if (or b (null? f*)) + b + ((apply or? f*) a))))])) + + (: or? (∀ (A) (→ (→ A Boolean) * (→ A (U A #f))))) + (define (or? . f*) + (if (null? f*) + (λ (a) a) + (λ (a) + (if ((car f*) a) + a + ((apply (inst or? A) (cdr f*)) a)))))) \ No newline at end of file diff --git a/multiassoc-syntax.rkt b/multiassoc-syntax.rkt new file mode 100644 index 0000000..67994a4 --- /dev/null +++ b/multiassoc-syntax.rkt @@ -0,0 +1,36 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide multiassoc-syntax + cdr-assoc-syntax + assoc-syntax) + + (require "typed-untyped.rkt") + (if-typed (require phc-toolkit/aliases) + (require phc-toolkit/untyped/aliases)) + (require-typed/untyped "stx.rkt") + + ;; TODO: cdr-stx-assoc is already defined in lib/low.rkt + + (define-type (Stx-AList A) + (Syntaxof (Listof (Syntaxof (Pairof Identifier A))))) + + (: multiassoc-syntax (∀ (A) (→ Identifier (Stx-AList A) (Listof A)))) + (define (multiassoc-syntax query alist) + ((inst map A (Syntaxof (Pairof Identifier A))) + stx-cdr + (filter (λ ([xy : (Syntaxof (Pairof Identifier A))]) + (free-identifier=? query (stx-car xy))) + (syntax->list alist)))) + + (: cdr-assoc-syntax (∀ (A) (→ Identifier (Stx-AList A) A))) + (define (cdr-assoc-syntax query alist) + (stx-cdr (assert (assoc-syntax query alist)))) + + (: assoc-syntax (∀ (A) (→ Identifier + (Stx-AList A) + (U False (Syntaxof (Pairof Identifier A)))))) + (define (assoc-syntax query alist) + (findf (λ ([xy : (Syntaxof (Pairof Identifier A))]) + (free-identifier=? query (stx-car xy))) + (syntax->list alist)))) diff --git a/not-implemented-yet.rkt b/not-implemented-yet.rkt new file mode 100644 index 0000000..9196a9d --- /dev/null +++ b/not-implemented-yet.rkt @@ -0,0 +1,19 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide ? ?*) + + (define-syntax (?* stx) + (syntax-case stx () + [(q . rest) + (quasisyntax/loc stx + ((λ () : (U) #,(syntax/loc #'q (error "Not implemented yet")) + . rest)))])) + + (define-syntax (? stx) + (syntax-case stx () + [(q t . rest) + (quasisyntax/loc stx + ((ann (λ () #,(syntax/loc #'q (error "Not implemented yet")) + . rest) + (→ t))))]))) \ No newline at end of file diff --git a/partial-include.rkt b/partial-include.rkt new file mode 100644 index 0000000..d055aea --- /dev/null +++ b/partial-include.rkt @@ -0,0 +1,51 @@ +#lang racket/base +(provide include-without-first-line) + +(require (for-syntax racket/base)) + +(define-for-syntax (replace-context ctx stx) + (define (recur e) + (cond + [(syntax? e) (datum->syntax ctx (recur (syntax-e e)) e e)] + [(pair? e) (cons (recur (car e)) (recur (cdr e)))] + [(null? e) e] + [(vector? e) ((if (immutable? e) + vector->immutable-vector + (λ (v) v)) + (list->vector + (recur (vector->list e))))] + [(hash? e) ((if (immutable? e) + (cond [(hash-eq? e) make-immutable-hasheq] + [(hash-eqv? e) make-immutable-hasheqv] + [else make-immutable-hash]) + (cond [(hash-eq? e) make-hasheq] + [(hash-eqv? e) make-hasheqv] + [else make-hash])) + (recur (hash->list e)))] + [(prefab-struct-key e) => (λ (k) + (apply make-prefab-struct + k + (recur (cdr + (vector->list + (struct->vector e))))))] + [(box? e) ((if (immutable? e) box-immutable box) + (recur (unbox e)))] + [else e])) + (recur stx)) + +(define-syntax (include-without-first-line stx) + (syntax-case stx () + [(_ filename1-stx . filename+-stx) + (let*-values ([(user-filename) (map syntax-e + (syntax->list + #'(filename1-stx . filename+-stx)))] + [(base _1 _2) (split-path (syntax-source #'filename1-stx))] + [(filename) (apply build-path base user-filename)]) + (with-input-from-file filename + (λ () + (read-line) ;; discard the first line. + (replace-context + #'filename1-stx + #`(begin + . #,(for/list ([rd (in-producer read-syntax eof filename)]) + rd))))))])) \ No newline at end of file diff --git a/percent.rkt b/percent.rkt new file mode 100644 index 0000000..32916f7 --- /dev/null +++ b/percent.rkt @@ -0,0 +1,78 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide % define% in let1) + + (require (for-syntax syntax/parse + "typed-untyped.rkt") + "in.rkt") + (begin-for-syntax + (if-typed (require phc-toolkit/aliases) + (require phc-toolkit/untyped/aliases))) + + (define-syntax-rule (let1 var val . body) + (let-values ([(var) val]) . body)) + + #|(define-syntax (% stx) + (syntax-parse stx #:literals (= → :) + [(_ (~seq (~or ((~and var (~not :)) ...) + (~seq (~and var (~not (~or = → :))) ...)) = expr) + ... + (~optional (~literal →)) . body) + #'(let-values ([(var ...) expr] ...) . body)]))|# + + (begin-for-syntax + (define-syntax-class %pat + (pattern v:id + #:with expanded #'v) + (pattern () + #:with expanded #'(list)) + (pattern (x:%pat . rest:%pat) + #:with expanded #'(cons x.expanded rest.expanded)) + (pattern #(x:%pat …) + #:with expanded #'(vector x.expanded …))) + (define-splicing-syntax-class %assignment + #:attributes ([pat.expanded 1] [expr 0]) + #:literals (= in) + (pattern (~seq (~and maybe-pat (~not (~or = in))) ... + (~datum =) expr:expr) + #:with [pat:%pat ...] #'(maybe-pat ...)))) + + (define-syntax (% stx) + (syntax-parse stx #:literals (= in) + [(_ :%assignment ... (~optional (~literal in)) . body) + #'(match-let*-values ([(pat.expanded ...) expr] ...) . body)])) + + (begin-for-syntax + (define-syntax-class typed-pat + (pattern [x:%pat (~literal :) type:expr] + #:with (tmp) (generate-temporaries #'(x)) + #:with var-type #`[tmp : type] + #:with (expanded ...) #'([x.expanded tmp])) + (pattern x:id + #:with var-type #'x + #:with (expanded ...) #'()) + (pattern x:%pat + #:with (tmp) (generate-temporaries #'(x)) + #:with var-type #'tmp + #:with (expanded ...) #'([x.expanded tmp])))) + + (define-syntax (define% stx) + (syntax-parse stx + [(_ (name param:typed-pat ...) + (~and (~seq ret ...) (~optional (~seq (~literal :) ret-type))) + . body) + #'(define (name param.var-type ...) + (match-let (param.expanded ... ...) ret ... . body))])) + + #| + (begin-for-syntax + (define-syntax-class λ%expr + (pattern e:id #:where (symbol->string e)) + (pattern e) + (pattern (e . rest:λ%expr)))) + + (define-syntax (λ% stx) + (syntax-parse stx + [(_ expr )])) + |#) \ No newline at end of file diff --git a/perf.rkt.ods b/perf.rkt.ods new file mode 100644 index 0000000000000000000000000000000000000000..ba21887acd21fae89215a76ef68058deab170a24 GIT binary patch literal 48074 zcmbsRb9iOT)(4EHlXPseW81c!bZpyp(jD8jZQHhOcWmQJ@AI9#`|SJN_x^G7JTt3m z*5Gf98nb4tIhU*i5HJz|02lzkcdrz2e+#w{Y5)L$-^b@E083L#LkCwILtPsi3sZev z2UBY+8Ye3QYHMA4Q+sM_8$&AtYkfycLn{YrdmB4LT?2a)LqiAIzhr`ef&C@(Q_SCg zke@AmYb%G}3@(-yXBz6UJ1y{Dla*PbiW&G}W9g@3WEU+HvsN+e#`5vX;Z(e;tJl$e z8WWW=qXPxw0Hw_?Dod`q0q2$Z3D5GSL{K(Z~Mr^;`JJ3MJPzrRF?xxMF+UD`pwjVF9`BJkqpdci^H_=Nuy`&|s+G++p(y!HY^6(;1 z=@B{QEVAt^j#dH3$qo^zf-uiOJ?j|@!g~D0=Tcqb$qjxvcnTECqf%i}2OG!Yxl^0_ z<6F7QNQ2ImCoOz3Gv(?;SPdU5>r8Z^3w3-kiP3h32cDYO+3HB%@b;W;J+edbjtdRa z8oEoAunv5zdiTZq%24^>6YUKI+(e-Ww8>^|lA9QRQ{%8U)ybPF-lD2T!B0E-N6(4) zD)Iy*qZ?t!r0!r3;n-9z==v$qTOX47^jkGN~-w#x=t5=CFpi(nro41@ROINbSzOIyhg)D*}@)1hw;}pNW3#1=h z+>w6Tc=nusqtxjoEoi*q7}d$=!>`CH7X4Py;;r92_p#I+-(yucUDqE=G^vA+t9itc z?FbYNiO9#_ZYYj)dK1xlFJo#jtxB@jNU1MT#c{OBT@@M&yK;F;q~&EuVH!I@&}r5$ z;r;;A??_;54up*kADxrVzSVEuyC^!-QX8Hq^zBDFi)x{2V@)4_43Kv-z0b)6|AaM? z@#YXTD7k=d!%0a$^s98A(;^noc%iAI90R&EAcnz>dh5)`hg8wV*g6U`)*V zgL5m)hRrkaB!0e0?9ckbMgH`3{Q>eQS&4FX3cQ&?!R(ARS0K{-QAfT~^^xMyX|a2;SnY7YGSK zL>7_olOa3x!L9XNg6az7Syd%!v9u)jI6V#%1YnSkI7gj0;S9zh$ojs~2|~l!(K)*F zFOrt+wJ4{eP63ZYA{Sd3RdQ=XkGksYUESgRZvD;8@3PljC`KoFOGm*60|A{mLk;8p zLwYe)m>InL9Xi3(Z8UQICj&WYnc7bn!o#`=;-=g1%h$~{a}){cGNZwASu}@7GDSIh zF#gJ&>eKqGyxleIQ^2JmO0)7HI0%O)h@WS5+_(A@+zy4IVuf%ZX8=$yoX006ZhUY!=R#9@aP_Wb_SR5m>&Ef znN?Wm9z7s<^kCIk=zhLFZ~Hw>PdH_P(zdB|+GH@G85s|i-%TPJ{MR`5XgAgJTx|~>-<&URQ}#K=}OV%oGSHxl$jj)b)ZS=dwV z3SvbZQpenK=?c`n=W^u*n`|RzlnYh|f#|HKrZy)V;D&v_6j1fR(mKO=1zigGiCll4 zf$xcg`!*~<2s;4ABkV#58_k)7`wF}r%_(@T6LKm4A0qUg$^Q_U;DDAz5-bejo#>|u zM`6lY`JoRc@9@fFnU;Z96KAn5A&Fp`^Ou2>!m#$k52nDG1BUoY+s;)J_oe*U>5|8C z{SVnAk_gUUWW)gdP+fnKiSg1wR(+Cn4RT)6!Tz^}>HhWL=cdX<_}5L9t8k)7*Dd{T zk4c~^hwFabS_wWB3Y0ci1JT5a5)W4+d9x>=!r?}UH%I@La> z@7{A3XT8O0`XQ*iE>~@%&1xMgNIz?7Qqkgj<<%%|b2hKDCjF2bE&q@!$FV*;-Bs+} zl@9KCttc24H_UQ%?cd-%65!cLhIzkg*F|U4yG!TZ0Q4Tl&IZtQLlB+_fnCpFE#KHA zr4F$==X|nZ9o(=RjA=O-%U}?`<6Y)YZZ&Ex^xF5VXa7}=GrE?nol%bSP_}uXYNO?l zpN`#jEIf9%`D!riihoTYOieA#ipHBA5u@lr z=@(!{evR%{LK=YcJs&Z^R4SH!U!5dxB*Xy=qV_wfr?VMhM}22HkWCDP zQuq!MnQ7_l^KCd%EBaDDUtC8eSd2bZ3Q+9KuIt`o^BkWy-pMuY8lSy8bDMwA5vY5# zPI2Q?*PyMux+Y!_;o#mA=wo!7vtI=IIxx~NwqMf47EOU%=^_R}QfFpY zIi}>)Pnt?@m6SRYvQ}E$lhQ~OYF&6?@!1dVdim_5(prWTdX!wY8<6gk9=HZ0pQ+eR zn%FkNG>FHS(ym=R7{A;wP}kUWXiy6X+<^>cRF(lVXoz7U2;Umfr)7={45lLb7p@e# zrV=A7dP(#dm{j#}RVMg|>ipb2Zb~aCBAX4V)MRFBaasl&yFv*awlzvx&9=*sgpI$+ zBTLn<$G*BKz2t%$&wRLuuqC=Kb~oKXQK-(^-_ut+FW@{}OD*|oQG;oZD(3*datQM9 zPWYlFDNN${lpHG}Rj)gE?>l7f}UuM31 zWZ9*}tVDlYFb1l|hwTtAkBSg_MXttsro^!DN;@E+ShZ6cVk}qo<`D_NC9+@1paVOv zjT|A>2?fed8-b4roPnUh%+y2}YF9hE<{S?iy1Yjm+oE-8M!F+jyv3_1&q1Ez5uJmC`8`}0fC{pxdwTXX7aR_*$%rcSC)Hx z+qiQF&lKy*FF`nyQhWPRhX>mw)+i6u6F>}vs zf#+68>bQ~h5DY3SP_x`iKvE%^YgEWyWc4-T#x)k~(mr_PIv3WBdAk)Tp|K(Vca3T{ z3%eBaSV{4mBw7^Kdj!Zda1ARta9c6I99nZ#1RGxztsFmbe@HH;aa3cP>sPQ~n8A)L zItRkG?;UzgL*!{+n2?R|0)Q0&Pu<-S9Tahk+?$SaekrgXAC~9NwP0-*!g_|c{Gzwx zDVd#ZtSg<5^?K6bWB_&Jx!P8X^ir-i4ni#u!P;E-R5NLba?{Q24>JC$#$SU zAWIB2#3%$A8$EGApLm*%Wu*q+ttcHP0 zfwNMjqiFoLT0^dATSlh8GdJUX^#21^+}LqIk@Y zBueQ8;LgOnOsVe)W_EgXIaxs29QY7Gu}ogyXP&6Am#tpU=&zfyjnUSwtHI4L;O-Q2 z;;S49LVRFm%e+QRb=BNJ?7+v1VsvtrO?V3z;g$Kj#vf?w<~dtl(VFE?S$&tL7ln5V z;0dxYr?40l=tcQx0gQM#3QbNxf=Dc#=OiynIE6)z9u|tLlb?W62H(43o~Vqal{u)f ztqGV}yx-pg7nkH}&~ZJ$Q@T~8Q(vp@7^Dau9bkh4V4pq!H}w*CXGoNyWmh$wk`(ur zZwiy$+VAl~M`PwIc*~<;2C+?vUe4Y1XBm$iCV!G0{AAlx0TDJD(PFv>j7*}A6dyQf zBM>p)FyEqsnShQithOyjh5SH)uD9iiMsK)XNi;+{r=cxl;Z#F%;6$FjKiLdZYI%++BEZaoq*IE!5lHKE+ zNM_2psq~p^)`!URSw(dN6E9%)M!yS(;z+D`mIHN$>7g^*9JuWYLF2v@ub;T>7(46+ zkl!r22N(nX-YAl3vF$K;l~bQ!R{`4I(Ce_eydd4gsLWOyA_M{~{9PqtCA5d$S;@Nj z`*VI`CrrTZ{anE7E^|-aCQFs26}TcL(cdLfI&34jRkg-_Su3 zNuRPXPA|X4BlcXSXUK*0Y4h!hez=%mV9|at%tOU**Y~=hyY=+Bv*8TPMJ^%UQ*lGS zX1z=nD*rVnx-jtqzWx z)P&xy^GDI-cOH}4GuoEq);A1uF2uAFlp_);Fn3mN;4`VWjSt|O&~G&rtHv#sroJ6; zr^^hZg++Q&C@-&Vpn~Rw3o&9@6X&#?(bH@Y1q_pZW14^n6e-#{M}SmXAgQDf~Khz}0dx&$Je^@4r66b2Z2v?)R7`wB+TD~06{Jw~m z)OZU(g8~4Q|cTUqZuU$0Jf{k^CP#A@(Lv!p?XRLTP7A6ddVtmCVQ; zQQ=>tj~AAr>F{punY>L4Vucd1I_xK}n2;V0)kH{a!fT9tMPqWn!m7R}_kwtCdW9$- zb-c2#YkoR75H(*xoILHcQ`bFjMH2QWWTI-?|4gYPd8{f#u7!TNruW z$jaQnVH?m~B*K;`}FGX~H%fIGXJ5YNTvCE!E7#JG||)trWp zi#y@lj!6pjY8M&T=RMnK}B|Csog9r}_@J7o@5Q7{9!sL8Xr}W5*xvNAex$>JOu-=l*w2*Q3Z4i*rDO zA~X;`N-Kc#Z;_U#N1GjLwyTlB&vBy_*wcV`~04EdK25ZyjRPOhJ<=$Bv8pQo0 zEC+2pP+%uzEl%I}_w&;u4&=G^%v*}h$x}ToAmBSO#Ze3<@&-WKH=5Jm8rVTeBKaAr zh+VO+J9(Pf(T2EN6!@b03hZ6dnwT5v#EeDo-oG)GTCCqN!79uk`xXP#^i7R`&U4TC z#!;BhwAOe7yCPqLs!%WtWfoU97*6$u-e`RoJhDxVH_YAXde5~Mg>FKNF6FNUl3a#1 z;8JhqJA@x3E-hZ6?WlKd6)5n_ccl>e6=4U@nE|R@+KV{|YT4aB#b5@J>Q7a6cdHT- zhH%6w{35u_r`+&0a(}{ls-)k$(PcPdgLsB+#vg-5SM<(-?Z;lqVg0#}i*zTMjoLOz zFn2)4b-xMlJ}2)0O7`q?DJA5BaZUWtXt+P3i>g>-hi}yik&&yF`yDMVBRyb98{RiR zz%+ga{0K-_4xZ_*ZqpnCxaOyz_6NM@9NgNv-fL=>&@U}Kdfc@XQg}W#yW!s5Fgd0) zargDw_z*84rQ!KEgS#tW`UdoB$@e^y37OX3U<;7*5fHU`Ui0vG|w zEf9it_C5mJD&~(&`T|33W!+wXsRUwmYUh+e68 zGD1X$p{v7#+F_NpHjnIT>APQF?jAc!5(;MB)kE%Mh-T{(njz+NmS5#dD0UYiYJ3CB zp5B8e(ZmsnB8Sa?Jo!+KGvjg}-wkanboC8?Z?oIe z{O1%d{h6k>4a%Ua7Wfyy4p?wMKiWR9XgFFhO!)7SVzi<~0|Q_`8Noy?%SaJ)c$2iL z2kO=htN3B(LAm|BuJr5UkjxE%}DOL6St#1;q7 zKP4xzl`JnbFkzppa4=hIY}Vwq8_q@)B&1qdA)D~7jCUr^J^(wVNbXV&c+qt? zdJ7XtIX|L2*>O!0ZNhxSL5V>Z?+j<1yezRUWRxHno|fpcUK0$FkaP1Dn4uw4m77B@ zK&jvM$2LamZ;W-8{^&lbA1l3}f7_#^0gE9z%q&5<^I2HR_gkZOB414b1f+FeUD)spa9XUR! zLT-vCWh65XdvPb8pjbC~#O5Ful5TY24n089K1fOaQbHSK&kZy&S@a)iXnky%Uk*_f z|054-CvEb_4a-8%U()~6!>;|04Is7?#$8VwhkuTFb1VO$fk&R^4-MWg^8azfm-Ucg z>($@?&mIkG=pQOR+7}4?h z+0!mV{tLYSxQo;IKfp{-{YeVT@~4NDb$=pb-T0^3MCpI>jh+43i&^~xHCN7GzomHE z^TYiG_da5Va5}87LI0B?B4ryb;cuXWZU#0J5PpN)=ek=N0{$DdowlooJ-^?c+ipBc z`1E{6HH_8z6-rb6RN0VRz)0;)RV<6`IQo?O55(PNxaK$@3Z*TtG8pm3r1V9I45S99VZz? z=pl%EX`j5o(zi(@JRF%M-0(x_sDNjz6TZ;b1;&B+Vo`y@AiJW41t~-f;w|23AG;$= z9ot6Cm)>@nJX;c|)$NX$hmT4J+H*)wan+Jhl@M03uQSc~bKUsBS}-cf zl@temE33Z)L_~2+=H6_i*GB!@YA+zovj;@tQ%r?K8Jf%Tv5Q5)4*CS}YsGHMn9Vv_ zC~IB1)3-JJ%@GgH-M{sFpXg1m>P$nj&|H;|Eh7J;+Eb$cOQ4Xzl54rOVMj&6-@bUe zCbMo;nSeboJu4lYnEkE&efcv@p(rPKA}c<1FFN)p{*Brb!N79?os~2EePhMLXVm8T z{vh z1j(VIaanG5_uCo&(*K6i+8hxS3k5pcGxmRBxv)khpi~KKb8`NS;R%Kr`F|6Gq=A+> z{un@=+qe3K!}EXhf~Q)_k6p#DYp~(vlPTmMEFazlZ<$qYdkU@oGWVaTgmU!#j!KhF z;GgQ-5nhU=fGFGhI_lMmdd;~US?3n`99d`l=e9`$*|GLz0|_)mv0)$`Srs;919Lg0 zu_NxXVKz^Sd!u0;S+9MMZBAj2ZT1APBRqY{UP2(F3l$+z5koj9M|+d;wu zJO|{{MsF86_g&B6`nBDz|Hge+3yF`hn+X%?kUrd;S+(MyiHS2}_Y@bWkTzPUkl}2C zuZ=zm{8X~VJRDflw#Z?f!u)GO$L2S{ zaU+LU;(!QKo+? zjDRY2;pG3T{GW>O>3oxNHER}YqG>Uww|P(>_x}LHx>X7kVxOEaVy{W{w~K)_SR}4% z>AkpH`-)x|z5ss$^BI~oh<>VRFBx0v*^gba$p%}|6xj-(@BB%2GLr_0O@ds9v7{-3rOLR-8a6|2Gjf z7Y;f*5dRY9H7}oW@{b9h{$8gSABBH1Idm3s{!z|6NJnkEvU3D{n>uG@{uMdd1c4f` zU-*KPk(Lj$IBp|1xhemco=quY?W={H(`|8H_vDC=oI zT$>Qyugm)<+@>04uyfKNIW6w{FHt0-w&Y$ULV`;=H_Ph3(jON0-t2sHl-F9L?tgBw z4?MF)1b=GEymGGNRt`Mur@WYVrQ24~qCV)T`s+kkmvLcG=&>i2?p2w==}CmpYJ!S>O-VK(bGYMU^k-sv}N6B{VyVcM2xU_V1;{osZ{qe`vk5?z^@HFyStL|xE1vi)6SaK#M>WFckVFyeMBAsMZ8n9Wc0cnzLO+PevnqRifzg+qLG@n*zFab%# z@IRhh=g)_6@u;qebMOd}Cj3hcX9o?*x%|7S7HRDNjyy@U+3yh33bViNZ?G{Z{TWJe zJ&loF7!K;IY{q|Cp!b+d#@})Ik|vAvF9guTfFLcwU|8dN|AiUAE+AMBrUn`xURd4O zBA*?80C-F+uVoBWK21Ql26!5(xX!=)cl%uV8kCXHAa(vr)cFoMq8q1%C;xKj|BCXb z{uI@niVC6ihp3W3gE9q?f&j}iljW7_T+8wCa_qB{g}VAjzpWcMylEnmc`G7MjCdFnEk&++4sx!y zFu9>ABtj_b7~>x5RY4eEQ|a3JwZ5FSM4na_JA7yi*l60JuJ*U60&z%E+4HQ9-dC;P zVj7Y{H=HumLB)k6ct$xr38+O(XLt#Z8WZb;26=jxowYJ3&dMwX&DPH)9V~IO)f7Fd zAMYAWA}sS{45DqUsWmxjN*I@|pTfoKP?fR7FuxE|@nq#Hi3J{No4D#A+{Xm%snz{N zS?45L*+0rT&~T9BZZR=)kP|YHyLxDrFzA%b|9BxAFseP`c8(gL1zmy{-&O`Hca9pl zD7Z}|4Y#bm6LsI|3(jHrmRnHo5pxu7y^Bs}#)v!z>?JNifPK+u@$7d0MD`TBtTBv?7F({N2SR z;`C)s2dC5+Dv+Ce;5LR!T>pfCQMfBbg+=Q21S(tz?x~Q6T9|HwEWyhcst3OT+C~{< z{iI}MUI|5s#T(5@<@2ZX7EqRDoNgrVDs>@DMS1o20j4myHVI^54AKwM*lwmQ&e1=BL9f|_uSe2nvk zI>w*go*w0}O$%iPQMa(Sm{>W;X*x`|9pyY9&pfGhMdT}frcMY8X2^iiUBD7+|X|@=R=CtfUJ+B=kp6gQV0s{%iclB4*;z89R{9NzdINdUf z#FecR$1$* z>pQG_?wpk-m#v+j5iUCR1d=N_5zR>vvX$W)f|V;)MRxpkAkZ;;8eOXocI9`^F-{9kj=;bmde=$0Y&N{nQE_ zhAjh^wmD9c6XAlW^9%U!8Uo$3B0+6TqAo20ISrQ2(bGoqo{xkz@|zd;3h6|GZLbWc zlT%PWw%3k^>ja04Ff0!j)S^IWV<3um;Pa1D_eJ{qTfl)VwW8 zq0#zCgZ()4bRbU?cjWRqT(53iZ%Al>`ZGu>k*(ip&SjNevCY0%-k#c(yx|XAGV;y< ziR?&jj82|i-`fIN&I+7t^xMk~x^+}eZ;ZLoZ=azxqPpZk6h@EMy#l2(94G~glpNo= z?6bRFIo&$wCrnsC8Q1U_ku880g?zjM^y>{DqQ67}_vZw~taG~QZN+OMh$ zr%2Oe60Gbvx;-KFj&zMq(eAylsC~N)@Q|6EKD*1v$>dPO(YQp5?apPmu~%Bg+3OG6 zW2b_-4&kv7FnQNPoTuP3*%;S;`?=My2s!2EcVG?LcK|ju&3~iIWV7uk8L$|pA%N;_ z@)&g52zGf?i2gANJWb=q&0pNR;j0x`RF+!W`KBzO<9>=aK3Wj@RZBtcXgH4DOdHnU zigZDa!zDaHr0|O?(w!6DfPWH&Wzs_O6THS4ZTVv^xmApZFNlUQqIFD=`6x*KW6C?R z*kw3olNf&HJsIIjR3)s4hbQe02>1pYs&lLXuvYWYNzTO}OPBrPWNxRI6N{KiN-7~w ztD?!uw$AM=_RF$#NIbMgXUaXXm@J<9NqAL$4c9ZV7}#pRDQY3~;IEyF2bYBXpW!

&%BhtwKyAJ$oJZ6rMy zO?lW4uz}o(3Fn)tKCci z>j%Fu?9Y!1!GI1i+uynq$tTN+wJzSSEp}zI^pZ&Gh6HODqbWXfE+@+gY__Er9?BE| zG=e<;(LOo!%wxtKDc;EiSxWDOy$RfzaoAabsmep))pJynaF!GHj4`0B-AzWZ-)Tro ziQJq5sBmT968CvY?MIybIlM%#cflUP69LWD9~NtP;QO(Z?dj&9=P3kr#-3W2o8G|6 zB{a2xHoJnUX}&1+(qt#*?qF{1P_D^x_K*O+k~mm*zh6;*Qt+lpY#M2GHd@)X;MH^U zrU03gCH0KfDZ>` zb{ySR3^H})gKMXXBp7Vq)OjaaUNrCf8THEp8k3TS*Qg|+&@aAWADMXB+Vyk0KwWEn zG}qL%)l4Y&ht&GD3$mV?7M!5<=;O1U5*bXFME%YWT&f$$C>L+eV2;O( z#;c2`wt-+YQ*|}n@2T;;cXd@|Fh(|ETG@4UI#1p$iL&XPM{nvxar)3~ zT~AWMNeLUGF8dpCw|YHn0uts&{j5(-Z(e1wL>Cgr|64dL6?lvdzPOF4nnbMmv&1F~=QtQGm$2hi{DcAS&}?_$vb0OY*C{2vd-eZFz=|9-cF zOGop^3lZy@685`I@EwQBO?C0=r0`iAhVG%oa~V$dqRfiTJ%ogG0ti??YVzOizKDjH z*^r{&t^gJ%lTX4OflM6sW+59D_}KJX2PU(t*2$r2h}Vfy&;*5Tz;xB)S+821`5xCN$k!wEc%T} z%{D0ac6HVy@o?FV-qqb5v(r_7pb@c7t(;iMYJDrKVDz4ox~NBoU%!ML5s^_i7SWR5 zUT=k42r@P9JQj5%yft8N541dFvAkNS&5FiBs)}H3i5Wsqvt7%iLW{<)4Sd)c)uATs zm6#zEr}NFN;cG_HLcU3T1%yi+dZ_Am0j~j-b%lOen5mrRCC9?pYfRZrO(O4IIcYXr z*oqiXLYU)k#$xJ)V(g63NHCs?MrxQH$6&TUzsQW7rl|O#hQ41|cfNBhP5Y$<=RO3d zlOnT;O>*_dBT$R8r`n{@Wh`RX(m5x6S8uXfrIy(l?bY1R5N+gyQWrC{ZwtnHw%cN> zg!g5@N2WpP>0dpIFKtqz!^ks~y4Lw|SLs_ZvBo~TeP@ea^jgtFT zOo@PMVO|bwazppR8$CbvReWmARd6@9vq;E{Du9jze#T>uR(Bc0=A;%#2F9qrIJ>(? zs7k#nr3I^Yh4lVliw! zi?ZcsO3Y$21$`^2Boq%NwkFa>v&_|qFl0>O}+2^3cB2_Tg7P!Jp0 zkfv0Zu1UABC4LFG=FHjQTTY}5skN^85tmwaNBjpi=s2Puc*qSs9eqV?x^M)Nimr5ETQ|HJpC4P8((JY;BrLr9$78|`JE$BUj z5uLhU|9N{X@=PA1HKJf|BMGbM6bN(2J(s|=2$zCclc^=9S3nSI;Y-fr5H)3J&WW3{u_T4)K(j1V%1k-TVW*#we~3-H45vPMz` z(iQAo)hNbmCk5yNqXYK^eG?+b{`2qg>oeU5%@YYX%q;E`(G-9fR>i%@MWiTmwVn6V zJ19?0xD@E^Ub6N9UtvV1A&*d9J0e&y!SQ2JSy9wk|U6 zN#ibgnk8UgpTiR53<710E2J@Du)bUTl;r4vS72YeB`*DF!`QZ5W|Ww)C?t);WWna) zgcjlEn|#tjV|iR|_gthkidRFq0c(Qcw7$=1p~+Va9Kh|a=-ZI7u* zY6NefvU)#i5zd()5Uq0{L0_wP)d@=v0P~X%+HTc02=9~dk*Uve5HFy*dY^P@s{uO@ zZFnF7NEc}BlTh%J&=1=3laS7G(hk@{Wi>(|%-B7FKpSY~a~N#37V8#cp%UMaBYGA#9;foHc8#=yc07)J zOjlDHA8+(SiBYxTis-deT*`Ptn7Mcoj8tAJ)#OwWQo@x-R}!QfLQ!_-EwaCdidZjj zNVCY~UOnDwM&QDed1g{_%4P?YK!&)F-ZcT}E40(vm`O-BGD72Qfi?xc_SlhWE>jwQ z-%Spc8RsNN#M~v%K1vD6{6-&>5J@Hag@*A>k@`?jQ7(m?;kvK>^YPrSf~AH&Q5}Hi#V0ejfgguQe{%>DF^LkIRN^><8k?)wbd5C4dqeEM*=1t z?O({!?3<$*<5fU9SfC!ch-Jx}s(zvBFUiMwkJ1ErC5^F2$X{P1@ zx!!fd|8As0-;hMFb9J>J?P+GFyNez=(}us#nEPF9dv*wDCLRHOsPTv}6Lc^=+2cq5 zgB8tYO{|AJ?&h2%ch`=LHO*#8tOo<`=GgBp%itXJp8Nw32N)|T;KVpEFy;H2&yS+m zACS0PJ(9d#J2aGFK^)*sz<|_$4bJ%d&?5Pw%-a>8{NqQzwkn*>iWu)6Khjo8Fj(>{ z!z{Fanj_+OU-ltcQDA>T6u(mtW4JzsA-E}CVjR^Uj769Qd~kEP0t!IM9tK|)v#h#6 z_zZlZvY`#Gqrcktwq#=hZ$s1fu|y4vpuoYL2iU;*u@1rQ{$}Q7Yr-7igFC<#Nc)TV z*OrwiC|{8;R5i?R<~rZjY;53d82UbrznEdq16*hYIhWwBKAF{dIh!zdy5X*L1o}Ri zExufBMSQ`c^3liWnbu=Pf&2eOY!w75(B}&c4{LB;{k3n`QGgQ-|C>dS3vO&A74Emn z{}t`B4hI_$1d56OZD>y)GHCGRe+|)M>D%S&+eQC9?2ZB#xd?sba<&?F0R|2q`Jfnd z7~W^w8gz5BuuW_f)+kTKJA4;$dZXVwsQg-X{~{idR4k9ae<3|pl!i@&w{HgInVH8w zNr9*+w9cxAD04=ZIbR8uZlv9=uAKCk$juUarq^8p$X zm`_J^dbHF3pwPnq-M(E5j8)Y!p;|O={#lRIwI)~Oor%GZekM7+xC;!0Tlq>`gL#%0 z*H7$49(VPFAr|MY21^7X?$Fgg8s7Ar5*G8L%K(afGmZ=8gENC+wAPqgOrh?|!dfO$2lDQ^+pt*+|Fm1qf_~i#H zm%7M4hjj3>p^}ksZszQ1{`AqI%ti0;*!C?;C->WWmx(AAJl}Yg6@ z!?v+oLma~GOGd#@^axWd{B!-H0$bK+?ls9tAEy0p1q9c=$@52rHSTO|zY51Mdd=LJ z+0au%y*k|IqLN2V*Ctx|2(meN7uUN7%~km*)KnYsO&PvO zL1RaHQB*~~#D%X$IMd7U5!P2l*nUso=r8pQX2il^7nyaH=(JuINt$gEaU;1=>Rj0V zA|XJ+T#x?tY(`@#+?n7`LS3kxDm%Fd;8R&u z@wd12DVhlyeFA5$Md2SU22bx%XH9yt5Q^G07Z;UB>i2eU4gnS8rb0h3bc1rBS^DS!sg!Gj`WV5p3wXL!OE|l#SFWcELbzIIW+HEgzC_ID z7YLLr)lwH$xA`bsnGlu$(3z;2_2U$x<;(I=FORPz=x{>ydXe5|nWtq+lVFvN{#@>< zPfz$sj(!mHq62dHf;CxooB~@BTPZ^IR!Uz`8C$xt2wO2|r9iUC(shD>Z0HsoV&~{l zAe4&bmZQ%FK>6$5r}#=>CNi)WmD5w?_7VxFu1Z6M)jfoPd^zT;NdrcoEt?bYPCLzq zq`CL6z>H44arG%DHqm(QM{172d`s(w=*ZOtb>q4P!{*?YU8JS@Ds%2RNNx|U@w=PX zOq(A{miG$LI5t0aetjf%F-QO_M{SmhFOJfeXUU&KSbf=?9UM$B-eX0=~b3poUPad}A)D+Zgij9?%Z`lz!SU!6ki*gk5{` zdM-H$-H~y1FW~U@^>oFMNVZ8ky}Bi<{OtEEsXzSm8QkGgPG`7aP-gXiRZ*({iH#mJ;0*9 zDhqK29LCc$iF_UgJBJD*0L{f|E9r15+zkuntx^K={`gXLbvJQ{E`%395Iv0Eq5FW3 z_~Yf`7`g+Dxn1A7NQoSiFTHMgkQ9clCxECB?2Ejr{cP%^nLgGf|nlBiATSIO2h9;{F1z3Rb;$2uAgfc$+~ zOLCS4O2yHM$zItR{c)mgP6YO}e`AbdS`bC_iLo@`e=+{=4_$bL#Y3=A0s#Cz&^|F% zFmbfhv(h!Su%~hOZk=5ET-a z6qgi{P>}qtt|BQYCnKvSCm}DVprEL(sG_N%sGzE(s->c&sj4BNY^b25tDt6}sA;CI zuCJzPrlxDIplhRS;;Lz2uV&<;Y2u)1=BBSGp`-NOKutkUUENee-b_>7R#VbOOIBA? z&rDatQAgUrP|ZM3U*FKo(A3i0P~XDX#L~pT+}vE>%u(OQ$-vgb(#FBu&fVI@!_nN( z*2>P!&fLYtRnzK+rj4(z^$&eJUqh#0Bew`MM?W*CAWK(23%4)}uV^O^Ut6zes~>Uh zK0(d_iEiQ9p3(U~t+aw2w0~IZ1v#7gdpJgWSw?%={P6w}{L?Mb$12X(KE~fIKG-A4 z&o(W{DJ|43JKQZl+SAw9*T+9NFeuPJI4mTJuyr_)Y z%&d&?tlE^^lEk9M^s3IH1pnN$gzEI*imb?@oRs?P@aCd~!h*uw(%S6umeTT?{HprA z>ejNFy3*R#vZl_uvb?H_s)nk9y6Upl>io9al7_~{i(j}f#UY*+P1#-u8#7q z@$&B3=AMzJp@sJ8^|pzvj_LjG^5p*N^nu30zSi2Fj+Wt$>Z#VknfBtzuF8>~rupvj z#leQnsrK!OmYwPL!J)zavAN-ymHF}hsmZC8nc>ByrGdr6xwYN(t+lbO^W~jiD~H#c zmyi2P!+UFUmzyJ}Ta(8-%a>at*N02HySqCFzxI#z_kNuoAMBj|+B-QpIXJt%xH>(# zez-Z?zq#DMy*_=s+Izk|d4D>;xw*N%f4YCXxqW_py1RaTx_y6t|2-W(KK3%>Kc@ug zwU{8Eg3HR8C$xsVaY`kJ`@^oZaY1SA`i9fV8I=mJ3FSalm{ZVAcUDczK1CWwFH~+g z$dt}r?>q1AeEe5$9zUeY@&i4+M_Rr?SQR|+ZsO3SEfEY3Ji@@OZi69UP&_H9+bz7w z3+K&P;418g3T&n=%}B1Ov{-?Uwzi9#|A)PI4$|c5)P{=R7AZM^;WK2nOSR9W#-DKp3bkYH_qt}$m|h=S>T~X zai5zk?Um9JIPZs#1M;usXRz>ezD-sHIc%-ZESNIcx%NU*XTt(gtr2o{zU|ECY|^=R zg-UtA*y*v@k+wE#>F#TsskjC*Tv)-Gl?5*;G>s?G-eZdQLc*25rm_ywR&!p0`!9fc zm+#u^DLk`Nmp_h3u~YFIh)*y)&k(MRZdh8ija2vPW+-p0vp&>GIr~5*D zwy~qcbM*KMcIw8}$>ce2=+p*?QC}srHxruF7Ha}s6Uu@?ZIZqSrJB9h_$WN_@Wm0+%~$;n0HTssFZ%_an8G z#I@l{#8`WSofzkb?37mO_5h!Z+-uc5RTj{KR#(Z0veq$ZMEsAL5O~-k^mFkhyqd=K z+2zHag?3zC)cTne6&mDB9>TiiOd0b>8QMbUoN$3PL0Y2dr1K*GON3 zwhIuKS@0Ih7qq!LG6scB4=7|F9ZpRYFpgj0REin;p%~76FKKU(@FaUU-0_ z+TK4Dh*gApqaEaSDZs!y3|6{jBu*iGyvJMn+U0--Qvjf*2z*L8f9A_`hA zZigjz)YoeIW)CglTXtDMG;61*xErOsmb9n5BBcX+-*-pVPs~Q;OJzrCj&bH$v+in! z$&f|A%89i4jHpBP7i;!%X|-D#{y~0Q>J_uLx&cR{y>!3@XxVlgr800Ogj!=OjsD0X zSwIn1reYLM2QDRBKYjjj>Orm*?Z9*&YP#?;)X4Mw9g3aCz%h2XD8xL4b9w>t z+Y3F|2b-5lT($~a&xL*%;=0p_ziS|gNWBC=gJ#M)j++t|!{2vNfttmZ_RJ1%5*f8P zg=h`}Q}K*Tr5Aj`9g|%15R~HP_sYZXm}q%Oe(38oR3& zy>RmCr7YsMsFXkzU*YD%a37Hl57MD8NAWRxWd{R9(@0&Ena62Eab9_*e1A2%Asmuu@88mWbbY)iM_Lg7124Nl= zvoya}V`m&E(%L&X`kOL(PGS0b8`2GEra6J3hk0ZDevRPKC|sH7Ix&LG;AOM4sF9S<(q@Tc{NkB3lR;Z@!Xbf|?orMx~R zJffxCM)CaX=E50 zYGl~#fCx;H)}A;$e9@L8Sv&+9sO9fj`Gb55RgKqG?0?Dz#7A@Iu~eA?Z^N%?tbBCl z`)9DXRkmEt@#oiKYz&mgxY>f64*jkOo=Da6%BWugYJioLr|_AliNY8=bY>Z1-9q+X zRZ{9{nl8+JeRpLxH`yhxTX``jB7UkGcOUyYyzLfqY*`qlgt$cg;;JFf5F~X-FgU5u zVi>7qK?HFX!n!OQ0?LxXZu}zf#+F}M@}(|ed?w`O2Dbn5Z9hOf zsHwJ}9l~B;7GJRG_HR;6vuaYj&E8+R?gju$TiqdoR4R~iJcW0Ya}?=-83}y^Tg65n zD#G07-LS7~0f$n%TeLB=`HuR&>`eTIqC(Kdl0lHLQx-wWC)jfV-)y2K0o8O1R2rcW zSA(cmoSH5}`AnVUjKkXlr0ax5D>O}oWYbmT)X1qMlfu>mG_+)@7JDlkV3lqmTg#UF zb+2jArjZFCm>VNSknXin$oE*i>41C`#- z4`$RYviWCy38qSupmdOgRCEMme5&Lml5DLgOqqOB#Ps8kwEFR7_+!iO`-q=H*J-ni z6SUbT+llPmKh2JJWK>oF(CGkvVw;EBE8GD7Z2z2OjwZO>nS{O<(X`aS3{trMrcVw^K~nr;PuvqI*nEECO1h{xteLr2ta25JK`|)E@{5lMWc%L6_?YW12}-oAv1k;& zMj6i}V8uSaOoJz9_C=K;4h3xw)1*Ad@1gJ@$@?wP=NBcITiWhK)te%f0_s_1y&W_tQT4Dp`N@uLv( zPgZ$k4Erxa8j$wLG7B>fZ?pwP57$vZ>E4JCB!4+cI3+i##GKV;7BB531D5BSDoK@J z6Z*j4rX_E!R*a?x!FNNXmxk!nS%KHdD3Oq5R}_NnQOc8IvD#~ekv8lxc9%vDv)*Fi zQkkrP(KpJx;bvji^)d5DqRo%LT7eI}wP}IG`R56~Q_F;(dziO9(Rvt6uT8%|2uc zf?)%y(5;Fni<@C(nw}%(b#W7g(6>)c(#cz<4!iB2{>+n5G6Kh27dt?g(wuQ&66gcHfrk_}FedeeCG%h#r&izyv@xTj-F>PM*WsT=_4eYK3KN)ik`^j#>(9k3 z-@^oCrLGNRKL)2!!Yy^S^qHgu)Xj&2;!b&~TiHl1&(7iW1-H>rKgqqM28*GJO^)_0 zY@HGj=H-`o^7e{+q7uC7n-uc0{CcXlwEXU|ifN}?P#5gK^n0DTDNw_Ab|36G0|P+R zi}ls!pw4HFrg?_(9N)skz3 z>^b{5G}(mIBd*nURnw%%+x}jQG;`H+o8MB9mBw3mqo70^?|-#6(bFq|K;&AV;Ss^Z zkCwgq1ZU52NjZ;!nxgqTeaod?T5od=k1FzaQJbfPJ?919JZ5nZR@_sk&Ek8QafDCx z_tpc19VePKwSfOAc8bNvz9lMR3^ObRq_hnpK1$-rVM8c&u;y;@y7dyBa-aA%Dk=+& z#VqTpNt`OCqo!8A4-j8>MCD&!XP}={B!|M=bv|XoMxpB=LH(!8wTCCWh8!Ecwi97X zFO*N)cqGezJ=|d6h8ukEd&$3nM#yX&O5Y;k8jJlq`*v$r^$^Z9>cY#C4bbDq^9dun z@oqi?#7Zc-;FQh|gTCVI!p~D9rS-zbsgY{2A}8)l3TZ;-C8AG?z2hP*x~&!s^Snm- zPfYtvPe2UO;3_KdWm=ahR_)EG)}2ig+2mJVP6m&;bUb!7X}><|3O1Bmn=r|5LSA{RBe>ChY>H=gR=$cx0~ z`Dm%qT3%LlVjg=BnnTI`4iAgPAVS0-ItNR4&VMCdhlEHtgZ2XO1gNfBan?I5tRHx| zEX8xj)0E{8Y@1n79&wdr$;WBpEdBmmxv#J(+P)cX9dwAL>!;CmqSCY>@i8e5>U=Fa zCceiLP=3EGZjJ@CiGNRvFwkmyO$o%Id=;RqWPh)>%Gt}0Njq3mUUcUcBaaOlSPaL} z9wc6<0o(j(Q`n8*tSyLR zYzX^cx#)$dCpqp>e-+_kmkV0JBibbvtf7W%Tv`brE z?_TMgvTO-nkmg%Q{YIKPiF98f8Zy2a#OgQ1_z|GS;UH|6p)G~qcN8N)>N4R01{TrD85I_mA{0d^YH-S&!kzuA zrtT;P_1_+hm4Ebdq!_y#nEBK+=CaI;H2N>cA&_vc66vfo(2M*57SsBd{>FKPkNiTV za@z+jmUw&~mP>$IVC`Z5Fo(>{9dmi_nn(Hy z2Zmi#EkO{=b7iAQ+!MNZn#0#x-z6|OMU&EhO21l(P9sCOiQ%?*cF0#K}nO)-XHk`fYKB!|mMt*mCWeWsuw`hu!* z2}CFxySUYm;p{1U9Bs0Fn9M>b${Yr7lEr0*{Qb*0bt&YPY7D(j-}&MJ*4pI=m~ccO z7M=mAvoHQXBO4&2YNtc*fS7Fn zh!$+pFfOLADZ`34c4i3VJ3CH6w6X4Pz}UE;MSlFIee1#a6yW>ev2LCxnpPy1sJmo( zVllZZC1F`NE=2_CM8G4FMK*@dAE;he7DiBtFbb?~Z1`Jv2m5fy%*cI)DJljytYdW6 zLxKAYas>)ia-U#l;OmFBXUi~OWG}09eg^1Igk$^T155~MAZbub(Fc|}CJ2<+E^qFx z34+L!X&jA{BAs{`#0LTP?eogjSe-SglvpPJkf)KDw4O&Uq>vVM!`sDsFxlnBy9>ER zr5SwrHz)2cQDFACKx18Zsm-RL;!D93{vDHC>^EbHmbs_oziQ`@7ILGJpqtoIw z0Ywe5t=+IiWU!`^<bGTQc_{p<;jE7m5JJ&U$N=xp0M_e#%if z@(2{yJu@XR&5CiKbG<5Y*}xFAv?cU)H=JPatLyN^6m;PBXkQPBDM-r%Tb*2=`Pbrz7@F;7TUMZDub%K6pq}cvFP+t2!4q_Ar#Yi`(jO6pq)~BRD6l`|-~>)5$Bz4~-8@+S_l8=jX$v zThJ-#AbS^BpJ>F#qNc>R;}K1>9xlJA({dN>Toj?HY8>(Cc#IWZjM7U`{xSA`812kY z*2#{%sDiRjGZF}1u>D=i{M}t#139Co(1WXKE+j|&qwTX*&2G|SnfZId=HY&~C~V{} zKGn_>L*3NGF@+sv0wfV5h(TkmY1Z^> zK|>gEGkG3ak7F(`;(pYE5`QvXi5&SfYG#_sLO2ywrFY+7-U(ojnS+5oIwtGFl%(q$ zvwhOo;n}ec=O@N!km!!y%XYHJdaQ>B7@dxaRcY z5ddc4h++D~llyNce-;W(?%5rfJ!_)WVf2c*`uZ72Yx|10N<8!V!}8IY3dMJKu^3du zq(}6TNI~W~aemL9pT;~Jg2rL2&A!K}nLEdMUjC`MnrW+?cZ*tS4U>b2a+=0Wy5u*7 zF9QDR_m?1|zb4Q-MD{h*>{n4xcb9^;I@a^)V}KLApml0uvu~21PZ}OxkVux|#*_e` zQEhJu+vPZSfTGvRg_)VEFIci0p zc8PQPtJc#3d223zVu=@|dr_;n&{9Q5uF&2o>a@V`#G0aLQ-ozu{mrkNw#Y`;yt^Rf zqXce!W)C$EK@T)`oiePbABUVZfl&nVtkAT7p>wgHqNQzzwRQ@ecp!YBg@1R$BiN-; z%vXCDpcPg*XX1~532eD-hz=5jf&gCo;Uu2L{5HOfl*A?@hT;V6rI>psX)TIVt)!9( zXV`W8!pv0lt%#RX2~Z7M0%E8aqc2poUPOCh9WJWWulIC+lMhlCie{pGu;NRFiIr z=i>KZGbm^p_mzKZ*Q;gAiHl|j14=;s50UH#dLoip!5QUw+;G3OoHlMjI0#1wLP+CH z+;A4jmSajdb6U#D(zBwgAV3cT(CO^kXl2dH*+#!sHEO`I$5%GWB)o))<8b|wnmVm`=EbqXFy^gUu z#5nkLyPmG`EQ8}DV8lToW|)=A!P(A3dI%y6G^1zbIM z=-y#V8?bpO+jcBYWgJol@RAXk=^KcaqfO8XP-cj9iUN-ImbO`Lz#R}~TCHHmkR^fn z+K<6#)zk-C`)BUQu=Hr}1-pD&MM5P+_VqgCaW{24*G1=p4|ok6xRj<*F^XQ(9M#2 z*A{d%qn4%P9xZ^c{G%gy30A9texrkCWTL`RUn83>r3C|VbRBsa{ApJ-Yw@Mqi%vDC zhKFeK77N}uQ-{d)i3I!ax%u3giu?1Y7wfR>7nb&Zm^~E7iF)V@(WV8|@P{e{P9pV7 z*yyY?zPa{d(42&UoZ-L?FSe>Aj8;y~a#6{d^y{hAqdl^g%Ulnf$dQ?;CDsoB5Rnm$ zO>ncDlwGDZImw#f=brbph43N_4Wj%)w@76@>w@DUo_j-Wn`cqlKu=I=&FgkXhH1dt z9_J!!uh})kW`Y9HLSf9k?Xj)r8m}ukFpDU(T^bPXNS8;SvKo(XHr_{2#)sY8zT?B; zbVHv=KO>Vz8h6RbdOy$?2adzztt8bU&xfgxQ7^$WgsG$f1i6^Vxdi8%z0-lI{j9Oi z#ad-on4mFR2USmN2k*d4kEQuSr#1yHW|>&$1fo4R7gfwnw;a|B-=A#x?mW83`(gWN zqDsz3ViE-hhAinN${o9y$Lrc{S}Te1f_pQeCZkGp>A3SS*%(NO&PPSYl2-UqCTzNj zyC~K~Du$+EQa@sfNISt0b_clM zt#Ryp+uX`l))>oFq~;kTg!qFdyhKBhHZh{!NDoyTMZJ|K^e9_QQzFI2LlOaY}>TJu4?kL>rVyxW1>53#tct$Mm zg|+cEPQI#ZOxfz@F@jT-*@mIH6Vd()-(C*Uvf-xa)eSb-``58sjYiA?O>ne0X~)%Z ztNPBqR1F9+QpWM(eNP281v!G z6U?Rg7b`)^0uh!^M0oM}hs5a?2V(Tk_d3}Yr-NaFaDYygmPQK16XrOK!^4Yt1Y1wB zQ}>wT?~QC%24~xA7-B(rZ4FF4obM2lC+lD-47l#9#)=COP}Y_1Uz@!XFV=AfI=vJ@(Tts$oKuvWm3%}j4FK3?3o zBgY#1g;#La?pCOxS4dh_(+u2TU`ri8d~i>ccI{Z6g^PQGjDrmFi1|LlZTgT;MoOnk z9H|5WPyT*EGk}AM?i?ef7TBxDs{uVP(;PwfI0?4pj4TaoIuAJSp0%5isf%df`gNb6;V^o4cmK22h?!se6Tnzmy1+?V!pY#ScSuk4lU4FzZdTx} z=BI*pn~&`Mr3ribsIPW2MG1elX`{lX^N!%OKtrHjp+Z_KNX}0NtynM{swn41K|0!d zirL0=^rh(Q&r7AO%C=JBcV9|7fbG0*+@dq+{%(f|6mMb*Aez8{)MUL*{Ql zP(`S-M)$-8q_v@j2@u&+@ntQ>G}-}SQ(S&iPqKe*dZyRdwZCJ5I)746;n{U^wvZL? zyN5$)av`Ruek?ekDLJ@}ICA3rIH~a8t)Zi3{7w8}r(q>1nzyAM<5jBqC9V6w!+#%b zUPo%qh`9fTrV3<( zm17yjq-1zd)0RDIsEP*DQ^5YYrO@;hzx48mPo0pg(`hYyq;dARXJ`AcPr5Rh#79_N zU+bOe7j*U0stpZ>q5=hzFN>!CqhoOtfD0GA%`kPj?HZq<)Bgnoy7z*xv5$hH`LQjz zl3Ri2WdR* z+&OM~qux3-nU2m=faj;()K7D-?!h{T7XOxOVd?3!P zt~OOVN9(%?KS^OZ8W^-%ZsUKo=?uFoq4tBC2yd)Uu?nZoD8R!FcMv?1CV0iOjkVVy z>o<;YmM0?{et$}5*mAX>K8Al^o`SOzQJ={5LcfToAp9z(kyP*RoDvwxe6DV($lnRE zPJ>aY%k9_0@@%RPy#!PQrY#stWEksfWe_v?r&WtR(!A$66A|Akt~u2*9iVmj9CJ8$ z*ysExT>xyOlTt1>jz%VW=`@K{BeD3Z)k~3zIQyTi7IkxYo6c}iWwD{DjU4rU2o2#gj=0-r8@KWR1IR3&SXxrjYxC(D?>(~m33p>ky#RmF}|m+zOs`N3?fODR5U_hX2EwP5w}uulWtwzyhnNm56zzN7(A(Vd}ku8RaHmAN)!#r}NI}@u{ncVo0XI>&-=M5^InRdhjSAGk#CJNh< zz8#m^g_Ko%QB~|7%S5kDj>jouvQUKK{V4fD8%MeCpRx%A_}a)RvKSw<*&7}|GvHsDp?=id=XoIk{{aL2j(L^$Lk==DItEguz76gmvC zMKdw5>zuUE0AaicQ`aw((6BZ5bsZsw8nU+5gOZ*xD-Po?Okk&3Mfi0PR2vO&my;Fk zExp}eD*ssfxgXs)b>gI+_Kt|-5Hp-@zw>tenoyO_Bu<4{elw6eC8Am4)D2@HY6z0` z9pqQ&$S^3|yM5P}ij3IRV{7hx^vjMIxVM%G=>nW^m9HqOJsl;@Uh1PY9JOA2Tz~{4 zlZ%(i$*ps!`12x*gp<`~bjsCIY;5|<0(i_?4ZpgxdoII%7F;XXBx(wSIdR`~!;>}s zYPy+~v}zwU{4KVdE^2;dNn&Y2*ex*5O{<7rEtwhY?q(fV48^4k$FBceA6;{v!20~m z#v!Amr9$f55wITK3UIwP;I$QLW~MfN_;Asy`%Yfl^!lfz15a-s4PRJH>F?7FpibX&}H| zbro&^h z^npd^RKZhS_YkExhA6z>e6GQKmd5d3R#^U6jwRE!9$W^zV3=T|$6&}`Hcf)UnEgvS z^zGB{5qZdL1aBA-PVKU?n3J@W4H(`i#k0<}rkNSR{cm0s+C~g^xt4_nR%tA^t4z_Y zi2C`j^T5;_81<}7NeK3J)#sjQ-g}6g*VGSkD{g)-%7fCDHy8fQvdl)BT}p_+&9D^| z#y5}oMuA3aQi(?CkUy!KC<4@oI6;)0YJ+xy$uwjIF3`c#urLhq{4wf1dLq^Uk6niw zPo!tx&nvu&a~N&+9iJ#}y4CY2*fj)mZ}NlZ-;(slvp5`Etx}9NOP63E9)7PkF<&se z&nS>$6N6^o>mYxK2}ui9^XvNm? z4fJBP2XMrLau$l+(>^a>_2j?o94+cxz8DLD)c*@#`DI*X19A)GK0(x+VJc*6Sj;oXY!t1T4MrcRZ0)qKoWw!es@ zkG_=F7Lp)6)v+`02&tA%u9eCMeaV5A0SW=qa=e^}LOdd2Y4Gi2y|yi)HEB7+9D(|FN3q! zG8TuiCEpc|{}q^$pz2Pa(Djdo+y&N{j6`tTY>?lfoMtRkSUME^*?iYn4Vu7!>+_|r z&(C$90IIMXsMPMCk*4^_($eYhYmg>HS*-qrnx*n|8IMqim4_*vR!S37AsyOOyae#U zQMtWSqkc0Xy#g|c=RV~J1Axz3Tl!q_P_4mhO%jm$hQAV!=*5LUVC}_k@X0G?g0B#M z1Cgs#bK8rC<+?*P{IpVA?R#_^-mW#$ZmYy1KgmQ;K8TPn9JXQ=sRMoTquo83>#tUZ zfX7+0DiH_>$#{)!VuTlElb71Me&fOH3U;&$yw6dnPY3p?C1?N9seoyZ@k=(j?(lT$ z;Fa?*W0fOelBotRpr<1MeMXBr+$_Eh6G&T>pd2^3%der`1^rQTGear|5wdv;H)mxh zwZ0&G?o&Be5V%BRhZSt|cOGe+%UX{vMIVk{Kp+VrfrVVF;8c$!HOA_oq~2`009lHn zk-Cz83cMFsgp2I)En2Bdq=4Ut8Q0u42uN36By#PcAe4CV>zklL#yWB9?hgITy4b5u z?r~cg`5|R7`~i7prp5wOYMem#J9JR=R-vq0pSlcZk491X+^xfF0S4Aj~jEg=*% zq`{6h#snc5Zz8TL9zw~fY9)hz4rI8kdM_lp6>`7WplIl|-)O?&nmCJfGIh>`z3n4O z{oY~z4qg)3fXLu=dTnNoXV?v-z{}<^V<{9xD6A>4AF-&eCauo2yZ$i(lzIR^Hoz@m zCy^D{gVi55=n>hfG`76C>5?{%2;#ZzfFn-^l-cH)w+Q*irO*}6)hW)54@u1w59*MG zg!AiGv{D#p6cRoIQz>xj#{muprKpvejKJn|yMPbEU{e#-Y@ecz=a`4OyO`KY)>#(@ z($C4ihTK-;ktN8cdt!g!2_11_v;0VWK0>isI;u|u!VR(mTMXVNjn6xxlx`aBDVlS7 zs?_a;2R6FjbW&kj`~yG8J}Nm>q$cSl_^u)0*+kVT$0c$Sw$N;B$IjjM>U1*7>n6(Htn0#{ibN7yFR zm-9Ymdw|U8pFT1$WSAMn&~(sht2`XWHfGHiX?)wQT%sn577~oZzAMaI8`=iG1OZOC zqx)kEC)nQ<&xeSE7U?Fq#}#mUWkXPtYlgs!@?;uOWVQojGr8EDIF2PPVjw{dI?J7b zf*9mAEMU`VS{uW$^f+d;n@IyQ1qRBd{QHU!mGh>i&`7!VJ`Y|;!8X*!SY6A+%&dcxAi_O9rZDw|+|z z!uC>Mnq=VaOizY8p@3CigO@whD^F9@PUGlo`}ES=`?P+wj6k@6IEyh8Lvy^{b0!4u zCc^hM`Tm;ZK%KA5zyt+d&VX`prk)>eYtuMALIx4brso;ksWsH*=NVc1>~~>Y#+7Zl ztt5w5e+b)*NjZ7}6W#4BVfb%pB)irjO7vCv4r;x z`(oPOCV=9KD*3Wx_l?<{j&&_yXcY)x9)r-lRuj0_*D4o{$0_tL)ZOxfAHmee`08fO zQ;uJ*ZCorUp)AdfuNs_*{gok4#Y7Ej*%J(MTgY%Pvw%;!)DT%+3Cn*uEZ)x$In*qu zGeNJ@|K)TDC7!mr&tl$M5SHGw**4O#8mv^hcw+oP2v-T7gbZ1K5;i~EnDnL$Fh9bS zCMJO;Nl@n2q>9LLIF=G7LD8ET&#DMIzW98n=1#W;VJ&lb6s;n>sU}DN?t%k9mjBjQNV z<1v`E;TSv9ve=DN6hz>L*JnT)E3r=I$0_dsVTT3~8xt*7&S~Os%m8<(!j2uSIkm96 zDrIQ!7RezTHNRg0F-AO~KmHbrI~N@URUHgbDcp!StS8=CWXNM92EmaI@jEL$4=ej) zY}@ZgjdF~xl3yj8kU`HNa#$>zxq+?BN%l?-1vdg#X$w^2qs=vN?5+u# zQxT>d38A>*99W!E8DubG6+@jg^fgxE~o$2VML^j zoU~L-d#C@Nj;^oZfzH)aVZpEdFdVulAHU}xYRN%(q2VMt?K6cJ3!TY%%ol@n&B1d~ zz$zqc(Oh;n!@7_*bbpW*6yPnj3Y{5YY9yj0%CBfVSq)LFsffKkkG*bpZ|$zVXl-rB z>N5utYlrUUzKr!4OLi8@(&}0w(#$(oxO+{qM#wiXS#5~1UzT`$S1s}PCBf5Yv1-D( zwx{2s6RJz(lS1OqkvmnhWpGMjQ%ZyJ*+V!5hvFY80+qk}D+k%T_YLW8 zx|w~hB*{Qqln#euhI{2D`Uh@!D1Vl=?xWm^JEXY{b2G@LJ=aBn9NucizCP;4ZPhrO z>#yQ3nd06owTrue0W^e{&w>P!0+84bvY#zjq=PAJ$rsN0Ix+1FN@DR9!UZp;IUa>(0VtjXDQ zl7pyNep*g9>J7&@Qt$j-;XXyzMD_L#@g7-#L50Y*xDWFY4pA^oR&u4 zr#AL922S?&|ATw|8@BqL?LT(?4UYYf?LV{qFNEy>`13yw=-nJe9-#f*d50VarzxwSjtDKq=F5xu8-d)!FjLC> zK%{oL@x$XhzgVcW)DPUQVfid=bz*e+teRIl6~)o0RVBCXc|)f%wS6<$H&Ze?{+A9F zVc~AKmUX)YjnNu?W>VlK@M_|BRKKXzGLNv*s%Yn@0EXARQZquP)!Brmg`bi&xNqQN zTz}Ls|xh!7>;^J{e=I>MuC^Q#;k-+hqAc)L(;wpTgv$2#{o z;Rq=$7+5ofFjfyj&YTF{_YJPaVe(+Q*29|$7FTZvClA#0YJqu?U0HjPFBNP0d;z0Y zf>K3 z?qVHpG2*L#yz+AZg)jcw*(bmK^MCK`|2;tz-Gvua=HkJkH?OXstgW%&j&KN2N_Z|T zNHSj$r9Vu#a$MaaIT9ZkH1z0^FwEyrxoS)Kz0QV4T~fQ(hn|wU#92s_c?6RA;;D(m znS3vnkVfJaC)+d!3j<+WTbo#G^z3$4$bppolt=Q>i)=IIg77n@;IU3Fa0W@SPQ4)^6K;z*Y5Mygy%4(n+}Nz5OoK{*2@bV4bo z&n3V%?9!xtWt11?S^T3LCvT#6EnbYOO|wDDZR>@PRXP=uf}LN-*^w%TDv7Xse%7J` z2HRgArtVaIIKOf$NjmfM-RyL|n3KL?j;T1e#JiU9FyP}RzgO$fZPtfu{_(OqE^|d1 zUHvQ<7_yQnoLPkj_Iwln|2)g-$v6d*th}?vJ6w3_XfN099b~^kk(bW$sZRL6FHEzS z{?7|n%gPVH#7k~1vGymN_h~&U{rjF0cxp$0+&k9&z<-i$%Zo0(&>wTQLb|8TUkyS| zQxTqdqB(Ba%I0U;kQHjOf4O%cQJZN%kFo0zeZ`YCE0VH zvoe$U>!(u0ju3mI7XKr|6VJV;YxVyU0yq8-rG?A?8=`K_D^;wrB4jE6ABn2Q#6 zKO{LR@MZuyCMCcHt*!|aHhW3Rtgbm@ZjS;PENXwcFPa<(^PGrM8`hZ-@<8|aht}44 zaiU@J_SU4i`4g=*AuKErg*l-+2FG-tUf_rXNZ;@k-w44E>$87S`E+J1E@1yZN??pp ze|g41PLy^Cg{-XLfjJCEMFF)Rf{aZA@uaQ*4N)^~W_zw%kzG*%jXshSfTaY?x+0<4 ziFs~XD@Ay@FKT)uJI%&cl+R#QL`<3SfGzytTq`Hz68+9}WP>BJ?@ymEoZVt45{!Uu z(++`whUCD8#Wk%A-CwVU6A}kAF4{jD6j*F#C_C0lKAB&)D9)tHe6~+(&xa=Vr!98I zwQat;i4Ob{lz;mwxj!qK9IthricK*X&&ok1O7Gjlwg<7tKAcKIF)QH^=!Y+cGEmhb@$$^j(G+j>i{!`C$&1o&3jb8b4E$F~ z_7A73WWIV3S{)8A#Z7o;R?o9w(1&t3zT3BT{=0oQPE3D~X2t$8N1N5U8QrWZ{`Y$A z;n@Ey0BiZq4E;;q^NjXf4G;^r*me#k6=q(T|5C+f3}qEy7i~%Qj#S4-u_J%snC?}me+}d(O(wBD7|~ef7)oU8^M!L;>h7j9`ypdk zHUpyI!u=$7MhbKPGo`HNe_2j;@eLnWO056i*!bF?gY{-H1J8LzM0)SF{riWy7KT4zAw zf+C%(BHa3Yraqq5TXpxw{yH+9j>y&)ppj3+_2i;Rw)biAKK+69t2u1YVvVo=L8^s_ z2jyINL&>&5mqZ_;FD8@YJh@5inn%9^4wMJMQ|6kh&jpkPx|`@Zc*niZ$=?RL8~-_d z2gd&lbQ$`a)l2-k#(x^J8~2%`ugPBqlAGk&qR#}(hwM3Vhv5618u7hp#|MU+_}O=d zzVD4T8fuH8Rq>j{Ujj4*a*OQQpicwThp<)jTDtEH?CN)?`n7W(AnY#e8s2(&YWLP{ z&}@)w!v{FV1v-W&`?g#BWkfcIpmZDZ)Z@c+3B`w{8;>F9eEh}Rmdk2a8x_2AFuW1ol{-#l{_eU|*TDlLhPko6~m zrB(ON04uJ~yykHX>x%c;=2M1Y<&WqVrR@aE#jmsG$0J9LH!Gr=DLJxdGwB1yG6kB+ zs%U=;PzunmP)vmPE?tejFZc~|)Ex@Y7D#H;cfo5^HZL56w$JXJ4}Y6wQj$v4PLb;e z^ut&urg5qo$SwTm{GBfd5$G+-Z#xq1D*>xP)g*JR+JWx7f}%$KHU_=E3Q!z`PJ|6o zSFl#O>kfYxTXlf`vZKY0(_qjb*oHUuQ%~p!N6rXO%5AaSC(AN` zK=>o0Le6I&dAubw6yk^u=0+hu4YrZM4mG1j8=+&}y_3s|%Ns}I&}&Tj<-=;RWJ~!2 ze7&5;9^#cCWd`Q}<<+IJ>Vs=)>GM1E%Y|;$G)>mL2EzvP<~6VEAzioFtzgx}VvqHh zqgTOWympFX3;fRXO$_Wuu`?ZE`9Q-8`k8G}@zrBx!Rc#&f&fpGN^MkpMnk;S_eeBY zwDE<9eWi!(!**De`<}FLWOmvT{#sr1NmI{LQ|oiKvc0_e_0Tx7-Z=f%xE#{BP11OT zvgSf@5%nJQ5jTAeaf|WE*FB&!>hlce`NPK_XGiB6?ETm0v2-Q=^f|v^=bz88{XNG0 z`bYphHK5h9!$A!JwFIrr=s!(kJ!508lXZx|lC$c9je*|T1R$F=Ep8-|^<&Eo_ytD3~0QN=nEY;_;r{vkE0@j1~9KS>6?=wvC z=06RUP5B(DTd*VEP1VSMP1rZ`&7DENY*F6p5$1wubM(k_@X2!Px_tZn8NDsw@f;B^ z>SAw)(kr)xFU!Xx%10Z7HxKuK$FD^2CJ}>xwWC4srsbPo<~;`J3)vz}rCuT|rClP- zr5_&6INJ|XeFiMDsfFLCu!q6c@$4Dq$ z(mC`{BQf+abAH3UAFtl~y?3qu`ft{O8948=_t~@0%YNQ{p8e)Yynd7iCUsB)lh~>O zB#vs}fLck6NS-7{tV|L^c1i*f7nS#WU6XVqx?|}GcrM%&oqb9Vh;>aV9UJ7SCchXd zm9AW$%GclD(kRB{myBZf^G2~h)Qd5t#X7#5M#TpcrTWMbm_G8^v*H6f-Qoj`OXZ}m zT;(KC_F}&scl5t`u|GCHvJM*@S?^~m9D&I`D}=Rc6#`NDqh5kl`imFdc+nc9f_uGb zcX+BwZdl# zj1wIbpcxs=RF_yc!~H@UqhVzdyR_KH0j&}po<~H-un@npkEh%8$IqFL7fBZ2o!s0M z>4?~*k=~WdPhf(*H5`AAm#H6y@oisipE~|IUZxIMsuN+{-kR+2N4!Iky@d>(*ID2% zw-jfupE~ezoAH26c3Dcfr6Sz#y4fe)aQR?rAOf)6?7o0J%?9KRA89hPIQv$>LU$7I zZvyp^mr$v&#H$S1T+y)ah_xcy@_W=M*6SBi?ZgvMk0Y7}f(;}$Y8x(GAS?Ckai4iE zgPu-0B~rs>lbRlPlW(bYW>3g?ziUZV`%z2>Y@5Z%rGg z6Ti~mv9K0)Z+-Y-YTSeNd!SJ+bWU@yIghM zJtB#Hw$C`RV0Y)ch12$JCq~!wq*KKEj3G*{d!c>k8hX}DRiy8-L~`%}gR?J(IT)JU zp5S~@^+g@aHBnpkbgS)`$jIweH%H$CJwqFTp8QJ^C}<4QPEbpUyofdipu0W^{)#Mr zhZ&4q{J7YDO*DTkNoM;~j$ecM(Rz0g`L}Id*oBR}&qlcKHgn1Hyi*&r54S;d`oxY4 zK0$&*#&c3dKwHQ-=oL|~bFxVRpAckKNkMrm@8c43GbH~W12+i)LH|fY!+C6kba=C} zA?T`q?Mz6rmyq>U^o;QbS=Z^BKvsUE50}%Rv8udY@qDWY`&X_)u`~^78zc*^)lqfZ zKBUZ-%Hi20-hAyd`4cqsVqO|U{9$wQipMSm1k@Xi3sU=YF|cQwMwA5?y3T*^Nxrl#wWO253%i71x|4;7AZNL60jk@Ax@m0(6oN7) zihMqN;Hs-)iQQEod3@JekE)b)i6jHsLhl=U$t?_?QO3ZaqVD8A!!wl2bVe;DF78!f zmJL0L%CvYApztgMYfdw7I|lX(js*=6Ghbo|>-;(E94Y~hC;~_a=M)?G?YCKbU&zMl z06ejO&KiYA!0+}&-iNG9umHE@whFvi$XP48ix>tZE8;w)siu zxFNzZoRDQD?vNm&k?1}0_@}qz553Di#yrnWqT$;}9(s(M>!uQf#!&K;H%6pNkl`k~ z5#K|9pyuLp+5+wNo(lX{$q?+&>qgD1gw0F6Cx=O?1hRkq(WOAPHYfD^ovTp6>e#x+ zA?xZsgo@epImtncH|q??HQ75kz>v_9;U8wxa&&YGI>T~%k37h%fU4QpZr4i8$W*;#HT+@fM-CPl=GjSSJhiU~A9}-%0x6Fp+rq3>;&HJW6f2yR^ z5S#z%N*_P&9PEH}{)(6JZb?|@Pg3^>y(}-(=z8X}aVdS)|vlm6O}SfBm}58O!~H7V||I z_HUl66n$#gEXy0pUvCxl7w25w^S|dx^xg1j0&bt8fy4ZU;G7-*f(!&U0kIqPwYqU@ z!eUxC4ei_YR+MO9XdK&*X$*$!gfSlSvK}&*uoKOGHuU-{2!Nw<8$!!@X`1gJ%P-0) z>pns{)BNOH2N>prGQK9*(u(P!)?Mi*KVg31w`iO z?Gm~_?i?I@EJMmIaqWd{!`*LZW!;P)u%~N-#Nutug#r8AG=%p;qkb6Zv5R zSN%Kt)g-`!_mG)7N3! zIk6_hDM=(FKj|vyfF~I0MLz|(25|xiMQ7PXv0h#1d&>;c{*f60OnJCb1%80$eUA}& zkC{owz!MHurP0F!#*dI=sRz>$2gRQn>j$tRLkuE=5+dJCZmq&R_7J3dpqnRCSpes^ zAn!PaqZ`g*J4Oqk(^$AntirdQ$tj=HRQtHG5uM}ui2_wsgZ;vCZFr;o2w1`Z9rWVK zDjd%M9Zp`i3S2cn?ob*ad0TXRGp~?uh8D<`AE%(&AqVWIKQ*? zsew5b7JDKphly8*x90(+6X~quFvvLEdICV$L{&ojiJ)U9wy8$1u=bX8UHda^tm_30ulNG4NTB{JJ*@>Ep zV$z)iwT0`oA*%Nn$JEa6>+DHx69{oepI}nrm7erv1>bX_Vb-Qzg0|grxyAepu>!@v zFL;hwubGl zKKKf0HrB+MEVNWKE4i^+eZ*M5ieXov6nE- zDj6y@1l0sjaW7-ZcD%??N8Rk8i_4{-#8ow6+QXil``~DdcL>Iy9oy80Erp29=K9Y< z8pS_h#52XJ2bv6QK}+15QGTx_-ov-ac5h*&upmYTdlrcX)uwSdtXEJ?O-5rXWqls8QIACIT4bpW|2q86@4mF+;Om}RNSskL6nfA?++zgKCob{wbQ zvNx^3X)9c;p_rmlGOYSZC2yEK4}v>qcqb0$KY|rFKl<3`#H)#ETxHfKD;*{;Y`s^x zw4NEKAL#x7$J$8SnCzN^aA0wT5Ed4}*MWGx|BPkJ+(5b8k1M0&+IOn#GFVJ{1p?2*VfBba+LD5j~5TH&-MfbE#bHw*v4 zW_Zk(G64nrRxBGWF*qam!D*1{Vv7kI4>6Fr^x!m%yltCXfxH#YrtWvmnI0m{ahvO| zv24S~n#3u%q+!b<=kgB2r-o2=u+YAqBt}OA4#@}Z9axi~56`2~57B_YeX zP_|5{4ds<7yB-*fhrz@upy`XBQR}JESHFOy1_wu-6# z-({35ZP#>@0RN+3WtMvL$_**JZ!nIfo!OqZR#$QRdz8rItLk?_Xhqo|;r$cmw-9R2 zx2p|7PFK4RZ=7<5k_U}%4ZaplTBQGOPaH-67e^Et3F1x9>)843RjToA8^^-VT1wWZ zB}%ZL-pYtKGPYAU#o3@F<9<*vi7?5Q-uHl#t*D_Get5FrFm(aa>elx`m=cF{*jFEh zDMssa%Un)tgDF+XDSB>SQJ;|p!%F+4xyzO_6MPB{A5Fihx!nxCt5n~%H!k6l*IJ)> z#=iU>PC+K?{3RC11ovp$e3YhAy1Jij9%|APbPIA#0v(Ly6o*ETX~)g=N`M;i1TY;j6vuDvv9EH!uS>j+`C~y#wH}*Y8)vsos*&Ej)>~4qSP0N4 z=#YOSyWem|^c2;l!m|9qKT5hWMXwcm)+XU z{p^PoGm_nRYt&hzL@-D5vJtmD7ouCE7~%x3V(S&|l2miVm{D&e=EGA&T^Ba>IP*7tu}OotTbW5)pq1icLIWvjPglcIRCfzK%1-sM+MUR^SSlc#2;GsCkPH* zIXC?5>iDPX2873w>{HG5DN^E4Y!uxd%e11QhYw> z9nw^fk}|$hDu5dKM(jf56jee+Vr5P|t^2fG^`Jgq5#w@N+w@ z@0$FaWFObjSau(b^d8r$KCD@-t)y_%Svq3bUc7@x&j10pDzh)NGw&K51!)?lL?j?} z_JWnV3n(^jEp@<~Ek^Zfj0pk;kA2=2*h?`8^W^K$~$QLY>w zu{j?UP3I|=7P4mop1+QK8=b!I1*!koU>CnJ<6 zylLo`zD@(EHIiMyOA1s^b;}zVQVg0;_g8o)x-}NHE*A1>$D=T;VZZX8t0Bm}t<(pR zFn@XIhgnY+6F0QT3%+whGj=<8cJOVRH^aWR@cE~aqFeGP?><)|`NdQYO+EU2tXOod zic@R>X21^gB2*+BWc*-XUfu zA-FyAO3q#IOVQzj=Y!XD)Sfn=_;3raNdtbJa&!k)5;@eSOP5h;Ut$pts^9ai$kqvM zieUIERaZ;%u`CJYv#oEU1vzk56)n4TRCoC@CrqOSiG5xfE4+QMwMOeriff_yK|*rt zZHjzSS-g3?ioYyejsLKiy=*5?RDw_HyM~vOkU+|2LkwJY)w(=~tImt5Cz{R+={e`UD zo8FO2U+h$A=<~_i9@4$E%&YPgO-G1{O`-$US^~?5?P=KlqC}9@`{}^50t&aMIkD+&DcB`C_zET zd_*Cs^!%uN&Z&9oA}nx9H!zfti=6Jxk$-b@;Mf&X@&< zQaEblw~28}iL8W0(EcL1YV*B^cJgujWsf{jWtpjfAx?Ppyf&g0Wpc{Rj{mIJT7c+?Ff(` z0w(lZ45HYZvDMML@Eq~vJUHv{q2@X~R|P%Pq=FtRS3ytJs-WSxE!@?$AqNwUD#(!v z6=bz+>SV>U)X8ek)Jfkh;Yy&%eLV_yqzAaKmtx)5aRJuhba(f4_&N9WtrOvW;EQlX zsHFQ1hA+?Fyh#t*;7coOcy&bTOmPS#wxeU)WgDdE7pQly^$!s2kYKKE4N&ipVWP=a z$#ySbq?&Y42_;~QqxFl~AZd98sk^!XUY6SQEWm}iRbRvlDfh7nyW+yoFIK!nyv+)_ShYa+ zzbB&R9^WE;8O;kBXn20+LnxEEQH^X`?!g`Sv;1n@=DB2AS5ofR)JeIw>`IJd#jC+7 zgk5zb|z3CQ;qX)a^+dw4#ArK{YiI0yJbsz75yk%)l`3YsbK z8WQucc0kmj`aKk3%T1p*{K9GZagJ3`c(SFAEea~#sqiArgJyo2PZeDf6gT@SnyK`U zv-wtRlRJEMG#Vu>96ihs+y;F;m7F zhtB!HgsIrAhuvths-(%qqZ4af5ZDjHTZFUNBJqDL%lyPR^LQ5Lp8F49&pZ24k)FF~ zI#Cp5*W{V;?$e4d0WQpWJexqKK6&nGWSJDI@vJRd$N=l*8OEgb$DdBk*RctDx%U-3Aopuj$wrR~yLPK-JCAU245x=Jn}h*>E;nFPNW}hdlIR z*BeiI&$QOS;P|0aBoV2$&!3h2yx<2NG6khf9zw$}^ta5~}CFo$DI(4_|!03guToQRvoAjS3Rc&Np;_c2`tmG`E>n%}0F~k0acSIo zx?|uNp$?HTXHDT8Wd>Jsw-Z{)DGleI6E1tmJSNn++(&NDEht@Mu`r4KiG-8=%qIR}iFWK}A6B~@W;6lx zL1kqpAs3L97m(J2Y3ZW{{(xrT0k%d538)vJm}?fFATav-WA&BmFwYkw>7cO!FuXt; z3@XwFKzSoxUj`mT3w}J}Tp(WHa0H(_gax-J_b+m1G!(J{H`ZM*>>J4VQ)>cK6X^`) z;KMT5;b-7*h@NavyxXQ!)&{l=MJz(Mu1ul{C&A2^o$DABA7-Bzb4YOFN{K9qk$3$Fn$kiV7}!))qV*^sX$O0K5zLI5 zCtPX2veLcSlfK*okxew|P6Uzh06(n7XS+`uLXS_FR<@8mh_5|cPkIh-CIZ_GM|fC# zi7&7@qNAIq=YSy9t7LNtdTq2ap}N(~8(HwTUB5frEz!mt+FFv{4o;@(chg<3rn_wE zxAI%}JV+kw#(8IYH{kA}o<)AplX>+~0+T^@d0FBigS!Lgx)CHpvPP<;L+lE=--ZrB z$-5Mxkd@`SkWW0^V-}>jbFfE-kcBAvOf4&?)5}Jn?dWU5?(o~AK{rSuSA2q2Y95nW zUr!anx#+EiIo!gbi3;lNwH_K$g{~AS)Z4S0|C!%Sk+87=Q>VGIYd*9?-oYBCDoz%l z5yEcNM8M4D8LZYFI=_NnuC#B?xh%!p*V<9yoz0$2nyqr*{gdK69II?VX@=D103rsY==kgt+@i-D)Z3435aQM1wK zbjwV9q#NPuwNZ;fen3KhV1;XZUw>+4B&akVF1wpNKyTnn&wTvdcyRraz==TWD*Sq} zsHgd-7p>=*LvCV{&liwXW52uJK43chUh{N$!?n1gNL~kQS0%GTykTGKm%M&Gajb6q zN5@m6&0+`s&(>8#cTm(}DUfA>vI_^>LZcoLTibkf((R(ZzEjd!F|24u8Anz1F3|-I`>p>?19i{zt1V#AmGCVcd>Az4Qhq(6Qy{{Db9qhBYna`$cl5^`zxp>W2xk9{Zrl5m^3r zSbohqUHe0NqF(c230ITqJ*7(@i7uhKGbctvzCY6IyLi&=-7GU< zm9#YEW_c5&Jw(7QaGg94heE)b5nxSjAXgvA zoy98qpC%vdI=sMK7(~UVxtrgXN<6-{$HBO|wp$t|^|gjcK;6bC-W5?+Utv<-8iB5> zon0)MKc#9_K3w4MzVycaRJc7#8vyHrwhQaiDjsc9WyuGp^=NA1oAaBr|x8li4s#8c$a#m!H54DcNQ7$&> z%l5aHlgz?S#be>L-lkAcn53fUpc+k;S}B{*D+?#ogd`%xF5`6+#n)PPimlJ(nMX z5Jt>+>F_FIjpz0*q1!Om*BN%}b9f_-V;|8nSomEfVEE*HzigkPhd(~e^rh*X3@~rR zo)cc79XoVIn%(G1XUChYeex$8s%)+a4TyxGt(bIV169zP%ixa~7&A=Tn=#-dQqr?C z`L1Qyh!4dEk$(amMIX-_MnoV>O24zCOltp4(?OP$qSf; zMhWp0X^?_dpRfNuLXhQ0N+4Bb}N60{3HrH^k&8>G}=vP)rh z+)$o=SUXSWM4i8b5~UTw1%EamO0J~46Yr&}zp#jmZ4825y`mwSIiH+jlwa+5&kjRa zsd`h4KvHVn;iVKe-I|>ESK6uG#YODrev63%Lu*dAO(b36aHw82)sgTwTl!KhGn$Dz zFw2Kl!&+I>QmDU-UWPft$ zB&1=oz&TPw;d}Don{T{py#~agHR7*dYc?U4JegIG16XELTdG&>6p+$S=}qKzZ8*@r zI?Lb~YA2Sl#07cd4TyshU%SvmU1l>yFRM^G7Oyr{IWW>X>-g!Ih3i!)AcJz?>sZ|< zk}tJ%A(=VJpXXKVUwuqsstS;arE@D*9A}Mj*d{OaVEe!~&Z8GEtBXJKkKT}`GzR7F z#T?ZYe7*41n4EySYwNWUV=aCo@7qqc6_iKPsP2Ka(>aK3ak}>5{1{@C^#0y^nNm)4 z=)%}4nf$cL^cQJzR8`d2Clb`L)AmN3IGNmbZ*4~C-6wnZ%;E3+tKo#k9vH)uebob#c&?N_^_N>nW1LF09=Ecp2c%=DKJ%vac?p}PIbys) zZ&^i!?i?9WOzonqr4E`5j?y0Sv5Fl732p4) z_YWzuGMY4_!04$3g5`aHj8*PH-(7^8wWoDyUevW7Yfh2v>_`60g-zTrbLJ3XxssH6 z-n-ZHHJ^siQpPh=K3%LI?U!5`@|nwM;ib2#xT_$_OW&jH!OM(nxynm#c*DZ*gR^o= zFu4iV#K9Jy%R>L)GglmVe$>$bAq6S6Y;h_bq^eHkzrK;|!G8ok6XPg9$xM>r#lw5U zavmqfId}d#9&Qg8oG?ctAW0#_Ug#|sPFr<${Gp}8{rpuNY;h`4Zzs#2RzHfm#DXDX#%Re)u`& zf7h@6eK5KE{ay0=&z7I{*iVV-nZET`f%^Yn$>)ElU4Mf9{8)a0;NhK#Dt{HCfd32n zyVmvZ4&ayFpLt||y_fzMoL}14|F0q z_PbX0zj4mgvcJk*@c-@TziVgz8|h3v`>PoL3(_ww?SG^E{kmfR1?6{b?VmV5$Mf$J z%`d<6d!{r6k7t Ee|xX0DF6Tf literal 0 HcmV?d00001 diff --git a/perfs.untyped.unsilent.txt b/perfs.untyped.unsilent.txt new file mode 100644 index 0000000..1ba2fa2 --- /dev/null +++ b/perfs.untyped.unsilent.txt @@ -0,0 +1,98 @@ +cd /tmp; for m in '' phc-toolkit/untyped phc-toolkit/untyped/misc phc-toolkit/untyped/require-provide phc-toolkit/untyped/fixnum phc-toolkit/untyped/typed-rackunit phc-toolkit/untyped/typed-rackunit-extensions phc-toolkit/untyped/syntax-parse phc-toolkit/untyped/tmpl phc-toolkit/untyped/threading phc-toolkit/untyped/aliases phc-toolkit/untyped/sequence phc-toolkit/untyped/repeat-stx phc-toolkit/untyped/stx phc-toolkit/untyped/list phc-toolkit/untyped/values phc-toolkit/untyped/ids phc-toolkit/untyped/generate-indices phc-toolkit/untyped/set phc-toolkit/untyped/type-inference-helpers phc-toolkit/untyped/percent phc-toolkit/untyped/not-implemented-yet phc-toolkit/untyped/cond-let phc-toolkit/untyped/multiassoc-syntax phc-toolkit/untyped/tmpl-multiassoc-syntax phc-toolkit/untyped/logn-id phc-toolkit/untyped/compat phc-toolkit/untyped/eval-get-values phc-toolkit/untyped/meta-struct phc-toolkit/untyped/contract; do echo "#lang racket/base (require $m)" > perf.rkt; echo $(((0$(for i in `seq 5`; do rm -fr compiled; t="$((time raco make perf.rkt) 2>&1)"; echo -n '+'; echo "$t" | sed -e 's/raco make perf.rkt *//' -e 's/s .*$//' -e 's/^\([0-9]*\)$/\100/' -e 's/,\([0-9]\)$/\10/' -e 's/,\([0-9][0-9]\)/\1/'; done)) / 5)) $m; done + 36 none +140 phc-toolkit/untyped + 83 phc-toolkit/untyped/misc + 83 phc-toolkit/untyped/require-provide + 81 phc-toolkit/untyped/fixnum +126 phc-toolkit/untyped/typed-rackunit +129 phc-toolkit/untyped/typed-rackunit-extensions + 84 phc-toolkit/untyped/syntax-parse + 81 phc-toolkit/untyped/tmpl + 81 phc-toolkit/untyped/threading + 82 phc-toolkit/untyped/aliases + 83 phc-toolkit/untyped/sequence + 81 phc-toolkit/untyped/repeat-stx + 83 phc-toolkit/untyped/stx + 81 phc-toolkit/untyped/list + 82 phc-toolkit/untyped/values +103 phc-toolkit/untyped/ids + 82 phc-toolkit/untyped/generate-indices + 81 phc-toolkit/untyped/set +112 phc-toolkit/untyped/type-inference-helpers + 84 phc-toolkit/untyped/percent + 82 phc-toolkit/untyped/not-implemented-yet + 82 phc-toolkit/untyped/cond-let + 83 phc-toolkit/untyped/multiassoc-syntax + 82 phc-toolkit/untyped/tmpl-multiassoc-syntax + 81 phc-toolkit/untyped/logn-id + 80 phc-toolkit/untyped/compat + 83 phc-toolkit/untyped/eval-get-values + 81 phc-toolkit/untyped/meta-struct + 83 phc-toolkit/untyped/contract + + +cd /tmp; for m in '' phc-toolkit/untyped phc-toolkit/untyped/misc phc-toolkit/untyped/require-provide phc-toolkit/untyped/fixnum phc-toolkit/untyped/typed-rackunit phc-toolkit/untyped/typed-rackunit-extensions phc-toolkit/untyped/syntax-parse phc-toolkit/untyped/tmpl phc-toolkit/untyped/threading phc-toolkit/untyped/aliases phc-toolkit/untyped/sequence phc-toolkit/untyped/repeat-stx phc-toolkit/untyped/stx phc-toolkit/untyped/list phc-toolkit/untyped/values phc-toolkit/untyped/ids phc-toolkit/untyped/generate-indices phc-toolkit/untyped/set phc-toolkit/untyped/type-inference-helpers phc-toolkit/untyped/percent phc-toolkit/untyped/not-implemented-yet phc-toolkit/untyped/cond-let phc-toolkit/untyped/multiassoc-syntax phc-toolkit/untyped/tmpl-multiassoc-syntax phc-toolkit/untyped/logn-id phc-toolkit/untyped/compat phc-toolkit/untyped/eval-get-values phc-toolkit/untyped/meta-struct phc-toolkit/untyped/contract; do echo "#lang racket (require $m)" > perf.rkt; echo $(((0$(for i in `seq 5`; do rm -fr compiled; t="$((time raco make perf.rkt) 2>&1)"; echo -n '+'; echo "$t" | sed -e 's/raco make perf.rkt *//' -e 's/s .*$//' -e 's/^\([0-9]*\)$/\100/' -e 's/,\([0-9]\)$/\10/' -e 's/,\([0-9][0-9]\)/\1/'; done)) / 5)) $m; done +55 none +143 phc-toolkit/untyped +82 phc-toolkit/untyped/misc +83 phc-toolkit/untyped/require-provide +82 phc-toolkit/untyped/fixnum +126 phc-toolkit/untyped/typed-rackunit +129 phc-toolkit/untyped/typed-rackunit-extensions +83 phc-toolkit/untyped/syntax-parse +82 phc-toolkit/untyped/tmpl +83 phc-toolkit/untyped/threading +82 phc-toolkit/untyped/aliases +83 phc-toolkit/untyped/sequence +83 phc-toolkit/untyped/repeat-stx +84 phc-toolkit/untyped/stx +82 phc-toolkit/untyped/list +82 phc-toolkit/untyped/values +103 phc-toolkit/untyped/ids +82 phc-toolkit/untyped/generate-indices +83 phc-toolkit/untyped/set +110 phc-toolkit/untyped/type-inference-helpers +82 phc-toolkit/untyped/percent +83 phc-toolkit/untyped/not-implemented-yet +82 phc-toolkit/untyped/cond-let +84 phc-toolkit/untyped/multiassoc-syntax +83 phc-toolkit/untyped/tmpl-multiassoc-syntax +82 phc-toolkit/untyped/logn-id +83 phc-toolkit/untyped/compat +81 phc-toolkit/untyped/eval-get-values +82 phc-toolkit/untyped/meta-struct +82 phc-toolkit/untyped/contract + + + +cd /tmp; for m in '' phc-toolkit phc-toolkit/misc phc-toolkit/require-provide phc-toolkit/fixnum phc-toolkit/typed-rackunit phc-toolkit/typed-rackunit-extensions phc-toolkit/syntax-parse phc-toolkit/tmpl phc-toolkit/threading phc-toolkit/aliases phc-toolkit/sequence phc-toolkit/repeat-stx phc-toolkit/stx phc-toolkit/list phc-toolkit/values phc-toolkit/ids phc-toolkit/generate-indices phc-toolkit/set phc-toolkit/type-inference-helpers phc-toolkit/percent phc-toolkit/not-implemented-yet phc-toolkit/cond-let phc-toolkit/multiassoc-syntax phc-toolkit/tmpl-multiassoc-syntax phc-toolkit/logn-id phc-toolkit/compat phc-toolkit/eval-get-values phc-toolkit/meta-struct phc-toolkit/contract; do echo "#lang typed/racket/base (require $m)" > perf.rkt; echo $(((0$(for i in `seq 5`; do rm -fr compiled; t="$((time raco make perf.rkt) 2>&1)"; echo -n '+'; echo "$t" | sed -e 's/raco make perf.rkt *//' -e 's/s .*$//' -e 's/^\([0-9]*\)$/\100/' -e 's/,\([0-9]\)$/\10/' -e 's/,\([0-9][0-9]\)/\1/'; done)) / 5)) $m; done +153 none +291 phc-toolkit +167 phc-toolkit/misc +170 phc-toolkit/require-provide +172 phc-toolkit/fixnum +233 phc-toolkit/typed-rackunit +238 phc-toolkit/typed-rackunit-extensions +175 phc-toolkit/syntax-parse +167 phc-toolkit/tmpl +169 phc-toolkit/threading +172 phc-toolkit/aliases +170 phc-toolkit/sequence +169 phc-toolkit/repeat-stx +178 phc-toolkit/stx +167 phc-toolkit/list +171 phc-toolkit/values +243 phc-toolkit/ids +170 phc-toolkit/generate-indices +168 phc-toolkit/set +198 phc-toolkit/type-inference-helpers +173 phc-toolkit/percent +167 phc-toolkit/not-implemented-yet +172 phc-toolkit/cond-let +180 phc-toolkit/multiassoc-syntax +172 phc-toolkit/tmpl-multiassoc-syntax +171 phc-toolkit/logn-id +168 phc-toolkit/compat +174 phc-toolkit/eval-get-values +170 phc-toolkit/meta-struct +167 phc-toolkit/contract diff --git a/repeat-stx.rkt b/repeat-stx.rkt new file mode 100644 index 0000000..a49364b --- /dev/null +++ b/repeat-stx.rkt @@ -0,0 +1,114 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide repeat-stx) + + (require syntax/stx + (for-syntax racket/base + racket/syntax + syntax/parse)) + + (define-for-syntax (repeat-stx-2 stx) + (syntax-parse stx + [(a:id b:id) + #'(λ _ a)] + [(a:id (b:expr (~literal ...))) + #`(λ (bs) (stx-map #,(repeat-stx-2 #'(a b)) bs))])) + + (define-for-syntax (repeat-stx-1 stx) + (syntax-parse stx + [(a:id b:expr) + #`(λ (a bs) (#,(repeat-stx-2 #'(a b)) bs))] + [((a:expr (~literal ...)) (b:expr (~literal ...))) + #`(λ (s1 s2) (stx-map #,(repeat-stx-1 #'(a b)) s1 s2))])) + + (define-syntax (repeat-stx stx) + (syntax-parse stx + [(_ a:expr b:expr) + #`(#,(repeat-stx-1 #'(a b)) #'a #'b)]))) + +(module test racket + (require (submod ".." untyped)) + (require syntax/parse + rackunit) + + (check-equal? + (syntax-parse #'(1 2) + [(a b) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a b)))]) + 1) + + (check-equal? + (syntax-parse #'(1 2 3) + [(a b ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a (b ...))))]) + '(1 1)) + + (check-equal? + (syntax-parse #'(1 (2 3) (uu vv ww) (xx yy)) + [(a (b ...) ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a ((b ...) ...))))]) + '((1 1) (1 1 1) (1 1))) + + (check-equal? + (syntax-parse #'(1 ((2) (3 3)) ((uu) (vv vv) (ww ww ww)) ((xx) (yy))) + [(a ((b ...) ...) ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx a (((b ...) ...) ...))))]) + '(((1) (1 1)) ((1) (1 1) (1 1 1)) ((1) (1)))) + + (check-equal? + (syntax-parse #'([1 x] [2 y] [3 z]) + [([a b] ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) (b ...))))]) + '(1 2 3)) + + (check-equal? + (syntax-parse #'((1 2 3) (a b)) + [([a b ...] ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) ((b ...) ...))))]) + '((1 1) (a))) + + (check-equal? + (syntax-parse #'(((1 2 3) (a b)) ((x y z t) (-1 -2))) + [[[[a b ...] ...] ...] + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx ((a ...) ...) (((b ...) ...) ...))))]) + '(((1 1) (a)) ((x x x) (-1)))) + + (check-equal? + (syntax-parse #'((f (1 2 3) (a b)) (g (x y z t) (-1 -2))) + [[[a (b ...) ...] ...] + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) (((b ...) ...) ...))))]) + '(((f f f) (f f)) ((g g g g) (g g)))) + + (check-equal? + (syntax-parse #'((h () ()) (i () (x y z) ())) + [([a (b ...) ...] ...) + (syntax->datum + (datum->syntax + #'dummy + (repeat-stx (a ...) (((b ...) ...) ...))))]) + '((() ()) (() (i i i) ())))) \ No newline at end of file diff --git a/require-provide.rkt b/require-provide.rkt new file mode 100644 index 0000000..f424047 --- /dev/null +++ b/require-provide.rkt @@ -0,0 +1,22 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules + (provide require/provide) + + (define-syntax (require/provide stx) + (syntax-case stx () + [(_ require-spec ...) + #'(begin + (require require-spec ...) + (provide (all-from-out require-spec ...)))])) + + (module+ test + (require typed/rackunit) + (module ma typed/racket + (define require-provide-foo 7) + (provide require-provide-foo)) + (module mb typed/racket + (require (submod ".." "..")) + (require/provide (submod ".." ma))) + (require 'mb) + (check-equal? require-provide-foo 7))) \ No newline at end of file diff --git a/scribblings/aliases-untyped.scrbl b/scribblings/aliases-untyped.scrbl new file mode 100644 index 0000000..210cde2 --- /dev/null +++ b/scribblings/aliases-untyped.scrbl @@ -0,0 +1,29 @@ +#lang scribble/manual +@require["utils.rkt" + @for-label[phc-toolkit/untyped/aliases + racket/base + (only-in racket ... compose) + racket/match + syntax/parse]] +@(def-orig orig [racket/syntax] + generate-temporary) + +@title{Untyped versions of the aliases} +@defmodule[phc-toolkit/untyped/aliases + #:use-sources + [phc-toolkit/untyped/aliases]] + +@defidform[∘]{An alias for @racket[compose]} +@defidform[…]{An alias for @racket[...]} +@defidform[…+]{An alias for @racket[...+]} +@defidform[match-λ]{An alias for @racket[match-lambda]} +@defidform[match-λ*]{An alias for @racket[match-lambda*]} +@defidform[match-λ**]{An alias for @racket[match-lambda**]} +@defidform[generate-temporary]{Equivalent to @orig:generate-temporary (but not + @racket[free-identifier=?] to the original for now)} +@defidform[attr]{An alias for @racket[attribute] which also works for plain + syntax pattern variables} +@defidform[|@|]{An alias for @racket[attribute] which also works for plain + syntax pattern variables} +@defform[(when-attr name expr)]{ + Equivalent to @racket[(if (attribute name) expr #'())]} \ No newline at end of file diff --git a/scribblings/aliases.scrbl b/scribblings/aliases.scrbl new file mode 100644 index 0000000..8419707 --- /dev/null +++ b/scribblings/aliases.scrbl @@ -0,0 +1,31 @@ +#lang scribble/manual +@require["utils.rkt" + @for-label[phc-toolkit/aliases + racket/base + (only-in racket ... compose) + racket/match + syntax/parse]] +@(def-orig orig [racket/syntax] + generate-temporary) + +@title{Aliases for other racket identifiers} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/aliases + #:use-sources + [phc-toolkit/aliases]] + +@defidform[∘]{An alias for @racket[compose]} +@defidform[…]{An alias for @racket[...]} +@defidform[…+]{An alias for @racket[...+]} +@defidform[match-λ]{An alias for @racket[match-lambda]} +@defidform[match-λ*]{An alias for @racket[match-lambda*]} +@defidform[match-λ**]{An alias for @racket[match-lambda**]} +@defidform[generate-temporary]{Typed version of @orig:generate-temporary} +@defidform[attr]{An alias for @racket[attribute] which also works for plain + syntax pattern variables} +@defidform[|@|]{An alias for @racket[attribute] which also works for plain + syntax pattern variables} +@defform[(when-attr name expr)]{ + Equivalent to @racket[(if (attribute name) expr #'())]} + +@include-section{aliases-untyped.scrbl} diff --git a/scribblings/backtrace-untyped.scrbl b/scribblings/backtrace-untyped.scrbl new file mode 100644 index 0000000..b106029 --- /dev/null +++ b/scribblings/backtrace-untyped.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/backtrace]] +@(def-orig typed [phc-toolkit/backtrace]) +@title{Untyped versions of backtrace} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/untyped/backtrace + #:use-sources + [(submod (lib "phc-toolkit/backtrace.rkt") untyped)]] + diff --git a/scribblings/backtrace.scrbl b/scribblings/backtrace.scrbl new file mode 100644 index 0000000..09fe88c --- /dev/null +++ b/scribblings/backtrace.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/backtrace]] +@title{backtrace} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/backtrace + #:use-sources + [(submod (lib "phc-toolkit/backtrace.rkt") typed)]] + +@include-section{backtrace-untyped.scrbl} diff --git a/scribblings/compat-untyped.scrbl b/scribblings/compat-untyped.scrbl new file mode 100644 index 0000000..b953a5d --- /dev/null +++ b/scribblings/compat-untyped.scrbl @@ -0,0 +1,16 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/compat]] +@(def-orig typed [phc-toolkit/compat] + with-disappeared-uses* + record-disappeared-uses*) +@title{Untyped versions of compat} +@defmodule[phc-toolkit/untyped/compat + #:use-sources + [(submod (lib "phc-toolkit/compat.rkt") untyped)]] + +@defidform[record-disappeared-uses*]{ + Untyped version of @|typed:record-disappeared-uses*|.} +@defidform[with-disappeared-uses*]{ + Untyped version of @|typed:with-disappeared-uses*|.} diff --git a/scribblings/compat.scrbl b/scribblings/compat.scrbl new file mode 100644 index 0000000..59f2624 --- /dev/null +++ b/scribblings/compat.scrbl @@ -0,0 +1,23 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/compat]] +@title{Compatibility wrappers} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/compat + #:use-sources + [(submod (lib "phc-toolkit/compat.rkt") typed)]] + +@defproc[(record-disappeared-uses* [ids : (U Identifier (Listof Identifier))]) + Any]{ + On Racket 6.5, @racket[record-disappeared-uses] only accepted a list + of identifiers, not a single identifier on its own. This wrapper allows + passing a single identifier on Racket 6.5 too.} + +@defform[(with-disappeared-uses* . body)]{ + On Racket 6.5, @racket[with-disappeared-uses] allowed a single body + expression. This wrapper wraps the @racket[body] expressions with a + @racket[let] form, so that multiple expressions and definitions can be used as + the body of @racket[with-disappeared-uses*] on Racket 6.5 too.} + +@include-section{compat-untyped.scrbl} diff --git a/scribblings/cond-let-untyped.scrbl b/scribblings/cond-let-untyped.scrbl new file mode 100644 index 0000000..3637580 --- /dev/null +++ b/scribblings/cond-let-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/cond-let]] +@(def-orig typed [phc-toolkit/cond-let]) +@title{Untyped versions of cond-let} +@defmodule[phc-toolkit/untyped/cond-let + #:use-sources + [(submod (lib "phc-toolkit/cond-let.rkt") untyped)]] + diff --git a/scribblings/cond-let.scrbl b/scribblings/cond-let.scrbl new file mode 100644 index 0000000..b579bfc --- /dev/null +++ b/scribblings/cond-let.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/cond-let]] +@title{cond-let} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/cond-let + #:use-sources + [(submod (lib "phc-toolkit/cond-let.rkt") typed)]] + +@include-section{cond-let-untyped.scrbl} diff --git a/scribblings/contract-untyped.scrbl b/scribblings/contract-untyped.scrbl new file mode 100644 index 0000000..8833883 --- /dev/null +++ b/scribblings/contract-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/contract]] +@(def-orig typed [phc-toolkit/contract]) +@title{Untyped versions of contract} +@defmodule[phc-toolkit/untyped/contract + #:use-sources + [(submod (lib "phc-toolkit/contract.rkt") untyped)]] + diff --git a/scribblings/contract.scrbl b/scribblings/contract.scrbl new file mode 100644 index 0000000..c59401e --- /dev/null +++ b/scribblings/contract.scrbl @@ -0,0 +1,33 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/contract + racket/function + racket/contract]] +@title{contract} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/contract + #:use-sources + [(submod (lib "phc-toolkit/contract.rkt") typed)]] + +@defproc[(regexp-match/c [rx (or/c string? regexp?)]) contract? + #:value (and/c (or/c string? bytes? path? input-port?) + (curry regexp-match? rx))]{ + + Returns a contract which accepts only values matching the given regular + expression.} + +@defproc[(id/c [id identifier?]) contract? + #:value (and/c identifier? (curry free-identifier=? id))]{ + Returns a contract which accepts only identifiers which are + @racket[free-identifier=?] to @racket[id].} + +@defidform[define/contract?]{ + Like @racket[define/contract], but later versions of this library may allow + disabling the contracts via a parameter or syntax parameter. This form will be + useful for internal functions, to ease debugging during development, but with + the (future) possibility of disabling the contracts in the final version, to + avoid the performance cost of checking many contracts between internal + functions.} + +@include-section{contract-untyped.scrbl} diff --git a/scribblings/eval-get-values-untyped.scrbl b/scribblings/eval-get-values-untyped.scrbl new file mode 100644 index 0000000..f3a7e3b --- /dev/null +++ b/scribblings/eval-get-values-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/eval-get-values]] +@(def-orig typed [phc-toolkit/eval-get-values]) +@title{Untyped versions of eval-get-values} +@defmodule[phc-toolkit/untyped/eval-get-values + #:use-sources + [(submod (lib "phc-toolkit/eval-get-values.rkt") untyped)]] + diff --git a/scribblings/eval-get-values.scrbl b/scribblings/eval-get-values.scrbl new file mode 100644 index 0000000..6b3051b --- /dev/null +++ b/scribblings/eval-get-values.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/eval-get-values]] +@title{eval-get-values} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/eval-get-values + #:use-sources + [(submod (lib "phc-toolkit/eval-get-values.rkt") typed)]] + +@include-section{eval-get-values-untyped.scrbl} diff --git a/scribblings/fixnum-untyped.scrbl b/scribblings/fixnum-untyped.scrbl new file mode 100644 index 0000000..1b2b61e --- /dev/null +++ b/scribblings/fixnum-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/fixnum]] +@(def-orig typed [phc-toolkit/fixnum]) +@title{Untyped versions of fixnum} +@defmodule[phc-toolkit/untyped/fixnum + #:use-sources + [(submod (lib "phc-toolkit/fixnum.rkt") untyped)]] + diff --git a/scribblings/fixnum.scrbl b/scribblings/fixnum.scrbl new file mode 100644 index 0000000..bfb6d7e --- /dev/null +++ b/scribblings/fixnum.scrbl @@ -0,0 +1,20 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/fixnum]] +@(def-orig orig [racket/fixnum] fxxor) +@title{Fixnum operations (fxxor …)} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/fixnum + #:use-sources + [(submod (lib "phc-toolkit/fixnum.rkt") typed)]] + +@defproc[(fxxor2 [a Fixnum] [b Fixnum]) Fixnum]{ + @orig:fxxor from @racketmodname[racket/fixnum], re-provided with the type + @racket[(Fixnum Fixnum → Fixnum)].} + +@defproc[(fxxor [a Fixnum] ...) Fixnum]{ + N-aray generalization or @racket[fxxor2]. Equivalent to + @racket[(foldl fxxor2 0 args)].} + +@include-section{fixnum-untyped.scrbl} diff --git a/scribblings/for-star-list-star.scrbl b/scribblings/for-star-list-star.scrbl new file mode 100644 index 0000000..47c078a --- /dev/null +++ b/scribblings/for-star-list-star.scrbl @@ -0,0 +1,33 @@ +#lang scribble/manual +@require[@for-label[phc-toolkit/stx + racket/base]] + +@title{for*/list*} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@defmodule[phc-toolkit/untyped/for-star-list-star] + +@defform[(for*/list* [sequences …] . body) + #:grammar ([sequences + (* [id seq-expr] …) + ([id seq-expr] …)])]{ + This form allows iteration over sequences, collecting + nested lists as the final result. Each @racket[sequences] + group of @racket[[id seq-expr]] starts a new level of + nesting. When the @racket[*] is present at the beginning of + a group, its bindings are evaluated in sequence (like + @racket[let*] and @racket[for*/list]), otherwise they are + evaluated in parallel (like @racket[let] and + @racket[for/list]). + + This form is equivalent to: + @racketblock[ + (for/list ([id seq-expr …]) + (for/list ([id seq-expr …]) + (for/list ([id seq-expr …]) + … + (for/list ([id seq-expr …]) + body))))] + except when a group of @racket[[id seq-expr]] starts with + a @racket[*], then @racket[for*/list] is used for that + group instead of @racket[for/list].} \ No newline at end of file diff --git a/scribblings/format-id-record-untyped.scrbl b/scribblings/format-id-record-untyped.scrbl new file mode 100644 index 0000000..1e03d14 --- /dev/null +++ b/scribblings/format-id-record-untyped.scrbl @@ -0,0 +1,124 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + scribble/struct + scribble/decode + @for-label[phc-toolkit/untyped-only/format-id-record + phc-toolkit/stx + racket/syntax + syntax/parse + racket/contract + racket/base]] +@title[#:tag "phc-toolkit-format-id-record"]{Formatting identifiers so that + DrRacket still shows arrows} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/untyped-only/format-id-record + #:use-sources + [(lib "phc-toolkit/untyped-only/format-id-record.rkt")]] + +@defproc[(format-id/record [lctx (or/c syntax? #f)] + [fmt (stx-e/c + (and/c string? + (regexp-match/c "^([^~]|~~|~a|~A)*$")))] + [#:source src (or/c syntax? #f) #f] + [#:props props (or/c syntax? #f) #f] + [vs (or/c string? symbol? keyword? char? number? + (syntax/c string?) + identifier? + (syntax/c keyword?) + (syntax/c char?) + (syntax/c number?))] + ...) + identifier?]{ + Like @racket[format-id], but cooperates with @racket[with-sub-range-binders] + to record sub-range binders, which allow DrRacket to draw arrows from the + identifiers present in @racket[vs ...] to occurrences of the resulting + identifier. It also means that when one or more identifiers present in + @racket[vs ...] are concatenated with other strings, it is possible to rename + parts of the resulting identifier in DrRacket. + + If @racket[fmt] is a syntax object containing a string, then arrows are drawn + from the format itself to the generated identifier, for each part of the + format which appears in the identifier (e.g. if the format is + @racket["x~~y~az"], then two arrows will be drawn from the format, one for + @racket["x~~y"], and one for @racket["z"]. + + This function must be called within the dynamic extent of + @racket[with-sub-range-binders] or @racket[with-arrows].} + +@defform[(with-sub-range-binders body-expr ... stx-expr)]{ + The value produced by @racket[stx-expr] must be a syntax object. All + @seclink["Syntax_Properties_that_Check_Syntax_Looks_For" + #:doc '(lib "scribblings/tools/tools.scrbl")]{sub-range binders} + recorded via @racket[record-sub-range-binders!] or + @racket[maybe-record-sub-range-binders!] are added to the syntax object in a + @seclink["Syntax_Properties_that_Check_Syntax_Looks_For" + #:doc '(lib "scribblings/tools/tools.scrbl") + ]{@racket['sub-range-binders]} property. +} + +@defform[(with-arrows body-expr ... stx-expr)]{ + Equivalent to: + + @racketblock[(with-disappeared-uses + (with-sub-range-binders + body-expr ... stx-expr))]} + +@defform[(syntax-parser-with-arrows . syntax-parser-options+clauses)]{ + Equivalent to: + + @racketblock[(λ (stx) + (with-arrows + ((syntax-parser . syntax-parser-options+clauses) stx)))] + + Within the @racket[syntax-parser-options+clauses], it is possible to use the + @racket[stx] identifier to refer to the whole syntax, in addition to using + @racket[syntax/parse]'s @racket[this-syntax].} + +@defproc[(record-sub-range-binders! [sub-range-binders + (or/c sub-range-binder/c + (listof sub-range-binder/c))]) + void?]{ + Cooperates with the enclosing @racket[with-sub-range-binders] or + @racket[with-arrows] to record the given sub-range-binders so that they are + added to the syntax object returned by @racket[with-sub-range-binders] or + @racket[with-arrows]. + + This function must be called within the dynamic extent of + @racket[with-sub-range-binders] or @racket[with-arrows].} + +@defproc[(maybe-record-sub-range-binders! [sub-range-binders + (or/c sub-range-binder/c + (listof sub-range-binder/c))]) + void?]{ + Cooperates with the enclosing @racket[with-sub-range-binders] or + @racket[with-arrows] to record the given sub-range-binders so that they are + added to the syntax object returned by @racket[with-sub-range-binders] or + @racket[with-arrows]. + + If this function is not called within the dynamic extent of + @racket[with-sub-range-binders] or @racket[with-arrows], it has no effect and + the sub-range-binders are not recorded.} + +@defparam[current-recorded-sub-range-binders sub-range-binders + (or/c (listof sub-range-binder/c) false/c)]{ + This parameter contains the list of sub-range-binders recorded so far by the + nearest @racket[with-sub-range-binders] or @racket[with-arrows].} + +@defthing[sub-range-binder/c chaperone-contract? + #:value + (or/c (vector/c syntax? + exact-nonnegative-integer? exact-nonnegative-integer? + (real-in 0 1) (real-in 0 1) + syntax? + exact-nonnegative-integer? exact-nonnegative-integer? + (real-in 0 1) (real-in 0 1)) + (vector/c syntax? + exact-nonnegative-integer? exact-nonnegative-integer? + syntax? + exact-nonnegative-integer? exact-nonnegative-integer?) + )]{ + A contract accepting valid representations of + @seclink["Syntax_Properties_that_Check_Syntax_Looks_For" + #:doc '(lib "scribblings/tools/tools.scrbl")]{sub-range binders}. +} \ No newline at end of file diff --git a/scribblings/generate-indices-untyped.scrbl b/scribblings/generate-indices-untyped.scrbl new file mode 100644 index 0000000..a728324 --- /dev/null +++ b/scribblings/generate-indices-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/generate-indices]] +@(def-orig typed [phc-toolkit/generate-indices]) +@title{Untyped versions of generate-indices} +@defmodule[phc-toolkit/untyped/generate-indices + #:use-sources + [(submod (lib "phc-toolkit/generate-indices.rkt") untyped)]] + diff --git a/scribblings/generate-indices.scrbl b/scribblings/generate-indices.scrbl new file mode 100644 index 0000000..0e89edf --- /dev/null +++ b/scribblings/generate-indices.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/generate-indices]] +@title{generate-indices} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/generate-indices + #:use-sources + [(submod (lib "phc-toolkit/generate-indices.rkt") typed)]] + +@include-section{generate-indices-untyped.scrbl} diff --git a/scribblings/ids-untyped.scrbl b/scribblings/ids-untyped.scrbl new file mode 100644 index 0000000..2d1aa55 --- /dev/null +++ b/scribblings/ids-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/ids]] +@(def-orig typed [phc-toolkit/ids]) +@title{Untyped versions of ids} +@defmodule[phc-toolkit/untyped/ids + #:use-sources + [(submod (lib "phc-toolkit/ids.rkt") untyped)]] + diff --git a/scribblings/ids.scrbl b/scribblings/ids.scrbl new file mode 100644 index 0000000..2dca809 --- /dev/null +++ b/scribblings/ids.scrbl @@ -0,0 +1,76 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[racket/base + racket/contract + phc-toolkit/ids + phc-toolkit/contract]] +@title{Generating identifiers} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/ids + #:use-sources + [(submod (lib "phc-toolkit/ids.rkt") typed)]] + +@defform[(define-temp-ids maybe-concise simple-format base+ellipses + maybe-first-base maybe-prefix) + #:grammar + [(base+ellipses base + (base+ellipses ooo)) + (maybe-concise (code:line) + (code:line #:concise)) + (maybe-first-base (code:line) + (code:line #:first-base first-base)) + (maybe-prefix (code:line) + (code:line #:prefix prefix))] + #:contracts + [(simple-format (syntax/c + (and/c string? + (or/c (regexp-match/c #rx"^[^~]*~a[^~]*$") + (regexp-match/c #rx"^[^~]*$"))))) + (base identifier?) + (first-base identifier?) + (prefix (or/c string? identifier?)) + (ooo (id/c ...))]]{ + Defines @racket[_new-name] as a syntax attribute, with the same nested + structure as @racket[base]. The @racket[_new-name] is obtained by applying the + @racket[base] to the given @racket[simple-format] string. The generated syntax + contains identifiers derived using the @racket[base] and + @racket[simple-format] in the same way. Each of the generated identifiers is + unique, in the sense that there are not two generated identifiers which are + @racket[free-identifier=?] to each other. + + If the @racket[#:first-base] option is specified, then @racket[_new-first] is + also defined to be the first generated identifier in the whole tree. In other + words, @racket[_new-first] will be bound to the same identifier as + @racket[_new-name] if there are no ellipses, to the value of + @racket[(stx-car _new-name)] if there is one level of ellipses, to the value + of @racket[(stx-car (stx-car _new-name))] if there are two levels, and so on. + The identifier @racket[_new-first] is generated by applying + @racket[first-base] to the @racket[simple-format]. + + If the @racket[#:prefix] option is specified, then the generated identifiers + are prefixed with @racket[prefix], followed by a colon @racket[":"]. This does + not impact the @racket[_new-name] and @racket[_new-first] identifiers, so it + can be useful when succinct identifiers are desired for the syntax attributes + within the macro which uses @racket[define-temp-ids], but the generated + identifiers should contain more context, to improve the readability of error + messages which involve the generated temporary identifiers. + + If the @racket[#:concise] option is specified, then the generated identifiers + are more concise, which makes them easier to read when debugging macros, but + also means that two distinct identifiers can look the same (but have distinct + scopes). If the @racket[#:concise] option is omitted, the generated identifiers + may contain extra characters do help visually disambiguate similar identifiers + (those extra characters are obtained using @racket[generate-temporary]). + + @history[#:changed "1.1" + @list{The lexical context for the defined identifier + @racket[_new-name] is now taken from the format, instead of being + taken from the base @racket[name]. Previously, the lexical context + was taken from the base @racket[name], except when the simple format + did not contain any @racket["~a"], in which case it was taken from + the whole @racket[base+ellipses] (this was a bug, which is fixed now + that both cases use the lexical context of @racket[format]). The + same applies to the lexical context for @racket[_new-first]}]} + +@include-section{ids-untyped.scrbl} diff --git a/scribblings/in-untyped.scrbl b/scribblings/in-untyped.scrbl new file mode 100644 index 0000000..0f8b7a7 --- /dev/null +++ b/scribblings/in-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/in]] +@(def-orig typed [phc-toolkit/in]) +@title{Untyped versions of in} +@defmodule[phc-toolkit/untyped/in + #:use-sources + [(lib "phc-toolkit/in.rkt")]] + diff --git a/scribblings/in.scrbl b/scribblings/in.scrbl new file mode 100644 index 0000000..5207512 --- /dev/null +++ b/scribblings/in.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/in]] +@title{in} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/in + #:use-sources + [(lib "phc-toolkit/in.rkt")]] + +@include-section{in-untyped.scrbl} diff --git a/scribblings/list-lang.scrbl b/scribblings/list-lang.scrbl new file mode 100644 index 0000000..69fe5c6 --- /dev/null +++ b/scribblings/list-lang.scrbl @@ -0,0 +1,6 @@ +#lang scribble/manual +@require[racket/require + (for-label (only-meta-in 0 phc-toolkit/list-lang))] +@title{list-lang} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/list-lang] diff --git a/scribblings/list-untyped.scrbl b/scribblings/list-untyped.scrbl new file mode 100644 index 0000000..8874d16 --- /dev/null +++ b/scribblings/list-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/list]] +@(def-orig typed [phc-toolkit/list]) +@title{Untyped versions of list} +@defmodule[phc-toolkit/untyped/list + #:use-sources + [(submod (lib "phc-toolkit/list.rkt") untyped)]] + diff --git a/scribblings/list.scrbl b/scribblings/list.scrbl new file mode 100644 index 0000000..47b2641 --- /dev/null +++ b/scribblings/list.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/list]] +@title{list} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/list + #:use-sources + [(submod (lib "phc-toolkit/list.rkt") typed)]] + +@include-section{list-untyped.scrbl} diff --git a/scribblings/logn-id-untyped.scrbl b/scribblings/logn-id-untyped.scrbl new file mode 100644 index 0000000..3870e7d --- /dev/null +++ b/scribblings/logn-id-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/logn-id]] +@(def-orig typed [phc-toolkit/logn-id]) +@title{Untyped versions of logn-id} +@defmodule[phc-toolkit/untyped/logn-id + #:use-sources + [(submod (lib "phc-toolkit/logn-id.rkt") untyped)]] + diff --git a/scribblings/logn-id.scrbl b/scribblings/logn-id.scrbl new file mode 100644 index 0000000..e1c8c79 --- /dev/null +++ b/scribblings/logn-id.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/logn-id]] +@title{logn-id} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/logn-id + #:use-sources + [(submod (lib "phc-toolkit/logn-id.rkt") typed)]] + +@include-section{logn-id-untyped.scrbl} diff --git a/scribblings/meta-struct-untyped.scrbl b/scribblings/meta-struct-untyped.scrbl new file mode 100644 index 0000000..bedf9ec --- /dev/null +++ b/scribblings/meta-struct-untyped.scrbl @@ -0,0 +1,23 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/meta-struct]] +@(def-orig typed [phc-toolkit/meta-struct] + struct-predicate + struct-constructor + struct-accessor + struct-type-is-immutable? + struct-instance-is-immutable?) +@title{Untyped versions of the meta-struct typed macros} +@defmodule[phc-toolkit/untyped/meta-struct + #:link-target? #f + #:use-sources + [(submod (lib "phc-toolkit/meta-struct.rkt") untyped)]] + +@defidform[struct-predicate]{Untyped version of @|typed:struct-predicate|.} +@defidform[struct-constructor]{Untyped version of @|typed:struct-constructor|.} +@defidform[struct-accessor]{Untyped version of @|typed:struct-accessor|.} +@defidform[struct-type-is-immutable?]{ + Untyped version of @|typed:struct-type-is-immutable?|.} +@defidform[struct-instance-is-immutable?]{ + Untyped version of @|typed:struct-instance-is-immutable?|.} \ No newline at end of file diff --git a/scribblings/meta-struct.scrbl b/scribblings/meta-struct.scrbl new file mode 100644 index 0000000..c6861ff --- /dev/null +++ b/scribblings/meta-struct.scrbl @@ -0,0 +1,168 @@ +#lang scribble/manual +@require[@for-label[phc-toolkit/stx + (only-meta-in 0 phc-toolkit/meta-struct) + (only-meta-in 1 phc-toolkit/untyped/meta-struct) + racket/base + racket/struct-info]] + +@title{meta operations on structs} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@section{Typed macros and procedures} + +@defmodule[phc-toolkit/meta-struct + #:use-sources + [(submod (lib "phc-toolkit/meta-struct.rkt") typed)]] + +@defform[(struct-predicate s) + #:grammar [[s meta-struct?]]]{ + Expands to a predicate for the given @racket[struct], with the + type @racket[(-> any/c boolean? : s)].} + +@defform[(struct-constructor s) + #:grammar [[s meta-struct?]]]{ + This macro expands to the constructor function for the given @racket[struct], + with the type @racket[(-> _arg … s)] where each @racket[_arg] corresponds to an + argument expected by the @racket[struct]'s constructor.} + +@defform*[{(struct-accessor s i) + (struct-accessor s field)} + #:grammar [[s meta-struct?] + [i (expr/c exact-nonnegative-integer?)] + [field identifier?]]]{ + This macro expands to the @racket[i]-th accessor function for the given + @racket[struct], with the type @racket[(-> s _t)] where @racket[_t] is the + @racket[struct]'s @racket[_i]-th field's type. + + If the second argument is an identifier, then this macro concatenates the + identifiers @racket[s] and @racket[field] with a @racket[-] in between, and + expands to the resulting @racket[_s-field]. The lexical context of + @racket[_s-field] is the same as the lexical context of @racket[s]. In some + rare cases this might not resolve to the accessor for @racket[field] on + @racket[s]. Passing an @racket[exact-nonnegative-integer?] as the second + argument should be more reliable.} + +@defproc[#:kind "phase 1 procedure" + (struct-type-is-immutable? [st Struct-TypeTop]) + boolean?]{ + Returns @racket[#t] if the given struct type can be determined + to have only immutable fields. Returns @racket[#f] otherwise.} + +@defproc[(struct-instance-is-immutable? [v struct?]) + boolean?]{ + Returns @racket[#t] if @racket[v] can be determined to be an instance of an + immutable struct. Returns @racket[#f] otherwise. Note that when given an + instance of an opaque struct @racket[struct-instance-is-immutable?] cannot + access the struct info, and therefore returns @racket[#f].} + +@include-section{meta-struct-untyped.scrbl} + +@section{Untyped for-syntax utilities} + +@defmodule[phc-toolkit/untyped/meta-struct + #:use-sources + [(submod (lib "phc-toolkit/meta-struct.rkt") untyped)]] + +@defproc[(meta-struct? [v any/c]) boolean?]{ + Returns @racket[#t] if @racket[v] can be used by the + functions provided by this module, and @racket[#f] + otherwise. More precisely, @racket[v] must be an + @racket[identifier] whose @racket[syntax-local-value] is a + @racket[struct-info?]. + + @history[#:changed "1.0" "This function is provided at phase 1."]} + +@defstruct[meta-struct-info ([type-descriptor (or/c identifier? #f)] + [constructor (or/c identifier? #f)] + [predicate (or/c identifier? #f)] + [accessors (list*of identifier? + (or/c (list/c #f) null?))] + [mutators (list*of (or/c identifier? #f) + (or/c (list/c #f) null?))] + [super-type (or/c identifier? #f)])]{ + Encapsulates the result of @racket[extract-struct-info] in + a structure with named fields, instead of an obscure + six-element list. The precise contents of each field is + described in + @secref["structinfo" #:doc '(lib "scribblings/reference/reference.scrbl")]. + + @history[#:changed "1.0" "The identifiers are provided at phase 1."]} + +@defproc[(get-meta-struct-info [s meta-struct?] + [#:srcloc srcloc (or/c #f syntax?) #f]) + meta-struct-info?]{ + Returns the @racket[meta-struct-info] for the given + identifier. The optional @racket[#:srcloc] keyword argument + gives the source location for error messages in case the + given identifier is not a @racket[meta-struct?]. + + @history[#:changed "1.0" "This function is provided at phase 1."]} + +@defproc[(meta-struct-subtype? [sub meta-struct?] [super meta-struct?]) + boolean?]{ + Returns @racket[#t] if the @racket[struct] associated to + the identifier @racket[sub] is a subtype of the + @racket[struct] associated to the identifier + @racket[super], and @racket[#f] otherwise or if the current + inspector is not strong enough to know. + + @history[#:changed "1.0" "This function is provided at phase 1."]} + +@defproc[#:kind "phase 1 procedure" + (struct-type-id-is-immutable? [id identifier?]) + boolean?]{ + Returns @racket[#t] if the struct with the given @racket[id] can be determined + to have only immutable fields. Returns @racket[#f] otherwise.} + +@(require (for-syntax racket/base + racket/syntax + racket/struct + racket/vector)) + +@(define-for-syntax (strip-loc e) + (cond [(syntax? e) (datum->syntax e (strip-loc (syntax-e e)) #f)] + [(pair? e) (cons (strip-loc (car e)) (strip-loc (cdr e)))] + [(vector? e) (vector-map strip-loc e)] + [(box? e) (box (strip-loc (unbox e)))] + [(prefab-struct-key e) + => (λ (k) (apply make-prefab-struct + k + (strip-loc (struct->list e))))] + [else e])) + +@(define-syntax (shorthand stx) + (syntax-case stx () + [(_ base expresion-type) + (with-syntax ([loc (datum->syntax #'base #'base #f)] + [name (format-id #'base "meta-struct-~a" #'base)] + [accessor (format-id #'base "meta-struct-info-~a" #'base)] + [tmpl (format-id #'base "!struct-~a" #'base)]) + #`(deftogether + [(defproc (name [s meta-struct?] + [#:srcloc srcloc (or/c #f syntax?) #f]) + (expressionof + (→ s #,(strip-loc #'expresion-type)))) + (defform #:kind "template metafunction" + (tmpl #,(strip-loc #'s) #,(strip-loc #'maybe-srcloc)) + #:grammar ([s meta-struct?] + [maybe-srcloc (code:line) + #||# (code:line #:srcloc srcloc)]))] + @list{ + @;{} Shorthand for @racket[(accessor (get-meta-struct-info s))] + @;{} (with the optional @racket[#:srcloc] passed to + @;{} @racket[get-meta-struct-info]). The precise contents of the + @;{} returned value field is described in + @;{} @secref["structinfo" + #:doc '(lib "scribblings/reference/reference.scrbl")]. + @;{} + @;{} @history[#:changed "1.0" + "This function is provided at phase 1."]}))])) + +@(shorthand type-descriptor (or/c identifier? #f)) +@(shorthand constructor (or/c identifier? #f)) +@(shorthand predicate (or/c identifier? #f)) +@(shorthand accessors (list*of identifier? + (or/c (list/c #f) null?))) +@(shorthand mutators (list*of (or/c identifier? #f) + (or/c (list/c #f) null?))) +@(shorthand super-type (or/c identifier? #f)) diff --git a/scribblings/misc-untyped.scrbl b/scribblings/misc-untyped.scrbl new file mode 100644 index 0000000..aae081e --- /dev/null +++ b/scribblings/misc-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/misc]] +@(def-orig typed [phc-toolkit/misc]) +@title{Untyped versions of misc} +@defmodule[phc-toolkit/untyped/misc + #:use-sources + [(submod (lib "phc-toolkit/misc.rkt") untyped)]] + diff --git a/scribblings/misc.scrbl b/scribblings/misc.scrbl new file mode 100644 index 0000000..51f2fd3 --- /dev/null +++ b/scribblings/misc.scrbl @@ -0,0 +1,62 @@ +#lang scribble/manual + +@(require (for-label typed/racket/base + phc-toolkit/misc)) + +@(module racket-ids racket/base + (require scribble/manual + (for-label predicates)) + + (define or?-id (racket or?)) + (provide (all-defined-out))) + +@(require 'racket-ids) + +@title{Miscellaneous utilities} + +@section{Typed miscellaneous utilities} + +@defmodule[phc-toolkit/misc] + +@defproc[(hash-set** [h (HashTable K V)] [l* (Listof (Pairof K V))]) + (HashTable K V)]{ + Calls @racket[hash-set] on the hash @racket[h] for each + key-value pair contained in each list of @racket[l*].} + +@defform[(with-output-file [var filename] maybe-mode maybe-exists body …) + #:grammar ([var Identifier] + [filename (ExpressionOf String)] + [maybe-mode (code:line) (code:line #:mode mode)] + [maybe-exists (code:line) (code:line #:exists exists)])]{ + Executes body with @racket[var] bound to the + @racket[output-port?] obtained when opening the file. The + port is automatically closed at the end of the + @racket[body]. This is a macro version of + @racket[call-with-output-file].} + +@defproc[(or? [f (→ A Boolean)] ...) (→ A (U A #f))]{ + Typed version of @or?-id from the + @racketmodname[predicates] package, which returns the value + itself when all predicates are satisfied instead of just + returning @racket[#t].} + +@subsection{Untyped versions of miscellaneous utilities} + +@defmodule[phc-toolkit/untyped #:link-target? #f] + +@defproc[(hash-set** [h (HashTable K V)] [l* (Listof (Pairof K V))]) + (HashTable K V)]{ + Untyped version.} + +@defform[(with-output-file [var filename] maybe-mode maybe-exists body …) + #:grammar ([var Identifier] + [filename (ExpressionOf String)] + [maybe-mode (code:line) (code:line #:mode mode)] + [maybe-exists (code:line) (code:line #:exists exists)])]{ + Untyped version.} + + +@defproc[(or? [f (→ A Boolean)] ...) (→ A (U A #f))]{ + Untyped version.} + +@include-section{misc-untyped.scrbl} diff --git a/scribblings/multiassoc-syntax-untyped.scrbl b/scribblings/multiassoc-syntax-untyped.scrbl new file mode 100644 index 0000000..9ecc65f --- /dev/null +++ b/scribblings/multiassoc-syntax-untyped.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/multiassoc-syntax]] +@(def-orig typed [phc-toolkit/multiassoc-syntax]) +@title{Untyped versions of multiassoc-syntax} +@defmodule[phc-toolkit/untyped/multiassoc-syntax + #:use-sources + [(submod (lib "phc-toolkit/multiassoc-syntax.rkt") untyped)]] + +@include-section{tmpl-multiassoc-syntax-untyped.scrbl} \ No newline at end of file diff --git a/scribblings/multiassoc-syntax.scrbl b/scribblings/multiassoc-syntax.scrbl new file mode 100644 index 0000000..fe4cc3c --- /dev/null +++ b/scribblings/multiassoc-syntax.scrbl @@ -0,0 +1,12 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/multiassoc-syntax]] +@title{multiassoc-syntax} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/multiassoc-syntax + #:use-sources + [(submod (lib "phc-toolkit/multiassoc-syntax.rkt") typed)]] + +@include-section{tmpl-multiassoc-syntax.scrbl} +@include-section{multiassoc-syntax-untyped.scrbl} diff --git a/scribblings/not-implemented-yet-untyped.scrbl b/scribblings/not-implemented-yet-untyped.scrbl new file mode 100644 index 0000000..9886b73 --- /dev/null +++ b/scribblings/not-implemented-yet-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/not-implemented-yet]] +@(def-orig typed [phc-toolkit/not-implemented-yet]) +@title{Untyped versions of not-implemented-yet} +@defmodule[phc-toolkit/untyped/not-implemented-yet + #:use-sources + [(submod (lib "phc-toolkit/not-implemented-yet.rkt") untyped)]] + diff --git a/scribblings/not-implemented-yet.scrbl b/scribblings/not-implemented-yet.scrbl new file mode 100644 index 0000000..c8a5baa --- /dev/null +++ b/scribblings/not-implemented-yet.scrbl @@ -0,0 +1,49 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/not-implemented-yet]] +@title{not-implemented-yet} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/not-implemented-yet + #:use-sources + [(submod (lib "phc-toolkit/not-implemented-yet.rkt") typed)]] + +@defform[(? type expr ...)]{ + Can be used as a placeholder for an expression returning @racket[type]. This + form throws an error at run-time, but will allow the program to typecheck so + that the developer can focus on other parts without a myriad of type errors, + and can come back to implement the @racket[?] placeholders later. + + The @racket[expr ...] expressions are included within a @racket[lambda] + function, after the @racket[(error "Not implemented yet")], so Typed/Racket's + dead code detection will ignore most type errors within those expressions. + This makes @racket[?] useful as a joker to temporarily ignore type errors + within the expressions, while annotating them with the type they should + normally have once they are fixed.} + +@defform[(?* expr ...)]{ + + Can be used as a placeholder for an expression returning @racket[Nothing]. + This form throws an error at run-time, but will allow the program to typecheck + so that the developer can focus on other parts without a myriad of type + errors, and can come back to implement the expressions marked with @racket[?*] + later. + + The @racket[expr ...] expressions are included within a @racket[lambda] + function, after the @racket[(error "Not implemented yet")], so Typed/Racket's + dead code detection will ignore most type errors within those expressions. + This makes @racket[?*] useful as a joker to temporarily ignore type errors + within the expressions. @racket[?*] is also useful as a joker to allow the + whole @racket[(?* expr ...)] expression to be used as an argument to nearly + any function, as it has the type @racket[Nothing], i.e. "bottom", which is a + subtype of (nearly) all other types (no value has the type @racket[Nothing], + i.e. it is the return type of functions which never return, which is the case + here, since @racket[?*] always throws an error at run-time. + + Caveat: the @racket[Nothing] type can propagate (when Typed/Racket encounters + a function called with @racket[Nothing] as the type of one of its arguments, + it may mark the return value of that function as @racket[Nothing] too, since + the call may never happen). This means that other parts of the code may be + considered dead code, and type errors in these other parts may be ignored.} + +@include-section{not-implemented-yet-untyped.scrbl} diff --git a/scribblings/percent-untyped.scrbl b/scribblings/percent-untyped.scrbl new file mode 100644 index 0000000..5e29a05 --- /dev/null +++ b/scribblings/percent-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/percent]] +@(def-orig typed [phc-toolkit/percent]) +@title{Untyped versions of percent} +@defmodule[phc-toolkit/untyped/percent + #:use-sources + [(submod (lib "phc-toolkit/percent.rkt") untyped)]] + diff --git a/scribblings/percent.scrbl b/scribblings/percent.scrbl new file mode 100644 index 0000000..f6e22cc --- /dev/null +++ b/scribblings/percent.scrbl @@ -0,0 +1,70 @@ +#lang scribble/manual + +@(require (for-label typed/racket/base + phc-toolkit/percent)) + +@title{@racket[let-in] binding and destructuring form} + +@defmodule[phc-toolkit/percent] + +The forms in this module may possibly be moved to a separate +package, as part of the template library described in +@secref{template-lib} (for now the template library is not +implemented yet). + +@defform[#:literals (in = and) + (% parallel-binding … + maybe-in + body …) + #:grammar + [(parallel-binding (code:line binding and parallel-binding) + binding) + (binding (code:line pattern … = expr)) + (maybe-in (code:line) + in) + (expr expression)]]{ + Locally binds the variables in the @racket[pattern]s to the + @racket[expr]. Each binding clause should contain as many + @racket[pattern]s as @racket[expr] produces values. The + @racket[body …] forms are evaluated with the given + variables bound. + + The bindings are executed in sequence, as if bound with + @racket[let*], unless grouped using @racket[and], in which + case they are executed in parallel, as if bound with + @racket[let]. + + NOTE: TODO: for now bindings are run in sequence, and + parallel bindings have not been implemented yet.} + +@defidform[in]{ + This identifier is only valid in certain forms, like + @racket[(% x = 10 in (+ x x))]. It is an error to use it as + an expression otherwise.} + +@defform[#:literals (: :: …) + (define% (name pattern …) + body …) + #:grammar + [(pattern variable + [variable : type] + cons-pattern + list-pattern + vector-pattern) + (cons-pattern (pattern . pattern) + (pattern :: pattern)) + (list-pattern (pattern …) + (pattern … :: tail-pattern)) + (tail-pattern pattern) + (vector-pattern #(pattern …)) + (variable identifier)]]{ + Locally binds the variables in the @racket[pattern]s to the + @racket[expr]. Each binding clause should contain as many + @racket[pattern]s as @racket[expr] produces values. The + @racket[body …] forms are evaluated with the given + variables bound. + + The bindings are executed in parallel, as if bound with + @racket[let].} + +@include-section{percent-untyped.scrbl} diff --git a/scribblings/phc-toolkit.scrbl b/scribblings/phc-toolkit.scrbl new file mode 100644 index 0000000..db4b708 --- /dev/null +++ b/scribblings/phc-toolkit.scrbl @@ -0,0 +1,76 @@ +#lang scribble/manual +@require[@for-label[phc-toolkit + racket/base]] + +@title{phc-toolkit} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@defmodule[phc-toolkit] + +This library contains a small toolkit of utilities used by +the @url{https://github.com/jsmaniac/phc} project and other +helper libraries for that project. + +This library exports the following typed modules: + +@itemlist[ + @item{@racketmodname[phc-toolkit/stx]} + @item{@racketmodname[phc-toolkit/misc]} + @item{@racketmodname[phc-toolkit/percent]} + @item{@racketmodname[phc-toolkit/meta-struct]} + @item{…}] + +Untyped versions of the above modules are available under +@racketmodname[phc-toolkit/untyped], which also contains the +following additional untyped-only modules: +@itemlist[ + @item{@racketmodname[phc-toolkit/untyped/for-star-list-star]}] + +The @secref{template-lib} document discusses the +hypothetical features of a still-unwritten parser and +template library. The template part aims to be the pendant +of @racket[match] and @racket[syntax/parse], and the parser +part should unify @racket[match] and @racket[syntax/parse], +to enable parsing of syntax and regular data alike. This +library is not implemented yet, and will probably be moved +to a separate package when it is. + +@(local-table-of-contents) + +@include-section{aliases.scrbl} +@include-section{backtrace.scrbl} +@include-section{compat.scrbl} +@include-section{cond-let.scrbl} +@include-section{contract.scrbl} +@include-section{eval-get-values.scrbl} +@include-section{fixnum.scrbl} +@include-section{generate-indices.scrbl} +@include-section{ids.scrbl} +@include-section{in.scrbl} +@include-section{list-lang.scrbl} +@include-section{list.scrbl} +@include-section{logn-id.scrbl} +@include-section{misc.scrbl} +@include-section{multiassoc-syntax.scrbl} +@include-section{not-implemented-yet.scrbl} +@include-section{percent.scrbl} +@include-section{repeat-stx.scrbl} +@include-section{require-provide.scrbl} +@include-section{sequence.scrbl} +@include-section{set.scrbl} +@include-section{stx.scrbl} +@include-section{syntax-parse.scrbl} +@include-section{test-framework.scrbl} +@include-section{threading.scrbl} +@include-section{tmpl.scrbl} +@include-section{typed-rackunit.scrbl} +@include-section{typed-rackunit-extensions.scrbl} +@include-section{typed-untyped.scrbl} +@include-section{type-inference-helpers.scrbl} +@include-section{values.scrbl} +@include-section{untyped.scrbl} +@include-section{for-star-list-star.scrbl} +@include-section{meta-struct.scrbl} +@include-section{format-id-record-untyped.scrbl} + +@include-section{template.scrbl} diff --git a/scribblings/repeat-stx-untyped.scrbl b/scribblings/repeat-stx-untyped.scrbl new file mode 100644 index 0000000..8a45490 --- /dev/null +++ b/scribblings/repeat-stx-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/repeat-stx]] +@(def-orig typed [phc-toolkit/repeat-stx]) +@title{Untyped versions of repeat-stx} +@defmodule[phc-toolkit/untyped/repeat-stx + #:use-sources + [(submod (lib "phc-toolkit/repeat-stx.rkt") untyped)]] + diff --git a/scribblings/repeat-stx.scrbl b/scribblings/repeat-stx.scrbl new file mode 100644 index 0000000..86b7c9f --- /dev/null +++ b/scribblings/repeat-stx.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/repeat-stx]] +@title{repeat-stx} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/repeat-stx + #:use-sources + [(submod (lib "phc-toolkit/repeat-stx.rkt") typed)]] + +@include-section{repeat-stx-untyped.scrbl} diff --git a/scribblings/require-provide-untyped.scrbl b/scribblings/require-provide-untyped.scrbl new file mode 100644 index 0000000..a1123df --- /dev/null +++ b/scribblings/require-provide-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/require-provide]] +@(def-orig typed [phc-toolkit/require-provide]) +@title{Untyped versions of require-provide} +@defmodule[phc-toolkit/untyped/require-provide + #:use-sources + [(submod (lib "phc-toolkit/require-provide.rkt") untyped)]] + diff --git a/scribblings/require-provide.scrbl b/scribblings/require-provide.scrbl new file mode 100644 index 0000000..d62a0e9 --- /dev/null +++ b/scribblings/require-provide.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/require-provide]] +@title{require-provide} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/require-provide + #:use-sources + [(submod (lib "phc-toolkit/require-provide.rkt") typed)]] + +@include-section{require-provide-untyped.scrbl} diff --git a/scribblings/sequence-untyped.scrbl b/scribblings/sequence-untyped.scrbl new file mode 100644 index 0000000..4a8db74 --- /dev/null +++ b/scribblings/sequence-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/sequence]] +@(def-orig typed [phc-toolkit/sequence]) +@title{Untyped versions of sequence} +@defmodule[phc-toolkit/untyped/sequence + #:use-sources + [(submod (lib "phc-toolkit/sequence.rkt") untyped)]] + diff --git a/scribblings/sequence.scrbl b/scribblings/sequence.scrbl new file mode 100644 index 0000000..00eec2e --- /dev/null +++ b/scribblings/sequence.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/sequence]] +@title{sequence} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/sequence + #:use-sources + [(submod (lib "phc-toolkit/sequence.rkt") typed)]] + +@include-section{sequence-untyped.scrbl} diff --git a/scribblings/set-untyped.scrbl b/scribblings/set-untyped.scrbl new file mode 100644 index 0000000..bd163cc --- /dev/null +++ b/scribblings/set-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/set]] +@(def-orig typed [phc-toolkit/set]) +@title{Untyped versions of set} +@defmodule[phc-toolkit/untyped/set + #:use-sources + [(submod (lib "phc-toolkit/set.rkt") untyped)]] + diff --git a/scribblings/set.scrbl b/scribblings/set.scrbl new file mode 100644 index 0000000..267808c --- /dev/null +++ b/scribblings/set.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/set]] +@title{set} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/set + #:use-sources + [(submod (lib "phc-toolkit/set.rkt") typed)]] + +@include-section{set-untyped.scrbl} diff --git a/scribblings/stx-patching-srcloc.scrbl b/scribblings/stx-patching-srcloc.scrbl new file mode 100644 index 0000000..15a81c8 --- /dev/null +++ b/scribblings/stx-patching-srcloc.scrbl @@ -0,0 +1,84 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/stx]] + +@(def-orig typed [phc-toolkit/stx] + stx-assoc + identifier->string + identifier→string + quasisyntax/top-loc + syntax/top-loc + quasisyntax/whole-loc + syntax/whole-loc) + +@title{Patching source locations} + +@(declare-exporting phc-toolkit/stx + #:use-sources + [(lib "phc-toolkit/stx/fold.rkt")]) + +@defform[(quasisyntax/top-loc stx-expr quasitemplate)]{ + Like @racket[(quasisyntax/loc stx-expr quasitemplate)], but the source + location for all "top" parts of the resulting syntax object are updated, so + long as their source location is the same as the source location for the + topmost part of the @racket[quasitemplate]. + + In other words, this does a traversal of the syntax object and updates the + source location of the traversed parts, but the traversal does not go within a + part whose source file differs from that of the @racket[quasitemplate]. + + For example, in the following code, the source location of parts within + @racket[user-code] will not be updated (unless @racket[user-code] originates + from the same file as @racket[quasitemplate]), but the source location of all + other parts will be updated, including the @racket[begin] identifier and its + surrounding form (its surrounding "pair of parentheses"). In contrast, + @racket[quasisyntax/loc] would have updated only the topmost syntax object, + i.e. the outermost "pair of parentheses" of the @racket[let] form. + + @racketblock[(λ (stx) + (syntax-case stx () + [(_ . user-code) + (with-syntax ([bg #'(begin . user-code)]) + (quasisyntax/top-loc stx (let () bg)))]))]} + +@defform[(syntax/top-loc stx-expr quasitemplate)]{ + Like @racket[(syntax/loc stx-expr quasitemplate)], but the source location + for all "top" parts of the resulting syntax object are updated, like is done + by @racket[quasisyntax/top-loc].} + + +@defform[(quasisyntax/whole-loc stx-expr quasitemplate)]{ + + Like @racket[(quasisyntax/top-loc stx-expr quasitemplate)], but the source + location for all parts of the resulting syntax object are updated if they + belong to the same source file as the @racket[quasitemplate], not only the + "top" ones. + + In the following example, all parts of the syntax object which source file is + the same as the macro will be updated, including those within + @racket[user-code] (e.g. if the @racket[user-code] contains code generated by + other macros from the same file. + + @racketblock[(λ (stx) + (syntax-case stx () + [(_ . user-code) + (with-syntax ([bg #'(begin . user-code)]) + (quasisyntax/whole-loc stx (let () bg)))]))] + + This is usually not needed, as @racket[quasisyntax/top-loc] would have + updated the source location of @racket[1], @racket[2] and @racket[3] and their + surrounding syntax list (the "pair of parentheses" around them), since their + surrounding syntax list comes from the same file as the macro: + + @racketblock[(λ (stx) + (syntax-case stx () + [(_ . user-function) + (quasisyntax/top-loc stx + (user-function 1 2 3))]))]} + +@defform[(syntax/whole-loc stx-expr quasitemplate)]{ + Like @racket[(syntax/top-loc stx-expr quasitemplate)], but the source + location for all parts of the resulting syntax object are updated if they + belong to the same source file as the @racket[quasitemplate], not only the + "top" ones, like is done by @racket[quasisyntax/whole-loc].} diff --git a/scribblings/stx-untyped-only.scrbl b/scribblings/stx-untyped-only.scrbl new file mode 100644 index 0000000..55b2624 --- /dev/null +++ b/scribblings/stx-untyped-only.scrbl @@ -0,0 +1,44 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/stx]] + +@title{Transformers utilities} + +@(declare-exporting phc-toolkit/stx + #:use-sources + [(lib "phc-toolkit/untyped-only/stx.rkt")]) + +@defproc[(make-rest-transformer [tranformer-function (-> syntax? syntax?)]) + (-> syntax? syntax?)]{ + Returns a transformer function which applies @racket[tranformer-function] on + the @racket[stx-cdr] of its argument. It is a shorthand for: + + @racketblock[(λ (stx) + (syntax-case stx () + [(_ . rest) (f #'rest)]))] +} + +@defproc[(make-id+call-transformer [result syntax?]) + (-> syntax? syntax?)]{ + Returns a transformer function which returns: + @itemlist[ + @item{the given @racket[result], when it is called as an identifier macro} + @item{@racket[(result arg ...)] where the @racket[arg ...] are the macro's + arguments (except the macro identifier itself), when it is called as a + regular macro.}] + + It is a shorthand for: + + @RACKETBLOCK[(λ (stx) + (syntax-case stx () + [(_ . args) (quasisyntax/top-loc stx (#,result . args))] + [id (identifier? #'id) result]))] +} + +@defproc[(make-id+call-transformer-delayed [result (-> syntax?)]) + (-> syntax? syntax?)]{ + + Like @racket[make-id+call-transformer], but the result is wrapped in a + function which is evaluated only when the returned transformer function is + run. This is useful when the expression depends on some mutable context.} \ No newline at end of file diff --git a/scribblings/stx-untyped.scrbl b/scribblings/stx-untyped.scrbl new file mode 100644 index 0000000..47d4c8b --- /dev/null +++ b/scribblings/stx-untyped.scrbl @@ -0,0 +1,47 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/stx]] + +@(def-orig typed [phc-toolkit/stx] + stx-assoc + identifier->string + identifier→string + make-rest-transformer + make-id+call-transformer + quasisyntax/top-loc + syntax/top-loc + quasisyntax/whole-loc + syntax/whole-loc) + +@title{Untyped versions of syntax object manipulation utilities} + +@defmodule[phc-toolkit/untyped/stx + #:use-sources + [(submod (lib "phc-toolkit/stx.rkt") untyped) + (lib "phc-toolkit/stx/fold.rkt")]] + +@defidform[stx-assoc]{Untyped version of @|typed:stx-assoc|.} + +@defproc*[([(identifier->string [identifier Identifier]) String] + [(identifier→string [identifier Identifier]) String])]{ + Untyped version of @|typed:identifier->string| and @|typed:identifier→string|. +} + +@defidform[make-rest-transformer]{ + Untyped version of @|typed:make-rest-transformer|.} + +@defidform[make-id+call-transformer]{ + Untyped version of @|typed:make-id+call-transformer|.} + +@defidform[quasisyntax/top-loc]{ + Untyped version of @|typed:quasisyntax/top-loc|.} + +@defidform[syntax/top-loc]{ + Untyped version of @|typed:syntax/top-loc|.} + +@defidform[quasisyntax/whole-loc]{ + Untyped version of @|typed:quasisyntax/whole-loc|.} + +@defidform[syntax/whole-loc]{ + Untyped version of @|typed:syntax/whole-loc|.} diff --git a/scribblings/stx.scrbl b/scribblings/stx.scrbl new file mode 100644 index 0000000..c37ee2c --- /dev/null +++ b/scribblings/stx.scrbl @@ -0,0 +1,118 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/stx + phc-toolkit/syntax-parse + (subtract-in phc-toolkit/untyped + phc-toolkit/stx + phc-toolkit/syntax-parse) + racket/base + racket/contract]] + +@(def-orig orig [syntax/stx racket/base] + stx-car + stx-cdr + syntax-e) + +@title{Syntax object manipulation utilities} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@defmodule[phc-toolkit/stx + #:use-sources + [(submod (lib "phc-toolkit/stx.rkt") typed)]] + +@; TODO: fix the types +@defproc[(stx-car [v (or/c (syntax/c pair?) pair?)]) any/c]{ + Typed version of @orig:stx-car from @racketmodname[syntax/stx].} + +@defproc[(stx-cdr [v (or/c (syntax/c pair?) pair?)]) any/c]{ + Typed version of @orig:stx-cdr from @racketmodname[syntax/stx].} + +@defproc[(stx-e [v (or/c (syntax/c any/c) any/c)]) any/c]{ + Typed version of @orig:syntax-e which also accepts objects which are not + syntax (in which case the original object is returned).} + +@defproc[(stx-pair? [v Any]) Boolean]{ + A predicate which returns true for pairs and for syntax pairs alike. +} + +@defproc[(stx-car/c [car-c (→ Any Result)]) (→ Any (U #f Result))]{ + Returns a contract similar to the one returned by + @racket[(cons/c car-c any/c)], but which accepts both syntax pairs + (@racket[stx-pair?]) and pairs (@racket[pair?]), as long as their + @racket[stx-car] (@racket[car] respectively) is accepted by @racket[car-c].} + +@defproc[(stx-cdr/c [cdr-c (→ Any Result)]) (→ Any (U #f Result))]{ + Returns a contract similar to the one returned by + @racket[(cons/c any/c cdr-c)], but which accepts both syntax pairs + (@racket[stx-pair?]) and pairs (@racket[pair?]), as long as their + @racket[stx-cdr] (@racket[cdr] respectively) is accepted by @racket[cdr-c].} + +@defproc[(stx-e/c [e-c (→ Any Result)]) (→ Any (U #f Result))]{ + Equivalent to @racket[(or/c e-c (syntax/c e-c))]. + + Also equivalent to @racket[(λ (v) (e-c (stx-e v)))]. + + Returns a contract which accepts any value accepted by @racket[e-c]. The + contract also accepts any value @racket[_v] for which @racket[syntax?] returns + true and @racket[(syntax-e v)] is accepted by @racket[e-c].} + +@defform[#:kind "type" + (Stx-List? A)]{ + A polymorphic type which is defined as: + @racketblock[(U Null + (Pairof A (Stx-List? A)) + (Syntaxof Null) + (Syntaxof (Pairof A (Stx-List? A))))]} + +@defproc[(stx-list? [v Any]) Boolean]{ + A predicate for @racket[Stx-List?]. +} + +@defproc[(stx->list [l (Stx-List? A)]) (Listof A)]{ + Turns into a list any syntax list, which can be any proper sequence of syntax + pairs terminated by a syntax list or by @racket[#'()]. If the value @racket[l] + is already a regular non-syntax list, a copy of the list is returned (note + that this means that the returned list will most likely not be @racket[eq?] to + the original).} + +@defproc[(stx-list/c [l-c (→ Any Result)]) (→ Any (U #f Result))]{ + Equivalent to: + + @racketblock[ + (λ (v) + (and (stx-list? v) + (l-c (stx->list v))))] + + Returns a contract which accepts any list accepted by @racket[l-c]. The + contract also accepts any value @racket[_v] for which @racket[stx-list?] + returns true and @racket[(stx->list v)] is accepted by @racket[e-c].} + +@defproc[(stx-null? [v Any]) Boolean]{ + Returns @racket[#true] for the empty list (@racket[null]) and for any empty + syntax list (@racket[#'()]). Returns @racket[#false] for any other value.} + +@defproc*[([(stx-assoc + [id Identifier] + [alist (Syntaxof (Listof (Syntaxof (Pairof Identifier T))))]) + (U (Syntaxof (Pairof Identifier T)) #f)] + [(stx-assoc + [id Identifier] + [alist (Listof (Syntaxof (Pairof Identifier T)))]) + (U (Syntaxof (Pairof Identifier T)) #f)] + [(stx-assoc [id Identifier] + [alist (Listof (Pairof Identifier T))]) + (U (Pairof Identifier T) #f)])]{ + Like @racket[assoc], but operates on syntax association lists. +} + +@defproc*[([(identifier->string [identifier Identifier]) String] + [(identifier→string [identifier Identifier]) String])]{ + Equivalent to @racket[(symbol->string (syntax-e identifier))]. +} + +@include-section{stx-untyped-only.scrbl} + +@include-section{stx-patching-srcloc.scrbl} + +@include-section{stx-untyped.scrbl} diff --git a/scribblings/syntax-parse-pattern-expanders.scrbl b/scribblings/syntax-parse-pattern-expanders.scrbl new file mode 100644 index 0000000..48aa339 --- /dev/null +++ b/scribblings/syntax-parse-pattern-expanders.scrbl @@ -0,0 +1,87 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/syntax-parse + racket/base + syntax/parse]] + +@(def-orig orig [syntax/parse] + ~or + ~literal + ~parse + ~bind) + +@title{Pattern expanders} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@declare-exporting[phc-toolkit/syntax-parse + #:use-sources + [(submod (lib "phc-toolkit/syntax-parse.rkt") typed)]] + +@defform[#:kind "pattern expander" + (~either alt ...)]{ + Like @orig:~or, but with no special behaviour when present under ellipses. + The use case for this is that @racket[({~or {~and 1 x} {~and 2 x}} ...)] would + match any list of @racket[1]s and @racket[2]s in any order, but it complains + that the attribute is bound twice, since both alternatives within the + @racket[~or] are understood as separate patterns, not mutually-exclusive + choices. On the other hand @racket[({~or {~and 1 x} {~and 2 x}} ...)] still + matches @racket[(2 1 1 1 2 2 1)], and successfully binds all the elements to + @racket[x ...].} + +@defform[#:kind "pattern expander" + (~lit alt ...)]{ + Alias for @|orig:~literal|.} + +@defform[#:kind "pattern expander" + (~with pat val)]{ + Alias for @|orig:~parse|, can be used semantically when @racket[#:with] would + have been used in a syntax class definition.} + +@defform[#:kind "pattern expander" + (~attr attr-name val)]{ + Alias for @racket[(#,orig:~bind [attr-name val])], can be used semantically + when @racket[#:attr] would have been used in a syntax class definition.} + +@(define ttern + @seclink["stxparse-patterns" + #:doc '(lib "syntax/scribblings/syntax.scrbl")]{pattern}) + +@defform[#:kind "pattern expander" + (~optkw kw #,ttern ...) + #:contracts + [(kw keyword?)]]{ + A shorthand for: + + @racketblock[{~optional {~seq {~and _name kw} #,ttern ...}}] + + where @racket[_name] is derived from the keyword, so that + @racket[~optkw #:foo] binds the pattern variable @racket[foo].} + + +@defform[#:kind "pattern expander" + (~optkw… kw #,ttern ...) + #:contracts + [(kw keyword?)]]{ + A shorthand for: + + @racketblock[(~optional {~seq {~and _name kw} #,ttern ...} + #:name "the kw keyword")] + + where the occurrence of @racket["kw"] within the string is replaced by the + actual @racket[kw] keywords, and where the @racket[_name] is derived from the + keyword, so that @racket[~optkw #:foo] binds the pattern variable + @racket[foo], and uses the name @racket["the #:foo keyword"]. + + This form can only be used where an + @tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{ellipsis-head pattern} + is allowed.} + + +@defform[#:kind "pattern expander" + (~maybe #,ttern ...)]{ + A shorthand for: + + @racketblock[(~optional {~seq #,ttern ...})]} + + diff --git a/scribblings/syntax-parse-untyped.scrbl b/scribblings/syntax-parse-untyped.scrbl new file mode 100644 index 0000000..9f415b5 --- /dev/null +++ b/scribblings/syntax-parse-untyped.scrbl @@ -0,0 +1,22 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/syntax-parse]] + +@(def-orig orig [phc-toolkit/syntax-parse] + stx + define-syntax/case + define-syntax/parse) + +@title{Untyped versions of @racket[syntax-parse] helpers} + +@defmodule[phc-toolkit/untyped/syntax-parse + #:use-sources + [(submod (lib "phc-toolkit/syntax-parse.rkt") untyped)]] + +@defidform[stx]{ + Untyped version of @|orig:stx|. +} + +@defidform[define-syntax/case]{Untyped version of @|orig:define-syntax/case|.} +@defidform[define-syntax/parse]{Untyped version of @|orig:define-syntax/parse|.} \ No newline at end of file diff --git a/scribblings/syntax-parse.scrbl b/scribblings/syntax-parse.scrbl new file mode 100644 index 0000000..8bad15f --- /dev/null +++ b/scribblings/syntax-parse.scrbl @@ -0,0 +1,101 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/syntax-parse + racket/base + syntax/parse]] + +@title{@racket[syntax-parse] helpers} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@defmodule[phc-toolkit/syntax-parse + #:use-sources + [(submod (lib "phc-toolkit/syntax-parse.rkt") typed)]] + +@defidform[stx]{ + This identifier can only be used in the body of some forms, + like @racket[define-syntax]. It is an error to use it as an + expression elsewhere.} + +@defform[(define-syntax/case (name . args) (literal-id ...) . body)]{ + This form is roughly equivalent to: + + @racketblock[(define-syntax (name stx) + (syntax-case stx (literal-id ...) + [(_ . args) (let () . body)]))] + + Within @racket[body], the syntax parameter @racket[stx] can be used to refer to + the whole syntax given as an argument to @racket[name].} + + +@(define ntax-patterns (tech #:doc '(lib "syntax/scribblings/syntax.scrbl") + #:key "syntax pattern" + "syntax-patterns")) +@(define ttern-directive (tech #:doc '(lib "syntax/scribblings/syntax.scrbl") + #:key "pattern-directive" + "pattern-directive")) + +@(define tterns + @seclink["stx-patterns" + #:doc '(lib "scribblings/reference/reference.scrbl")]{patterns}) + +@(define ttern + @seclink["stx-patterns" + #:doc '(lib "scribblings/reference/reference.scrbl")]{pattern}) + +@defform[(define-syntax/parse (name . #,ntax-patterns) + #,ttern-directive ... . body)]{ + This form is roughly equivalent to: + + @racketblock[(define-syntax (name stx) + (syntax-parse stx + [(_ . #,ntax-patterns) #,ttern-directive ... . body]))] + + Within the @racket[#,ntax-patterns], the @racket[#,ttern-directive] and the + @racket[body], the syntax parameter @racket[stx] can be used to refer to the + whole syntax given as an argument to @racket[name].} + +@defform[(λ/syntax-parse (name . #,ntax-patterns) + #,ttern-directive ... . body)]{ + This form is roughly equivalent to: + + @racketblock[(λ (stx) + (syntax-parse stx + [(_ . #,ntax-patterns) #,ttern-directive ... . body]))] + + Within the @racket[#,ntax-patterns], the @racket[#,ttern-directive] and the + @racket[body], the syntax parameter @racket[stx] can be used to refer to the + whole syntax given as an argument to the function.} + +@defform[(define-for-syntax/case-args (name (pattern ...)) . body)]{ + This form is roughly equivalent to: + + @racketblock[(define-for-syntax (name _arg ...) + (with-syntax ([pattern _arg] ...) + . body))] + + where each @racket[_arg] is a fresh identifier.} + + +@defform[(λ/syntax-case #,tterns (literal ...) . body)]{ + This form is roughly equivalent to: + + @racketblock[(λ (stx) + (syntax-case stx (literal ...) + [(_ . #,tterns) ... . body]))] + + Within the @racket[#,tterns], and the @racket[body], the syntax parameter + @racket[stx] can be used to refer to the whole syntax given as an argument to + the function.} + +@defform[(define/case-args (name (#,ttern ...)) . body)]{ + This form is roughly equivalent to: + + @racketblock[(define (name _arg ...) + (with-syntax ([#,ttern _arg] ...) + . body))] + + where each @racket[_arg] is a fresh identifier.} + +@include-section{syntax-parse-pattern-expanders.scrbl} +@include-section{syntax-parse-untyped.scrbl} \ No newline at end of file diff --git a/scribblings/template.scrbl b/scribblings/template.scrbl new file mode 100644 index 0000000..e73f6e0 --- /dev/null +++ b/scribblings/template.scrbl @@ -0,0 +1,492 @@ +#lang scribble/manual + +@(require (for-label typed/racket/base + syntax/parse + ;"template.rkt" + )) + +@(define ellipses (racket ...)) + +@title[#:tag "template-lib"]{Versatile parser and template library} + +Keywords: grammar, parser, template. + +@defform[(parse expr [pattern body …] …)]{ + Analogous to @racket[syntax-parse], except it isn't + specialized for syntax, but rather works for arbitrary + s-expressions, including syntax ones (denoted by + @racket[#'(…)] in the pattern).} + +@defform[#:literals (: :: ... else struct) + (tmpl template) + #:grammar + [(template variable + [variable : type] ;; (ann variable type) + ;; cons-template + (template . template) + (template :: template) + + ;; list + (template**) + ;; list* + template**-dotted + + ;; vector + #(template**) + (vector . template**-dotted) + + ;; hash-template: template** must expand to a list of pairs. + (hash . template**-dotted) ;; TODO: how to distinguish + (hasheq . template**-dotted) ;; mutable and immutable? + (hasheqv . template**-dotted) + #hash([template . template]) + #hasheq([template . template]) + #hasheqv([template . template]) + + ;; struct-template + (struct-id template …) + (struct struct-id template …) + #s(prefab-id template …) + #s(template template …) ;; Only allowed in untyped racket + + ;; box + #&template + + ;; call-template + (~identifier args …) ;; calls (identifier args …) + (~ expr args …) ;; calls (expr args …) + + ;; unquote-template + ,expr + ,@(list expr) + ,@(list* expr) ;; must appear in last position. + + + ;; template-expander + template-expander-id + (template-expander-id args …) + + ;; maybe-template (should all be template expanders + ;; which means the system is extensible enough to express + ;; these special cases). + (?? alt-template …) + (?@ . template**-dotted) + (??@ . template**-dotted) + (?if condition template template) + (|@if| condition template template) + (if@ condition template template) + (|@cond| [condition template] …) + (|@cond| [condition template] … [else template]) + (cond@ condition template template) + + ;; like #,@(with-syntax ([meta-var #'template]) + ;; #'(template**)) + (~let ([meta-var+args template]) + . template**-dotted) + + (~sort key template ooo) + (~loc stxloc . template) + ;; Like (template . template), but discards the first and + ;; keeps just the second. If the first contains pattern + ;; variables which are repeated, this has the effect of + ;; repeating the second as many times as the first. Example: + ;; #'(vector (~each some-pattern-var '())) + ;; => (vector '() '() '() '() '()) + (~each template template) + + ;; escaped + (ddd escaped) + + ;; + + ;; literal + #t + #f + string + bytes + number + char + keyword + regexp + pregexp) + + (meta-var+args meta-var + (meta-var meta-arg …)) + + (tail-template template) + + ;; specialize mid-sequence in repetition (diagonal-matrix-style) + + (variable identifier) + + (template**-dotted (template* … . template) + template**) + (template** (code:line template* …) + (code:line template* … :: template) + (code:line template* … (~rest . template))) + (template* template + (code:line template ooo) + special-cased-template) + (special-cased-template (code:line template vardd) + (code:line template ddvar)) + ;; Where var is an iterated variable. + (vardd var.. ;; exclude the current iteration + var...) ;; include the current iteration + (ddvar ..var ;; exclude the current iteration + ...var) ;; include the current iteration + + (ooo #,ellipses ;; TODO: make it a hyperlink + ___ + ..k ;; k positive integer + __k ;; k positive integer + (code:line .. expr) ;; expr must return a positive integer + (code:line __ expr)) ;; expr must return a positive integer + (ddd #,ellipses) + ]]{ + TODO: implement the versatile template library. + @racket[...] + + TODO: support for typed/racket. + + TODO: optimization feature: would it be useful if the + expanded code could be optimized? For example, when looking + at the output of syntax-parse, the code is far from being + concise. + + The patterns for @racket[parse] should all have a way to + create a symmetric counterpart for @racket[tmpl], which + produces the original value. This symmetry is important + because it allows lens-like macros, which operate on only a + part of the data structure, leaving everything else + intact. + + @racket[??] works like @racket[??] from + @racket[syntax/parse/experimental/template], except it + allows any number of alternatives (including 0, to avoid + special-casing in macros). It is more or less equivalent to + @racket[(?? a (?? b (?? c …)))], following syntax/parse's + semantics. + + @racket[?@] has the same meaning as in syntax/parse. + + @racket[(??@ t* …)] is a shortcut for + @racket[(?? (?@ t* …))] + + For better compatibility with at-exp, @racket[|@if|] can be + written @racket[if@], and the same goes for + @racket[|@cond|] etc. + + TODO: what's the difference between @racket[~], + @racket[template-expander] and @racket[unquote]? + @racket[template-expander] runs at compile-time and should + treat its arguments as syntax. + + Concerning unquoting, unlike @racket[racket]'s default + behaviour in @RACKET[#'([x #,(y …)] …)], unquoting should + not break the nesting of ellipses. How should we express + voluntary variation of the level of nesting? @racket[~let] + already allows expanding part of the template at some level + and inserting it verbatim somewhere below, but it's not a + silver bullet. One case which comes to mind is when some of + the nested data should be mixed with less-nested data, for + example going from + @racket[([10 1 2 3] [100 4 5] [1000 6])] to + @racket[([10 20 30] [400 500] [6000])] should be relatively + easy to express. Maybe @racket[~let] with parameters can be + a suitable generalized solution: + @RACKET[({~let ([(addx v) #,(+ x v)]) [(addx y) …]} …)] + + The special-cased template syntax should allow special + treatment of the @racket[i]-th iteration in a doubly-nested + loop: matching @racket[x] on @racket[(1 2 3 4 5)], and + using the template @racket[(0 x.. ,(* x x) ..x 1) …] will + produce @racket[(1 1 1 1 1) + (0 4 1 1 1) + (0 0 9 1 1) + (0 0 0 16 1) + (0 0 0 0 24)]. The pattern before + @racket[x..] and the pattern after @racket[..x] can expand + to multiple items which will be spliced in by wrapping it + with @racket[?@].} + +@section{Ideas for implementation} + +@subsection{Extensibility (expanders)} + +Allow normal, inline-prefix, inline-postfix and inline-infix +expanders, which can bind using regular expressions. This +allows implementing exotic syntax like @racket[var..] +(postfix, operates on the pattern preceeding it), +@racket[..var] (postfix, operates on the pattern after it), +@racket[(… escaped-pattern)] (normal, operates on the +containing s-exp) + +@subsection{Customization} + +For things that are likely to be customized by the user in +the whole file scope, define a grammar/custom module, used +as follows: + +@racketblock[(require grammar/custom) + (grammar/custom option …)] + +The @racket[grammar/custom] macro expands to +@racket[(require grammar/core)] followed by a bunch of +@racket[define-syntax] which wrap the core macros, providing +them the custom options: + +@racketblock[(require grammar/core) + (define-syntax-rule (parse . rest) + (parse/core #:global-options (option …) . rest)) + (define-syntax-rule (tmpl . rest) + (parse/core #:global-options (option …) . rest))] + +This can also be used to rename the @racket[parse] and +@racket[tmpl] macros, if desired (for example, +@racket[tmpl] could be renamed to @racket[quasisyntax], or +something similar). + +Otherwise, @racket[grammar/custom] could just @racket[set!] +some for-syntax variable which stores the options. A second +boolean for-syntax variable could be used to check if +@racket[grammar/custom] was called twice, and throw an error +in that case. + +Or maybe we should just use units? Can they be customized in +a similar way? + +The idea is to avoid having to wrap the whole file in a +@racket[(parameterize …)], and be able to easily +@racket[provide] a customized variation of this library: + +@racketblock[(provide (customized-out grammar/custom))] + +@subsection{Unsorted ideas} + +@subsubsection{Global pattern constraints} + +For patterns, have global constraints: @racket[(~global-or id)] binds +@racket[id] to true if the enclosing pattern was matched at least once, and +false otherwise. Multiple occurrences of the same @racket[(~global-or id)] make +the @racket[id] true if any of the containing clauses was matched at least +once. + +Inside a @racket[{~no-order}], it should be possible to impose some partial +order constraints, so that we can say: + +@racketblock[ + {~no-order + {~optional pat-a} + {~optional pat-b} + pat-c + {~optional {~constrain pat-d {~after pat-a}}}}] + +The above code means that @racket[pat-a], @racket[pat-b] and @racket[pat-d] are +optional (but not @racket[pat-c]), the four patterns can appear in any order, +but if @racket[pat-a] and @racket[pat-d] are both present, then @racket[pat-d] +must appear after @racket[pat-a]. + +Scopes: the global constraints apply within a scope. By default, there is an +implicit top-level scope, and some forms might implicitly introduce a catch-all +scope unless otherwise specified, like the implicit @racket[~demimit-cut] for +@racket[define-syntax-class] from @racket[syntax/parse]. There could be two +kinds of scopes: unhygienic catch-all scopes which scope all "global" +constraints within, and naming scopes, which explicitly say which identifiers +they scope. + +@racketblock[ + {~scope {a} + {~vector + {~scope {b} {~no-order {~once a} {~optional b}}} + {~scope {b} {~no-order {~once a} {~optional b}}}}}] + +The code above matches against a vector of two @racket[~no-order] lists. The +@racket[a] pattern must appear exactly once, either in the first list or in the +second, but not in both. On the other hand, the @racket[b] pattern may appear +zero or one time in the first list, zero or one time in the second list, and may +appear in both since its constraint is scoped for each list. Although it is less +clear, the following code is semantically identical: + +@racketblock[ + {~scope {a b} + {~vector + {~no-order {~once a} {~optional b}} + {~scope {b} {~no-order {~once a} {~optional b}}}}}] + +Since the @racket[b] in the @racket{~no-order} is bound to the enclosing +@racket[{~scope {b} …}], it does not interact in any way with the outer scope. +The @racket[~optional] constraint on the @racket[b] in the first +@racket[~no-order] therefore does not interact withe the @racket[~optional] +constraint in the second @racket[~no-order]. + +@subsubsection{Generalization of pattern/template kinds} + +Nearly all patterns and templates should work equally well for regular lists and +syntax objects. It should be possible and easy enough to create new "kinds" of +data, which modify how patterns and templates work all the way through the +pattern or template tree, until it switches to a new kind. As an example, the +following pattern starts as a normal s-expr pattern, and switches to syntax in +two nodes: + +@racketblock[ + {~s-expr 1 2 (buckle {~optional my} shoe) + 3 4 {~syntax (knock {~optional at the} door)} + 5 6 (pick {~optional-wrap (up _) (sticks)}) + 7 8 {~syntax (lay {~optional-wrap (them _) (straight)})}}] + +That pattern should match the following value: + +@racketblock[ + `(1 2 (buckle shoe) + 3 4 ,#'(knock door) + 5 6 (pick (up (sticks))) + 7 8 ,#'(lay (them (straight))))] + +The @racket[~syntax] indicates that the whole subtree should start matching (or +producing) syntax objects, instead of regular s-expressions. It is worht noting +that syntax objects have extra information (source location, syntax properties) +that regular s-expressions lack. One way of implementing this would be to make +the pattern directives operate on "enhanced" s-expressions. Enhanced +s-expressions are s-expressions with arbitrary kind-specific data attached to +them. The @racket[~s-expr] simply translates s-expressions into enhanced +s-expressions with an empty data attached, while @racket[~syntax] is a sort of +pre-processor which turns syntax objects into enhanced s-expressions with source +location and syntax properties attached. These "kind" pre-processors run before +the normal pattern directives are applied. Some kind-specific pattern directives +can access those properties (if they are used in within the scope of the +appropriate @racket[~kind]), so that a @racket[(~loc srcloc . pattern)] matches +@racket[pattern] and saves its source location into the variable +@racket[srcloc]. + +Kinds should also be able to alter how the pattern variables are bound: +@racket[~s-expr] simply binds (in patterns) and uses (in templates) normal +Racket variables. On the other hand, @racket[~syntax] binds and uses syntax +pattern variables, so that the bound variables are used as @racket[#'var] +instead of @racket[var]. + +Different pattern and template forms can specify a default kind (possibly by +simply wrapping their pattern or tempalte with the appropriate @racket[~kind]). +For example, a @racket[define/match] form would use @racket[~s-expr] by default, +whereas a @racket[define-syntax/match] would use @racket[~syntax]. The same +would apply for re-implementations of Racket's @racket[match] and +@racket[syntax-parse]. + +Do the "kinds" form some sort of monad? TODO: Think about this, and try to see +if there are some monads which can be translated to pattern/template kinds +usefully. + +@subsubsection{Lenses} + +It should be possible to describe lenses using the patterns: you can work on +the focused part of the match, possibly access (read-only) other parts, and +return a new value. What should happen when the focused part is under an +ellipsis and has more than one match ? Implicitly execute the code n times, like +a sort of @racket[for/list]? + +@subsubsection{Backtracking} + +Since the parser may need to backtrack, we need to expose the backtracking +mechanism to the user in some way, so that the user can: +@itemlist[ + @item{Cut the current branch} + @item{Perform some side-effects and undo them when backtracking (dangerous)} + @item{Record a side-effectful lambda which is executed when the match succeeds + or when the current branch is @racket[~commit]ted.} + @item{Querry information about the previously failed branches} + @item{Maybe affect the order in which non-deterministic branches are taken. + This feature would mainly be used by optimizers. + + As a toy "just because we can" example, the backtracking mechanism should be + configurable enough that some CSP algorithm like AC2003 can be expressed by + the user, turning the pattern library into a CSP solver (where the CSP problem + is expressed as a pattern over an empty object). Another toy "just because we + can" example would be a datalog implementation built upon this library, where + the deduction rules are expressed as patterns. + + The goal is that the parser's backtracking mechanism should be modular enough + to allow us to implement a dead-simple unoptimized backtracker, and allow + optimizers to be written as plug-ins. For example, an optimiazer could + statically detect branches that can be cut due to a prior failure (e.g. if the + two-element-list pattern @racket[(foo:id bar:number)] failed because the first + element was not an @racket[identifier?], there's no point in trying + @racket[(baz:id quux:string fuzz:number)] on the same term. + + Extensive configurability of the backtracking mechanism and optimization + features may interact badly with partial application and partial compilation, + see below. Think it through before giving too much or too little expressivity + to the user.}] + +@subsubsection{Partial application} + +It should be possible to give a partial input with holes to a pattern or +template form, and, for optimization purposes, request that the pattern or +template processes the input as much as it can (for the parser, it would +potentially open a bounded number of backtracking branches, ready to switch to +the next one if one fails), leaving an efficient "continuation". + +@subsubsection{Partial compilation} + +One of the drawbacks of @racketmodname[syntax/parse] is that compiling a +@racket[syntax-parse] form takes some non-negligible time. This means that if a +macro generates another macro, and the generated macro code uses syntax-parse, +each call to the "generator" macro will be expensive. A complex macro generating +syntax which contains hundreds of uses of syntax-case will be reasonnably fast. +The same code using syntax-parse will be much slower. Since the generated uses +of @racket[syntax-parse] will all have the same "shape" with a few identifiers +etc. changing, it would be nice to be able to partially pre-expand a use of +@racket[syntax-parse], leaving only the "holes" to be expanded. With a bottom-up +expansion mechanism there's not much to do, so we have to try hard to make the +pattern / template expander top-down as much as possible, and/or use a lazy +language (for which most things can be evaluated, leaving a continuation for the +few things that actually depend on the holes). + +Although partial compilation sounds like a very interesting academic project, +it might be too difficult to get something useful out of it in practice. An +alternative, which would procude the sought performance benefits for macros +generating code which uses the pattern/template library, would be to make as +many of the concepts first-class, so that they can easily be supplied as a +parameter. Note that firs-class in this case does not necessarily mean "run-time +first-class", but possibly "compile-time first-class": we only need to be able +to pre-declare parametric templates, then use them in the code generated by a +macro. As long as the parametric templates support a form of "separate +compilation" and optimization, filling in the parameters can be handled by a +fast macro. + +Some of the optimization plug-ins may however rely on a closed-world assumption +(i.e. they want to have the whole, final pattern or template, in order to +optimize it). If such an optimization plug-in is used, we may have to fall back +to the idea of using partial compilation, or simply accept that macros which +generate such code will take a while to expand. + +@subsubsection{QuickCheck test generation} + +It should be possible to generate random data that matches (and does not match, +too, that's a distinct problem) a pattern (unless there's a user-provided +predicate that is opaque to the library, in which case we can just ignore it and +generate instances at random, hoping that some will match and some won't). + +Combined with the fact that pattern directives should be reversible into +template directives, and vica versa, it means that each directive should also +express its set of accepted values in terms of its contents. Of course, we don't +expect to be able to uniformly sample random instances, nor do we expect to be +able to support in a useful way complex patterns with lots of opaque predicates. + +@subsubsection{Error messages} + +@racketmodname[syntax/parse] generates good error messages, but it does not +work as well when the patterns become complex. Think this through, so that the +annotation burden is minimal, and so that users don't have to think too hard +about where to put a @racket[~describe] (I frequently had the problem with +@racket[syntax/parse] where I wrote a @racket[~describe], but it wasn't taken +into account. + +@subsection{Things to look at} + +@itemlist[ + @item{@racket[math/arry], for @racket[::] and array + broadcasting.} + @item{Quasipatterns in @racket[match].} + @item{The @racket[lens] library} + @item{@url{https://github.com/racket/racket/issues/1304} + non-linear matching (with repeated binding variables, for + example, that should be eq? or equal?)}] diff --git a/scribblings/test-framework-untyped.scrbl b/scribblings/test-framework-untyped.scrbl new file mode 100644 index 0000000..10db0b2 --- /dev/null +++ b/scribblings/test-framework-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/test-framework]] +@(def-orig typed [phc-toolkit/test-framework]) +@title{Untyped versions of test-framework} +@defmodule[phc-toolkit/untyped/test-framework + #:use-sources + [(submod (lib "phc-toolkit/test-framework.rkt") untyped)]] + diff --git a/scribblings/test-framework.scrbl b/scribblings/test-framework.scrbl new file mode 100644 index 0000000..1439f77 --- /dev/null +++ b/scribblings/test-framework.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/test-framework]] +@title{test-framework} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/test-framework + #:use-sources + [(submod (lib "phc-toolkit/test-framework.rkt") typed)]] + +@include-section{test-framework-untyped.scrbl} diff --git a/scribblings/threading-untyped.scrbl b/scribblings/threading-untyped.scrbl new file mode 100644 index 0000000..77265fe --- /dev/null +++ b/scribblings/threading-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/threading]] +@(def-orig typed [phc-toolkit/threading]) +@title{Untyped versions of threading} +@defmodule[phc-toolkit/untyped/threading + #:use-sources + [(submod (lib "phc-toolkit/threading.rkt") untyped)]] + diff --git a/scribblings/threading.scrbl b/scribblings/threading.scrbl new file mode 100644 index 0000000..0a043f8 --- /dev/null +++ b/scribblings/threading.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/threading]] +@title{threading} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/threading + #:use-sources + [(submod (lib "phc-toolkit/threading.rkt") typed)]] + +@include-section{threading-untyped.scrbl} diff --git a/scribblings/tmpl-multiassoc-syntax-untyped.scrbl b/scribblings/tmpl-multiassoc-syntax-untyped.scrbl new file mode 100644 index 0000000..b6f1328 --- /dev/null +++ b/scribblings/tmpl-multiassoc-syntax-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/tmpl-multiassoc-syntax]] +@(def-orig typed [phc-toolkit/tmpl-multiassoc-syntax]) +@title{Untyped versions of tmpl-multiassoc-syntax} +@defmodule[phc-toolkit/untyped/tmpl-multiassoc-syntax + #:use-sources + [(submod (lib "phc-toolkit/tmpl-multiassoc-syntax.rkt") untyped)]] + diff --git a/scribblings/tmpl-multiassoc-syntax.scrbl b/scribblings/tmpl-multiassoc-syntax.scrbl new file mode 100644 index 0000000..05d6c60 --- /dev/null +++ b/scribblings/tmpl-multiassoc-syntax.scrbl @@ -0,0 +1,28 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/tmpl-multiassoc-syntax]] +@title{Template metafunction for @racket[multiassoc-syntax]} +@defmodule[phc-toolkit/tmpl-multiassoc-syntax + #:use-sources + [(submod (lib "phc-toolkit/tmpl-multiassoc-syntax.rkt") + typed + m-tmpl-cdr-assoc-syntax)]] + +@deftogether[ + [@defform[#:kind "template metafunction" + (tmpl-cdr-assoc-syntax maybe-default query [k . v] …) + #:grammar + [(maybe-default (code:line) + (code:line #:default default))]] + @defform[#:kind "template metafunction" + (!cdr-assoc maybe-default query [k . v] …) + #:grammar + [(maybe-default (code:line) + (code:line #:default default))]]]]{ + + This template metafunction returns the first @racket[v] whose @racket[k] is + @racket[free-identifier=?] to the given @racket[query]. If no such @racket[k] + exists, then @racket[default] is returned if specified, and otherwise an error + is raised while expanding the template.} + diff --git a/scribblings/tmpl-untyped.scrbl b/scribblings/tmpl-untyped.scrbl new file mode 100644 index 0000000..77d1954 --- /dev/null +++ b/scribblings/tmpl-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/tmpl]] +@(def-orig typed [phc-toolkit/tmpl]) +@title{Untyped versions of tmpl} +@defmodule[phc-toolkit/untyped/tmpl + #:use-sources + [(submod (lib "phc-toolkit/tmpl.rkt") untyped)]] + diff --git a/scribblings/tmpl.scrbl b/scribblings/tmpl.scrbl new file mode 100644 index 0000000..9c038cb --- /dev/null +++ b/scribblings/tmpl.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/tmpl]] +@title{tmpl} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/tmpl + #:use-sources + [(submod (lib "phc-toolkit/tmpl.rkt") typed)]] + +@include-section{tmpl-untyped.scrbl} diff --git a/scribblings/type-inference-helpers-untyped.scrbl b/scribblings/type-inference-helpers-untyped.scrbl new file mode 100644 index 0000000..179da2a --- /dev/null +++ b/scribblings/type-inference-helpers-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/type-inference-helpers]] +@(def-orig typed [phc-toolkit/type-inference-helpers]) +@title{Untyped versions of type-inference-helpers} +@defmodule[phc-toolkit/untyped/type-inference-helpers + #:use-sources + [(submod (lib "phc-toolkit/type-inference-helpers.rkt") untyped)]] + diff --git a/scribblings/type-inference-helpers.scrbl b/scribblings/type-inference-helpers.scrbl new file mode 100644 index 0000000..04a375a --- /dev/null +++ b/scribblings/type-inference-helpers.scrbl @@ -0,0 +1,16 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/type-inference-helpers]] +@title{type-inference-helpers} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/type-inference-helpers + #:use-sources + [(submod (lib "phc-toolkit/type-inference-helpers.rkt") typed)]] + +@defform[#:kind "type expander" + (maybe-apply-type τ arg ...)]{ + Expands to @racket[τ] if there are no arguments, and to @racket[(τ arg ...)] + if there is at least one argument. } + +@include-section{type-inference-helpers-untyped.scrbl} diff --git a/scribblings/typed-rackunit-extensions-untyped.scrbl b/scribblings/typed-rackunit-extensions-untyped.scrbl new file mode 100644 index 0000000..a33a73a --- /dev/null +++ b/scribblings/typed-rackunit-extensions-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/typed-rackunit-extensions]] +@(def-orig typed [phc-toolkit/typed-rackunit-extensions]) +@title{Untyped versions of typed-rackunit-extensions} +@defmodule[phc-toolkit/untyped/typed-rackunit-extensions + #:use-sources + [(submod (lib "phc-toolkit/typed-rackunit-extensions.rkt") untyped)]] + diff --git a/scribblings/typed-rackunit-extensions.scrbl b/scribblings/typed-rackunit-extensions.scrbl new file mode 100644 index 0000000..128927c --- /dev/null +++ b/scribblings/typed-rackunit-extensions.scrbl @@ -0,0 +1,77 @@ +#lang scribble/manual +@require[scribble-math + "utils.rkt" + @for-label[phc-toolkit/typed-rackunit-extensions]] +@title{Extensions for @racketmodname[typed/rackunit]} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@defmodule[phc-toolkit/typed-rackunit-extensions + #:use-sources + [(submod (lib "phc-toolkit/typed-rackunit-extensions.rkt") typed)]] + +@defform[#:literals (:) + (check-ann value type) + #:grammar [(value (ExpressionOf type)) + (type Type)]]{ + Verifies at compile-time that the given value is of the + given type. The file will not compile if this check fails. + + TODO: do the check at run-time, like @racket[check-tc].} + +@defform[(check-tc . body)]{ + Verifies at run-time that the statments in @racket[body] + typecheck without any error. + + TODO: fix possible problems with source location when the + test fails.} + +@defform[(check-not-tc . body)]{ + Verifies at run-time that the statments in @racket[body] + contain a type error. This can be used to check that the + types provided by a library or generated by a macro are + strong enough, by verifying that type errors that should be + caught are caught. + + TODO: fix possible problems with source location when the + test fails.} + +@defproc[(check-equal?-classes [class (∀ (A) (Pairof String (Listof A)))] ...) + Void]{ + Verivies that the given elements form equality classes as + indicated. + + The @racket[car] of each class indicates its name, and the + @racket[rest] is a list of element which belong to that + class. All elements of the same class should have the same + type @racket[Aᵢ], but elements of two different classes can + have different types @racket[Aᵢ] and @racket[Aⱼ]. + + This function checks that all elements of the same class + are @racket[equal?], and that any two elements of two + distinct classes are different. It also checks that + elements are equal to themeselves, and checks equalities + and inequalities in both directions, i.e. + @racket[(and (equal? a b) (equal? b a))] for equalities, + and @racket[(and (not (equal? a b)) (not (equal? b a)))] + for inequalities. + + Be aware that this function has @${O(n²)} time complexity, + with @${n} being the total number of elements in all + classes.} + +@defform[#:literals (:) + (check-equal?-classes: [maybe-nameᵢ maybe-typeᵢ elementᵢⱼ ...] ...) + #:grammar [(maybe-nameᵢ (code:line) + (code:line #:name String)) + (maybe-typeᵢ (code:line) + (code:line : tᵢ)) + (tᵢ Type) + (elementᵢⱼ (ExpressionOf tᵢ or Any))]]{ + Macro form of @racket[check-equal?-classes]. It is + equivalent to + @racket[(check-equal?-classes + (list nameᵢ elementᵢ ...) ...)], but also checks + that each @racket[elementᵢⱼ] is of the corresponding + @racket[tᵢ] type, if specified.} + +@include-section{typed-rackunit-extensions-untyped.scrbl} diff --git a/scribblings/typed-rackunit-untyped.scrbl b/scribblings/typed-rackunit-untyped.scrbl new file mode 100644 index 0000000..7100b64 --- /dev/null +++ b/scribblings/typed-rackunit-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/typed-rackunit]] +@(def-orig typed [phc-toolkit/typed-rackunit]) +@title{Untyped versions of typed-rackunit} +@defmodule[phc-toolkit/untyped/typed-rackunit + #:use-sources + [(lib "phc-toolkit/typed-rackunit.rkt")]] + diff --git a/scribblings/typed-rackunit.scrbl b/scribblings/typed-rackunit.scrbl new file mode 100644 index 0000000..4dfc598 --- /dev/null +++ b/scribblings/typed-rackunit.scrbl @@ -0,0 +1,106 @@ +#lang scribble/manual +@require["utils.rkt" + @for-label[phc-toolkit/typed-rackunit + racket/base + racket/list + (only-in racket compose ...) + racket/match + syntax/parse]] + +@(def-orig orig [rackunit] + check-equal? + check-not-equal? + check-true + check-exn + check-not-exn) + +@(def-orig tr [typed/rackunit] + check-equal? + check-not-equal? + check-true + check-exn + check-not-exn) + +@title{Utilities and patches for @racketmodname[typed/rackunit]} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@defmodule[phc-toolkit/typed-rackunit] + +@; TODO: add the message parameter when it is implemented +@defform[#:literals (:) + (check-equal?: actual maybe-type expected) + #:grammar [(actual (ExpressionOf Any)) + (expected (ExpressionOf Any)) + (maybe-type (code:line) + (code:line : type)) + (type Type)]]{ + Typed macro which behaves like the @orig:check-equal? function. The official + typed version @tr:check-equal? from @racketmodname[typed/rackunit] has some + issues with source location for failed tests, and with higher-order values + (e.g. syntax) passed as @racket[Any]. This alternate implementation fixes these + issues. + + This implementation is compatible with the use of other + functions from @racketmodname[typed/rackunit]. +} + +@defform[#:literals (:) + (check-not-equal?: actual maybe-type expected) + #:grammar [(actual (ExpressionOf Any)) + (expected (ExpressionOf Any)) + (maybe-type (code:line) + (code:line : type)) + (type Type)]]{ + Typed macro which behaves like the @orig:check-not-equal? function. The + official typed version @tr:check-not-equal? from + @racketmodname[typed/rackunit] has some issues with source location for failed + tests, and with higher-order values (e.g. syntax) passed as @racket[Any]. This + alternate implementation fixes these issues. + + This implementation is compatible with the use of other + functions from @racketmodname[typed/rackunit]. +} + +@defform[#:literals (:) + (check-true: actual) + #:grammar [(actual (ExpressionOf Any))]]{ + Typed macro which behaves like the @orig:check-true function. The official + typed version @tr:check-true from @racketmodname[typed/rackunit] has some + issues with source location for failed tests, and possibly with higher-order + values (e.g. syntax) passed as @racket[Any]. This alternate implementation + fixes these issues. + + This implementation is compatible with the use of other + functions from @racketmodname[typed/rackunit].} + +@defform[#:literals (:) + (check-exn: exn-predicate-or-regexp thunk maybe-message) + #:grammar [(exn-predicate-or-regexp + (ExpressionOf (U Regexp (→ Any Any)))) + (thunk (→ Any)) + (maybe-message (code:line) + (code:line (ExpressionOf String)))]]{ + Typed macro which behaves like the @orig:check-exn function. The official + typed version @tr:check-exn from @racketmodname[typed/rackunit] has some + issues with source location for failed tests, and possibly with higher-order + values (e.g. syntax) passed as @racket[Any]. This alternate implementation + fixes these issues. + + This implementation is compatible with the use of other + functions from @racketmodname[typed/rackunit].} + +@defform[#:literals (:) + (check-not-exn: thunk maybe-message) + #:grammar [(thunk (→ Any)) + (maybe-message (code:line) + (code:line (ExpressionOf String)))]]{ + Typed macro which behaves like the @orig:check-not-exn function. The official + typed version @tr:check-not-exn from @racketmodname[typed/rackunit] has some + issues with source location for failed tests, and possibly with higher-order + values (e.g. syntax) passed as @racket[Any]. This alternate implementation + fixes these issues. + + This implementation is compatible with the use of other + functions from @racketmodname[typed/rackunit].} + +@include-section{typed-rackunit-untyped.scrbl} diff --git a/scribblings/typed-untyped-untyped.scrbl b/scribblings/typed-untyped-untyped.scrbl new file mode 100644 index 0000000..33c8a9c --- /dev/null +++ b/scribblings/typed-untyped-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/typed-untyped]] +@(def-orig typed [phc-toolkit/typed-untyped]) +@title{Untyped versions of typed-untyped} +@defmodule[phc-toolkit/untyped/typed-untyped + #:use-sources + [(lib "phc-toolkit/typed-untyped.rkt")]] + diff --git a/scribblings/typed-untyped.scrbl b/scribblings/typed-untyped.scrbl new file mode 100644 index 0000000..53a80c4 --- /dev/null +++ b/scribblings/typed-untyped.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/typed-untyped]] +@title{typed-untyped} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/typed-untyped + #:use-sources + [(lib "phc-toolkit/typed-untyped.rkt")]] + +@include-section{typed-untyped-untyped.scrbl} diff --git a/scribblings/untyped.scrbl b/scribblings/untyped.scrbl new file mode 100644 index 0000000..0a6ede3 --- /dev/null +++ b/scribblings/untyped.scrbl @@ -0,0 +1,62 @@ +#lang scribble/manual +@require[@for-label[phc-toolkit/stx + racket/base]] + +@title{Untyped versions of the modules} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} + +@defmodule[phc-toolkit/untyped] + +The module @racketmodname[phc-toolkit/untyped] and the +modules below it (@racketmodname[phc-toolkit/untyped/stx] +@etc) provide the same bindings as +@racketmodname[phc-toolkit], but those functions and macros +are declared in an untyped context. This means that no check +is performed on the arguments (contracts have not been added +yet to the definitions in this library). This untyped +version of the library exists mainly so that macros defined +within the modules work with untyped @racketmodname[racket], +as macros declared within a @racket[typed/racket] module +normally throw an error when used in an untyped context. + +The following untyped modules are available (a link to the +typed version is noted for each): + +@(define-syntax-rule (u untyped typed) + @item{@racketmodname[untyped] (@racketmodname[typed])}) + +@itemlist[ + @u[phc-toolkit/untyped/aliases phc-toolkit/aliases] + @u[phc-toolkit/untyped/cond-let phc-toolkit/cond-let] + @u[phc-toolkit/untyped/fixnum phc-toolkit/fixnum] + @u[phc-toolkit/untyped/generate-indices phc-toolkit/generate-indices] + @u[phc-toolkit/untyped/ids phc-toolkit/ids] + @u[phc-toolkit/untyped/list phc-toolkit/list] + @u[phc-toolkit/untyped/logn-id phc-toolkit/logn-id] + @u[phc-toolkit/untyped/misc phc-toolkit/misc] + @u[phc-toolkit/untyped/multiassoc-syntax phc-toolkit/multiassoc-syntax] + @u[phc-toolkit/untyped/not-implemented-yet phc-toolkit/not-implemented-yet] + @u[phc-toolkit/untyped/percent phc-toolkit/percent] + @u[phc-toolkit/untyped/repeat-stx phc-toolkit/repeat-stx] + @u[phc-toolkit/untyped/require-provide phc-toolkit/require-provide] + @u[phc-toolkit/untyped/sequence phc-toolkit/sequence] + @u[phc-toolkit/untyped/set phc-toolkit/set] + @u[phc-toolkit/untyped/stx phc-toolkit/stx] + @u[phc-toolkit/untyped/syntax-parse phc-toolkit/syntax-parse] + @u[phc-toolkit/untyped/threading phc-toolkit/threading] + @u[phc-toolkit/untyped/tmpl-multiassoc-syntax + phc-toolkit/tmpl-multiassoc-syntax] + @u[phc-toolkit/untyped/tmpl phc-toolkit/tmpl] + @u[phc-toolkit/untyped/typed-rackunit-extensions + phc-toolkit/typed-rackunit-extensions] + @u[phc-toolkit/untyped/typed-rackunit phc-toolkit/typed-rackunit] + @u[phc-toolkit/untyped/type-inference-helpers + phc-toolkit/type-inference-helpers] + @u[phc-toolkit/untyped/values phc-toolkit/values] + @u[phc-toolkit/untyped/meta-struct phc-toolkit/meta-struct]] + +Furthermore, the following module is only available as an +untyped module: + +@itemlist[ + @item{@racketmodname[phc-toolkit/untyped/for-star-list-star]}] diff --git a/scribblings/utils.rkt b/scribblings/utils.rkt new file mode 100644 index 0000000..16468af --- /dev/null +++ b/scribblings/utils.rkt @@ -0,0 +1,18 @@ +#lang racket + +(require scribble/manual + (for-syntax syntax/parse)) + +(provide def-orig) + +(define-syntax def-orig + (syntax-parser + [(_ orig:id [lib ...] o:id ...) + #`(begin + (module orig racket/base + (require scribble/manual) + (require (for-label lib ...)) + (define o (racket o)) + ... + (provide (prefix-out orig (prefix-out : o)) ...)) + #,(datum->syntax #'orig `(require (quote ,#'orig))))])) \ No newline at end of file diff --git a/scribblings/values-untyped.scrbl b/scribblings/values-untyped.scrbl new file mode 100644 index 0000000..9f45731 --- /dev/null +++ b/scribblings/values-untyped.scrbl @@ -0,0 +1,10 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/untyped/values]] +@(def-orig typed [phc-toolkit/values]) +@title{Untyped versions of values} +@defmodule[phc-toolkit/untyped/values + #:use-sources + [(submod (lib "phc-toolkit/values.rkt") untyped)]] + diff --git a/scribblings/values.scrbl b/scribblings/values.scrbl new file mode 100644 index 0000000..e32ad9a --- /dev/null +++ b/scribblings/values.scrbl @@ -0,0 +1,11 @@ +#lang scribble/manual +@require[racket/require + "utils.rkt" + @for-label[phc-toolkit/values]] +@title{values} +@author{@author+email["Georges Dupéron" "georges.duperon@gmail.com"]} +@defmodule[phc-toolkit/values + #:use-sources + [(submod (lib "phc-toolkit/values.rkt") typed)]] + +@include-section{values-untyped.scrbl} diff --git a/sequence.rkt b/sequence.rkt new file mode 100644 index 0000000..165c998 --- /dev/null +++ b/sequence.rkt @@ -0,0 +1,268 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules + (provide sequence-length>= + in-last? + in-tails + in-heads + in-split + in-split* + *in-split + Syntax-Listof + my-in-syntax + in-syntax + sequence-cons + sequence-null + sequence-list) + + (require racket/sequence) + + ;; sequence-length>= + (begin + (: sequence-length>= (→ (Sequenceof Any) Index Boolean)) + (define (sequence-length>= s l) + (let-values ([(more? next) (sequence-generate s)]) + (define (rec [remaining : Index]) : Boolean + (if (= remaining 0) + #t + (and (more?) + (begin (next) + (rec (sub1 remaining)))))) + (rec l)))) + + ;; in-last? + ;; Returns a sequence of the same length as `s`. All values in the sequence + ;; are #f, except for the last one which is 'last. + (begin + (: in-last? (→ (Sequenceof Any) (Sequenceof (U #f 'last)))) + (define (in-last? s) + (if (sequence-length>= s 1) + (sequence-append (sequence-map (λ _ #f) (sequence-tail s 1)) + (in-value 'last)) + empty-sequence))) + + ;; in-heads and in-tails + (begin + (: in-tails (∀ (T) (→ (Listof T) (Listof (Pairof T (Listof T)))))) + (define (in-tails l) + (if (null? l) + '() + (cons l (in-tails (cdr l))))) + + (module+ test + (require typed/rackunit) + (check-equal? (for/list : (Listof (Listof Number)) + ([x : (Listof Number) (in-tails '(1 2 3 4 5))]) x) + '((1 2 3 4 5) (2 3 4 5) (3 4 5) (4 5) (5))) + (let ((l '(1 2 3 4 5))) + (check-true (eq? (caddr (for/list : (Listof (Listof Number)) + ([x : (Listof Number) (in-tails l)]) x)) + (cddr l))))) + + (: in-heads (∀ (T) (→ (Listof T) (Listof (Pairof T (Listof T)))))) + (define (in-heads l) + (: my-append1 (→ (Listof T) T (Pairof T (Listof T)))) + (define (my-append1 x y) + (if (null? x) + (list y) + (cons (car x) (my-append1 (cdr x) y)))) + + (define (on-heads/private [acc-head : (Listof T)] [l : (Listof T)]) + : (Listof (Pairof T (Listof T))) + (if (null? l) + '() + (let ([new-head (my-append1 acc-head (car l))]) + (cons new-head (on-heads/private new-head (cdr l)))))) + (on-heads/private '() l)) + + (module+ test + (require typed/rackunit) + (check-equal? (for/list : (Listof (Listof Number)) + ([x : (Listof Number) (in-heads '(1 2 3 4 5))]) x) + '((1) (1 2) (1 2 3) (1 2 3 4) (1 2 3 4 5))))) + + ;; in-split, in-split*, *in-split, *in-split* + (begin + ;; Can't write the type of in-split, because typed/racket doesn't allow + ;; writing (Sequenceof A B), just (Sequenceof A). + ;; in-parallel's type has access to the multi-valued version of Sequenceof, + ;; though, so we let typed/racket propagate the inferred type. + (define #:∀ (T) (in-split [l : (Listof T)]) + (in-parallel (sequence-append (in-value '()) (in-heads l)) + (sequence-append (in-tails l) (in-value '())))) + + ;; Same as in-split, but without the empty tail. + (define #:∀ (T) (in-split* [l : (Listof T)]) + (in-parallel (sequence-append (in-value '()) (in-heads l)) + (sequence-append (in-tails l)))) + + ;; Same as in-split, but without the empty head. + (define #:∀ (T) (*in-split [l : (Listof T)]) + (in-parallel (in-heads l) + (sequence-append (sequence-tail (in-tails l) 1) + (in-value '())))) + + (define #:∀ (T) (*in-split* [l : (Listof T)]) + (in-parallel (in-heads l) + (sequence-tail (in-tails l) 1)))) + + ;; my-in-syntax and Syntax-Listof + (begin + ;; See also syntax-e, which does not flatten syntax pairs, and syntax->list, + ;; which isn't correctly typed (won't take #'(a . (b c d e))). + (define-type (Syntax-Listof T) + (Rec R (Syntaxof (U Null + (Pairof T R) + (Listof T))))) + + ;; in-syntax is now provided by racket/sequence. + (: my-in-syntax (∀ (T) (→ (Syntax-Listof T) + (Listof T)))) + (define (my-in-syntax stx) + (let ((e (syntax-e stx))) + (if (null? e) + e + (if (syntax? (cdr e)) + (cons (car e) (my-in-syntax (cdr e))) + e)))) + + (define (test-in-syntax) + ; (ann `(,#'(a . b) ,#'(c . d)) + ; (Listof (Syntaxof (U (Pairof (Syntaxof 'a) (Syntaxof 'b)) + ; (Pairof (Syntaxof 'c) (Syntaxof 'c)))))) + (my-in-syntax #'((a . b) (c . d))) + ; (ann `(,#'a ,#'b ,#'c ,#'d ,#'e) (Listof (Syntaxof (U 'a 'b 'c 'd)))) + (my-in-syntax #'(a . (b c d e))) + ; (ann '() (Listof (Syntaxof Nothing))) + (my-in-syntax #'()))) + + ;; combining sequences: + ;; sequence-cons + ;; sequence-null + ;; sequence-list + + (begin + (: sequence-cons (∀ (A B) (→ (Sequenceof A) (Sequenceof B) + (Sequenceof (cons A B))))) + (define (sequence-cons sa sb) + (sequence-map (λ ([x : (List A B)]) (cons (car x) (cadr x))) + (in-values-sequence (in-parallel sa sb)))) + + (: sequence-null (Sequenceof Null)) + (define sequence-null (in-cycle (in-value '()))) + + (define #:∀ (A) (sequence-head [s : (Sequenceof A)]) + (sequence-ref s 0)) + + (define #:∀ (A) (sequence-tail1 [s : (Sequenceof A)]) + (sequence-tail s 1)) + + ;; sequence-list should have the type: + ;; (∀ (A ...) (→ (Sequenceof A) ... (Sequenceof (List A ...))))) + ;; But the type system rejects the two definitions below. + ;; This definition works, but it's the wrong type: + #;(: sequence-list (∀ (A) (→ (Sequenceof A) * + (Sequenceof (Listof A))))) + #;(define (sequence-list . sequences) + (if (null? sequences) + sequence-null + (sequence-cons (car sequences) + (apply sequence-list (cdr sequences))))) + + ;; This definition works: + (: sequence-list (∀ (A ...) (→ (Sequenceof A) ... + (Sequenceof (List A ...))))) + + (define (sequence-list . seqs) + (let ([more?+next + (map (λ #:∀ (T) ([s : (Sequenceof T)]) + (let-values ([(more? next) (sequence-generate s)]) + (cons more? next))) + seqs)]) + ((inst make-do-sequence Void (List A ...)) + (λ () [values (λ (_) + (map (λ #:∀ (T) ([mn : (Pairof (→ Boolean) (→ T))]) + ((cdr mn))) + more?+next)) + (λ (_) + (void)) + + (void) + (λ (_) + (andmap (λ #:∀ (T) ([mn : (Pairof (→ Boolean) (→ T))]) + ((car mn))) + more?+next)) + #f + #f])))) + + #;(define (sequence-list . seqs) + (let ([more?+next (map (λ #:∀ (T) ([s : (Sequenceof T)]) + : (Pairof (→ Boolean) (→ T)) + (let-values ([(more? next) + (sequence-generate s)]) + (cons more? next))) + seqs)]) + ((inst make-do-sequence + (List (Sequenceof A) ...) + (List A ...)) + (λ () + [values (λ (seqs2) + (map sequence-head + seqs2)) + (λ (seqs2) + (map sequence-tail1 + seqs2)) + seqs + (λ (_) + (andmap (λ #:∀ (T) ([mn : (Pairof (→ Boolean) (→ T))]) + ((car mn))) + more?+next)) + (λ (seqs2) + 'todo) + (λ _ + #t) + (λ _ + #t)])))) + + (module+ test + (require typed/rackunit) + (check-equal? + (let-values ([(more? next) (sequence-generate + (sequence-list (in-list '(1 2 3)) + (in-vector #(a b c)) + (in-list '("x" "y" "z"))))]) + (list (more?) + (more?) + (next) + (next) + (more?) + (more?) + (more?) + (next) + (more?) + (more?) + (more?))) + '(#t #t (1 a "x") (2 b "y") #t #t #t (3 c "z") #f #f #f))) + + #| + (: sequence-list (∀ (A ...) (→ (Sequenceof A) ... + (Sequenceof (List A ...))))) + (define (sequence-list . sequences) + (if (null? sequences) + sequence-null + (sequence-cons (car sequences) + (apply sequence-list (cdr sequences))))) + |# + + #| + (: sequence-list (∀ (F R ...) + (case→ [→ (Sequenceof Null)] + [→ (Sequenceof F) (Sequenceof R) ... + (Sequenceof (List F R ...))]))) + (define sequence-list + (case-lambda + [() + sequence-null] + [(sequence . sequences) + (sequence-cons sequence (apply sequence-list sequences))])) + |#)) \ No newline at end of file diff --git a/set.rkt b/set.rkt new file mode 100644 index 0000000..7684249 --- /dev/null +++ b/set.rkt @@ -0,0 +1,6 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide set-map→set) + (: set-map→set (∀ (e b) (→ (Setof e) (→ e b) (Setof b)))) + (define (set-map→set s f) (list->set (set-map s f)))) \ No newline at end of file diff --git a/stx.rkt b/stx.rkt new file mode 100644 index 0000000..07bd6af --- /dev/null +++ b/stx.rkt @@ -0,0 +1,441 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + ;; intersection types with ∩ were not present in 6.5 + (require "typed-untyped.rkt") + (if-typed + (define-syntax (if-typed<6.6 stx) + (syntax-case stx () + [(_ lt ge) + (if (or (regexp-match #px"^6(\\.[012345](\\..*|)|)$" (version)) + (regexp-match #px"^[123245]\\..*$" (version))) + #'lt + #'ge)])) + (define-syntax-rule (if-typed<6.6 lt ge) ge)) + (define-syntax-rule (skip-typed<6.6 . rest) + (if-typed<6.6 (begin) (begin . rest))) + + (skip-typed<6.6 + (provide stx-e/c + stx-e)) + (provide (all-from-out syntax/stx + "stx/fold.rkt" + "untyped-only/stx.rkt") + + stx-list + stx-e + stx-pair + + stx-list/c + stx-car/c + stx-cdr/c + + syntax-cons-property + stx-map-nested + identifier-length + identifier->string + (rename-out [identifier->string identifier→string]) + ;stx-map-nested + + stx-car + stx-cdr + stx-null? + stx-pair? + stx-list? + + stx-cons + + Stx-List? + Syntax-Pairs-of + + stx-drop-last + stx->list + + stx-foldl + + stx-assoc + cdr-stx-assoc + + check-duplicate-identifiers + + remove-use-site-scope + + nameof) + + (require syntax/stx + (for-syntax racket/syntax + "untyped-only/stx.rkt") + "typed-untyped.rkt") + (require-typed/untyped "sequence.rkt") + + (require "stx/fold.rkt" + "untyped-only/stx.rkt") + + ;; match-expanders: + ;; stx-list + ;; stx-e + ;; stx-pair + (begin + (define-match-expander stx-list + (λ (stx) + (syntax-case stx () + [(_ pat ...) + #'(? syntax? + (app syntax->list (list pat ...)))]))) + + (define-for-syntax stx-e-match-expander + (λ (stx) + (syntax-case stx () + [(_ pat) + #'(? syntax? + (app syntax-e pat))]))) + + (if-typed<6.6 + (define-match-expander stx-e + stx-e-match-expander) + (define-match-expander stx-e + stx-e-match-expander + (make-id+call-transformer #'stx-e-fun))) + + (define-match-expander stx-pair + (λ (stx) + (syntax-case stx () + [(_ pat-car pat-cdr) + #'(? syntax? + (app syntax-e (cons pat-car pat-cdr)))])))) + + ;; utilities: + ;; syntax-cons-property + ;; identifier-length + ;; identifier->string + ;; stx-map-nested + (begin + (: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A)))) + (define (syntax-cons-property stx key v) + (let ([orig (syntax-property stx key)]) + (syntax-property stx key (cons v (or orig '()))))) + + (: identifier-length (→ Identifier Index)) + (define (identifier-length id) (string-length (identifier->string id))) + + (: identifier->string (→ Identifier String)) + (define (identifier->string id) (symbol->string (syntax-e id))) + + (: stx-map-nested (∀ (A B) (→ (→ A B) + (Syntaxof (Listof (Syntaxof (Listof A)))) + (Listof (Listof B))))) + (define (stx-map-nested f stx) + (map (λ ([x : (Syntaxof (Listof A))]) + (map f (syntax-e x))) + (syntax-e stx)))) + + ;; accessors: + ;; stx-car + ;; stx-cdr + ;; stx-null? + ;; stx-pair? + (begin + #| + (require/typed syntax/stx + [stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A))] + [stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B))]) + |# + + (: stx-car (∀ (A B) + (case→ (→ (U (Syntaxof (Pairof A B)) (Pairof A B)) A) + ;; TODO: Not typesafe! + (→ (U (Syntaxof (Listof A)) (Listof A)) A)))) + (define (stx-car p) (car (if (syntax? p) (syntax-e p) p))) + + (: stx-cdr (∀ (A B) + (case→ (→ (U (Syntaxof (Pairof A B)) (Pairof A B)) B) + ;; TODO: Not typesafe! + (→ (U (Syntaxof (Listof A)) (Listof A)) + (Listof A))))) + (define (stx-cdr p) (cdr (if (syntax? p) (syntax-e p) p))) + + (: stx-car/c (∀ (Result) (→ (→ Any Result) + (→ Any (U #f Result))))) + (define ((stx-car/c car/c) v) + (if (syntax? v) + (if (pair? (syntax-e v)) + (let ([r (car/c (car (syntax-e v)))]) + r) + #f) + #f)) + + (: stx-cdr/c (∀ (Result) (→ (→ Any Result) + (→ Any (U #f Result))))) + (define ((stx-cdr/c car/c) v) + (and (if-typed + ((make-predicate (Syntaxof (Pairof Any Any))) v) + (and (syntax? v) (pair? (syntax-e v)))) + (car/c (stx-cdr v)))) + + (: stx-null? (→ Any Boolean : (U (Syntaxof Null) Null))) + (define (stx-null? v) + (if-typed + ((make-predicate (U (Syntaxof Null) Null)) v) + (or (null? v) (and (syntax? v) (null? (syntax-e v)))))) + + (: stx-pair? (→ Any Boolean : (U (Pairof Any Any) + (Syntaxof (Pairof Any Any))))) + (define (stx-pair? v) + (if-typed + ((make-predicate (U (Pairof Any Any) + (Syntaxof (Pairof Any Any)))) + v) + (or (pair? v) (and (syntax? v) (pair? (syntax-e v))))))) + + ;; constructors: + ;; stx-cons + (begin + (module m-stx-cons-untyped racket + (provide stx-cons list->stx list*->stx) + + (define (stx-cons a b) #`(#,a . #,b)) + (define (list->stx l) #`#,l) + (define (list*->stx l*) #`#,l*)) + + (if-typed + (module m-stx-cons-typed typed/racket + (provide stx-cons list->stx list*->stx) + (require (only-in typed/racket/unsafe unsafe-require/typed)) + (unsafe-require/typed + (submod ".." m-stx-cons-untyped) + [stx-cons (∀ (A B) + (→ (Syntaxof A) + (Syntaxof B) + (Syntaxof (Pairof (Syntaxof A) (Syntaxof B)))))] + [list->stx (∀ (A) + (→ (Listof (Syntaxof A)) + (Syntaxof (Listof (Syntaxof A)))))] + [list*->stx (∀ (A B) + (→ (Rec R (U B (Pairof (Syntaxof A) R))) + (Syntaxof (Rec R (U B (Pairof (Syntaxof A) R))))))])) + (module m-stx-cons-typed racket + (provide stx-cons list->stx list*->stx) + (require (submod ".." m-stx-cons-untyped)))) + + (require 'm-stx-cons-typed)) + + ;; stx-drop-last + (begin + (: drop-last (∀ (A) (→ (Listof A) (Listof A)))) + (define (drop-last l) + (if (and (pair? l) (pair? (cdr l))) + (cons (car l) (drop-last (cdr l))) + '())) + + (define-type (Stx-List? A) + (U Null + (Pairof A (Stx-List? A)) + (Syntaxof Null) + (Syntaxof (Pairof A (Stx-List? A))))) + + (: stx-list? (→ Any Boolean : (Stx-List? Any))) + (define (stx-list? v) + (if-typed ((make-predicate (Stx-List? Any)) v) + (or (null? v) + (and (pair? v) (stx-list? (cdr v))) + (and (syntax? v) (null? (syntax-e v))) + (and (syntax? v) (stx-list? (cdr (syntax-e v))))))) + + (: stx-list/c (∀ (Result) (→ (→ (Listof Any) Result) + (→ Any (U #f Result))))) + (define ((stx-list/c l/c) v) + (and (stx-list? v) + (l/c (stx->list v)))) + + (define-type (Syntax-Pairs-of A) + (U (Syntaxof Null) + (Syntaxof (Pairof A (Syntax-Pairs-of A))))) + + (: stx->list (∀ (A) (→ (Stx-List? A) (Listof A)))) + (define (stx->list l) + (cond [(null? l) + '()] + [(pair? l) + (cons (car l) (stx->list (cdr l)))] + [else + (stx->list (syntax-e l))])) + + (: stx-drop-last + (∀ (A) (→ (Stx-List? (Syntaxof A)) (Syntaxof (Listof (Syntaxof A)))))) + (define (stx-drop-last l) + (list->stx (drop-last (stx->list l)))) + + ;; stx-e-fun is used as the fallback for the stx-e match-expander + (define-type SexpofAny1 (U Boolean + Complex + Char + Null + Symbol + String + Keyword + (Pairof Any Any) + VectorTop + BoxTop)) + + (skip-typed<6.6 + (: stx-e/c (∀ (Result) (→ (→ Any Result) + (→ Any (U #f Result))))) + (define ((stx-e/c e/c) v) + (and (if-typed ((make-predicate (U (Syntaxof Any) SexpofAny1)) v) + #t) ;; The untyped stx-e-fun is more permissive + (e/c (stx-e-fun v)))) + + (: stx-e-fun (∀ (A) (case→ (→ (U (Syntaxof A) (∩ A SexpofAny1)) + A)))) + (define (stx-e-fun v) + (if (syntax? v) + (syntax-e v) + v))) + #| + #;(cond [(null? l) + #'()] + [(pair? l) + (cond [(null? (cdr l)) + #'()] + [(pair? (cdr l)) + ] + [else + (let* ([res (stx-drop-last (cdr l))] + [e (syntax-e res)]) + (if (null? e) + (stx-cons (car l) #'()) + (stx-cons (car l) res)))] + [else + (stx-drop-last (syntax-e l))]) + + #;(if (if-typed ((make-predicate (Syntaxof Any)) l) (syntax? l)) + (stx-drop-last (syntax-e l)) + (if (null? l) + #'() + (stx-cons (car l) + (stx-drop-last (cdr l))))))) + |#) + + ;; stx-foldl + (begin + (: stx-foldl + (∀ (E F G Acc) + (case→ (→ (→ E Acc Acc) + Acc + (U (Syntaxof (Listof E)) (Listof E)) + Acc) + (→ (→ E F Acc Acc) + Acc + (U (Syntaxof (Listof E)) (Listof E)) + (U (Syntaxof (Listof F)) (Listof F)) + Acc) + (→ (→ E F G Acc Acc) + Acc + (U (Syntaxof (Listof E)) (Listof E)) + (U (Syntaxof (Listof F)) (Listof F)) + (U (Syntaxof (Listof G)) (Listof G)) + Acc)))) + (define stx-foldl + (case-lambda + [(f acc l) + (if (stx-null? l) + acc + (stx-foldl f (f (stx-car l) acc) (stx-cdr l)))] + [(f acc l l2) + (if (or (stx-null? l) (stx-null? l2)) + acc + (stx-foldl f + (f (stx-car l) (stx-car l2) acc) + (stx-cdr l) + (stx-cdr l2)))] + [(f acc l l2 l3) + (if (or (stx-null? l) (stx-null? l2) (stx-null? l3)) + acc + (stx-foldl f + (f (stx-car l) (stx-car l2) (stx-car l3) acc) + (stx-cdr l) + (stx-cdr l2) + (stx-cdr l3)))]))) + + ;; stx-assoc + ;; cdr-stx-assoc + (begin + (: stx-assoc (∀ (T) (case→ + (→ Identifier + (U (Syntaxof (Listof (Syntaxof (Pairof Identifier + T)))) + (Listof (Syntaxof (Pairof Identifier T)))) + (U (Syntaxof (Pairof Identifier T)) #f)) + (→ Identifier + (Listof (Pairof Identifier T)) + (U (Pairof Identifier T) #f))))) + (define (stx-assoc id alist) + (let* ([e-alist (if (syntax? alist) + (syntax->list alist) + alist)] + [e-e-alist (cond + [(null? e-alist) '()] + [(syntax? (car e-alist)) + (map (λ ([x : (Syntaxof (Pairof Identifier T))]) + (cons (stx-car x) x)) + e-alist)] + [else + (map (λ ([x : (Pairof Identifier T)]) + (cons (car x) x)) + e-alist)])] + [result (assoc id e-e-alist free-identifier=?)]) + (if result (cdr result) #f))) + + (: cdr-stx-assoc + (∀ (T) (case→ (→ Identifier + (U (Syntaxof (Listof (Syntaxof (Pairof Identifier T)))) + (Listof (Syntaxof (Pairof Identifier T))) + (Listof (Pairof Identifier T))) + (U T #f))))) + (define (cdr-stx-assoc id alist) + (if (null? alist) + #f + ;; The typechecker is not precise enough, and the code below does not + ;; work if we factorize it: + ;; (if (and (list? alist) (syntax? (car alist))) … …) + (if (list? alist) + (if (syntax? (car alist)) + (let ((res (stx-assoc id alist))) + (if res (stx-cdr res) #f)) + (let ((res (stx-assoc id alist))) + (if res (cdr res) #f))) + (let ((res (stx-assoc id alist))) + (if res (stx-cdr res) #f)))))) + + ;; check-duplicate-identifiers + (begin + (: check-duplicate-identifiers (→ (Syntaxof (Listof (Syntaxof Symbol))) + Boolean)) + (define (check-duplicate-identifiers ids) + (if (check-duplicate-identifier (my-in-syntax ids)) #t #f))) + + ;; remove-use-site-scope + (begin + (define #:∀ (A) (remove-use-site-scope [stx : (Syntaxof A)]) + (define bd + (syntax-local-identifier-as-binding (syntax-local-introduce #'here))) + (define delta + (make-syntax-delta-introducer (syntax-local-introduce #'here) bd)) + (delta stx 'remove))) + + ;; nameof + (begin + ;; TODO: use the proper way to introduce arrows if possible. + (define-syntax (nameof stx) + (syntax-case stx () + [(_ x) + (record-disappeared-uses (list #'x)) + #''x]))) + + #| + (define (raise-multi-syntax-error name message exprs) + (let ([e (exn:fail:syntax "message" + (current-continuation-marks) + (list #'aaa #'bbb))]) + ((error-display-handler) (exn-message e) e))) + |#) \ No newline at end of file diff --git a/stx/fold-typed+prefab.rkt.does-not-work b/stx/fold-typed+prefab.rkt.does-not-work new file mode 100644 index 0000000..9fb0637 --- /dev/null +++ b/stx/fold-typed+prefab.rkt.does-not-work @@ -0,0 +1,57 @@ +#lang typed/racket + +(require "prefab.rkt") +(define-type SrcLoc (U False + (Syntaxof Any) + (List Any + (U Integer False) + (U Integer False) + (U Integer False) + (U Integer False)) + (Vector Any + (U Integer False) + (U Integer False) + (U Integer False) + (U Integer False)))) + +;; Replaces the syntax/loc for the top of the syntax object, until +;; a part which doesn't belong to old-source is reached. +;; e.g. (with-syntax ([d user-provided-syntax]) +;; (replace-top-loc +;; #'(a b (c d e)) +;; (syntax-source #'here) +;; new-loc)) +;; will produce a syntax object #'(a b (c (x (y) z) e)) +;; where a, b, c, z, e and their surrounding forms have their srcloc set to +;; new-loc, but (x (y) z) will be left intact, if the user-provided-syntax +;; appears in another file. +(: replace-top-loc (→ Syntax Any SrcLoc Syntax)) +(define (replace-top-loc stx old-source new-loc) + (define (process-e [stx : (U Syntax-E PrefabTop)]) : (U Syntax-E PrefabTop) + (cond + ;[(syntax? stx) + [(prefab-struct? stx) + (apply make-prefab-struct + (prefab-struct-key stx) + (map process (vector->list (struct->vector stx))))] + [(and (pair? stx) (syntax? (cdr stx))) + (cons (process (car stx)) + (process (cdr stx)))] + [(and (pair? stx) (not (syntax? (cdr stx)))) + (map process stx)] + [(vector? stx) + (list->vector (map process (vector->list stx)))] + [(box? stx) + (box (process (unbox stx)))] + [else + stx])) + (define (process [stx : Syntax]) : Syntax + (if (equal? (syntax-source stx) old-source) + (datum->syntax stx (process-e (syntax-e stx)) new-loc stx) + stx + ;; Use the following expression to replace the loc throughout stx + ;; instead of stopping the depth-first-search when the syntax-source + ;; is not old-source anymore + #;(datum->syntax stx (process (syntax-e stx)) stx stx))) + + (process stx)) diff --git a/stx/fold.rkt b/stx/fold.rkt new file mode 100644 index 0000000..8621dc7 --- /dev/null +++ b/stx/fold.rkt @@ -0,0 +1,90 @@ +#lang racket + +(provide fold-syntax + replace-top-loc + syntax/top-loc + quasisyntax/top-loc + syntax/whole-loc + quasisyntax/whole-loc) + +(define (fold-syntax f stx) + (let process ([stx stx]) + (cond + [(syntax? stx) + (f stx (λ (x) + (let ([p (process (syntax-e x))]) + (if (syntax? p) + p + (datum->syntax stx p stx stx)))))] + [(pair? stx) + (cons (process (car stx)) + (process (cdr stx)))] + [(null? stx) + stx] + [(vector? stx) + (list->vector (map process (vector->list stx)))] + [(box? stx) + (box (process (unbox stx)))] + [(hash? stx) + (define processed (process (hash->list stx))) + (cond + [(hash-equal? stx) (hash processed)] + [(hash-eqv? stx) (hasheqv processed)] + [(hash-eq? stx) (hasheq processed)])] + [(prefab-struct-key stx) + (apply make-prefab-struct + (prefab-struct-key stx) + (map process (vector->list (struct->vector stx))))] + [else + stx]))) + +;; Replaces the syntax/loc for the top of the syntax object, until +;; a part which doesn't belong to old-source is reached. +;; e.g. (with-syntax ([d user-provided-syntax]) +;; (replace-top-loc +;; #'(a b (c d e)) +;; (syntax-source #'here) +;; new-loc)) +;; will produce a syntax object #'(a b (c (x (y) z) e)) +;; where a, b, c, z, e and their surrounding forms have their srcloc set to +;; new-loc, but (x (y) z) will be left intact, if the user-provided-syntax +;; appears in another file. + +(define (replace-top-loc stx old-source new-loc) + (fold-syntax + (λ (stx rec) + (if (equal? (syntax-source stx) old-source) + (datum->syntax stx (syntax-e (rec stx)) new-loc stx) + stx)) + stx)) + +;; Use the following function to replace the loc throughout stx +;; instead of stopping the depth-first-search when the syntax-source +;; is not old-source anymore +(define (replace-whole-loc stx old-source new-loc) + (fold-syntax + (λ (stx rec) + (if (equal? (syntax-source stx) old-source) + (datum->syntax stx (syntax-e (rec stx)) new-loc stx) + (rec stx))) + stx)) + +(define-syntax (syntax/top-loc stx) + (syntax-case stx () + [(self loc template) + #'(replace-top-loc #'template (syntax-source #'self) loc)])) + +(define-syntax (quasisyntax/top-loc stx) + (syntax-case stx () + [(self loc template) + #'(replace-top-loc #`template (syntax-source #'self) loc)])) + +(define-syntax (syntax/whole-loc stx) + (syntax-case stx () + [(self loc template) + #'(replace-whole-loc #'template (syntax-source #'self) loc)])) + +(define-syntax (quasisyntax/whole-loc stx) + (syntax-case stx () + [(self loc template) + #'(replace-whole-loc #`template (syntax-source #'self) loc)])) \ No newline at end of file diff --git a/stx/prefab.rkt b/stx/prefab.rkt new file mode 100644 index 0000000..7cf14d8 --- /dev/null +++ b/stx/prefab.rkt @@ -0,0 +1,70 @@ +#lang typed/racket/base + +(module m1 racket/base + (require alexis/bool + racket/function) + + (provide prefab-struct?) + + (define prefab-struct? (compose true? prefab-struct-key))) + +(module m2 typed/racket/base + (provide PrefabKey + PrefabTop + prefab-struct? + make-prefab-struct + ;; Imprecise type (m3 gives a more precise type to these): + prefab-struct-key + prefab-key?) + + (define-type PrefabKey (U Symbol + (List Symbol + ; Optional: Nonnegative-Integer + (List Nonnegative-Integer Any) + (Vectorof Nonnegative-Integer)) + (List Symbol + Nonnegative-Integer ; Optional + (List Nonnegative-Integer Any) + (Vectorof Nonnegative-Integer)) + (List* Symbol + ; Optional: Nonnegative-Integer + (List Nonnegative-Integer Any) + (Vectorof Nonnegative-Integer) + PrefabKey) + (List* Symbol + Nonnegative-Integer ; Optional + (List Nonnegative-Integer Any) + (Vectorof Nonnegative-Integer) + PrefabKey))) + + (require typed/racket/unsafe) + (unsafe-require/typed (submod ".." m1) [#:opaque PrefabTop prefab-struct?]) + + (require/typed racket [make-prefab-struct (→ PrefabKey Any * PrefabTop)]) + + (require/typed racket + [prefab-struct-key (→ Any (U #f PrefabKey))] + [prefab-key? (→ Any Boolean)])) + +(module m3 typed/racket/base + (require typed/racket/unsafe) + (require (except-in (submod ".." m2) prefab-struct-key prefab-key?)) + + (provide prefab-struct-key prefab-key?) + + ;; Give a more precise type, while still ensuring that at least part of it + ;; is validated by a contract: + (unsafe-require/typed (submod ".." m2) + [prefab-struct-key (case→ (→ PrefabTop PrefabKey) + (→ Any #f))] + [prefab-key? (→ Any Boolean : PrefabKey)])) + +(require (except-in 'm2 prefab-struct-key prefab-key?) + 'm3) + +(provide PrefabKey + PrefabTop + prefab-struct? + make-prefab-struct + prefab-struct-key + prefab-key?) \ No newline at end of file diff --git a/syntax-parse.rkt b/syntax-parse.rkt new file mode 100644 index 0000000..a32f220 --- /dev/null +++ b/syntax-parse.rkt @@ -0,0 +1,296 @@ +#lang typed/racket +(require "typed-untyped.rkt") + +(module m-stx-identifier racket + (require racket/stxparam) + + (provide stx) + + (define-syntax-parameter stx + (lambda (call-stx) + (raise-syntax-error + 'stx + (string-append "Can only be used in define-syntax/parse, λ/syntax-parse" + " or other similar forms") + call-stx)))) + +(define-typed/untyped-modules #:no-test + (provide stx + define-and-for-syntax + define-syntax/parse + define-syntax/case + ;define-for-syntax/parse-args + define-for-syntax/case-args + λ/syntax-parse + λ/syntax-case + define/case-args + λstx + ~maybe + ~maybe* + ~optkw + ~oncekw + ~optkw… + ~oncekw… + ~kw + ~lit + ~with + ~attr + ~or-bug + (rename-out [~or-bug ~either]) + define-simple-macro + ;template/loc + ;quasitemplate/loc + template/debug + quasitemplate/debug + meta-eval + define/with-parse + identity-macro + name-or-curry + (all-from-out "untyped-only/syntax-parse.rkt")) + + (begin-for-syntax + (provide stx)) + + (require (for-syntax (submod "stx.rkt" untyped))) + (require "untyped-only/syntax-parse.rkt") + + (define-syntax (define-and-for-syntax stx) + (syntax-case stx () + [(_ id value) + (remove-use-site-scope + #'(begin + (define-for-syntax id value) + (define id value)))])) + + + (require (rename-in syntax/parse + [define/syntax-parse define/with-parse]) + syntax/parse/define + syntax/parse/experimental/template + (for-syntax racket/syntax + racket/stxparam) + (for-meta 2 racket/base racket/syntax) + racket/stxparam) + + (require "typed-untyped.rkt" + (for-syntax "typed-untyped.rkt")) + (require-typed/untyped "backtrace.rkt") + (begin-for-syntax (require-typed/untyped "backtrace.rkt")) + + (define-syntax ~maybe + (pattern-expander + (λ (stx) + (syntax-parse stx + [(_ pat ...) + #'(~optional (~seq pat ...))])))) + + (define-syntax ~maybe* + (pattern-expander + (λ (stx) + (syntax-parse stx + [(_ name pat ...) + #'(~and name (~optional (~seq pat ...)))])))) + + (define-for-syntax ((|make ~*kw| base-pattern name?) stx) + (syntax-case stx () + [(_ kw pat ...) + (keyword? (syntax-e #'kw)) + (let () + (define/with-syntax name + (format-id #'kw "~a" (keyword->string (syntax-e #'kw)))) + #`(#,base-pattern (~seq (~and name kw) pat ...) + #,@(if name? + #`(#:name #,(format "the ~a keyword" + (syntax-e #'kw))) + #'())))])) + + (define-syntax ~optkw + (pattern-expander + (|make ~*kw| #'~optional #f))) + + (define-syntax ~oncekw + (pattern-expander + (|make ~*kw| #'~once #f))) + + (define-syntax ~optkw… + (pattern-expander + (|make ~*kw| #'~optional #t))) + + (define-syntax ~oncekw… + (pattern-expander + (|make ~*kw| #'~once #t))) + + (define-syntax ~kw + (pattern-expander + (λ (stx) + (syntax-parse stx + [(_ kw:keyword) + (define/with-syntax name + (format-id #'kw "~a" (keyword->string (syntax-e #'kw)))) + #'(~and name kw)])))) + + ;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in + ;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)]) + (define-syntax ~or-bug + (pattern-expander + (λ (stx) + (syntax-parse stx + [(_ pat ...) + #'(~and (~or pat ...))])))) + + (define-syntax ~lit + (pattern-expander + (λ (stx) + (syntax-parse stx + [(self (~optional (~seq name:id (~literal ~))) lit) + (if (attribute name) + #'(~and name (~literal lit)) + #'(~literal lit))] + [(self (~optional (~seq name:id (~literal ~))) lit ...) + (define (s stx) (datum->syntax #'self stx stx stx)) + (if (attribute name) + #'(~and name (~seq (~literal lit) ...)) + #'(~seq (~literal lit) ...))])))) + + (define-syntax ~with + (pattern-expander + (λ (stx) + (syntax-parse stx + [(_ pat val) + #'(~parse pat val)])))) + + (define-syntax ~attr + (pattern-expander + (λ (stx) + (syntax-parse stx + [(_ attr-name val) + #'(~bind [attr-name val])])))) + + (require (submod ".." m-stx-identifier) + (for-syntax (submod ".." m-stx-identifier))) + + ;; TODO: try to factor out the common parts of these definitions (problem: + ;; the same code is used at different meta-levels, we would need a separate + ;; module to declare it). + (define-simple-macro (define-syntax/parse (name . args) body0 . body) + (define-syntax (name stx2) + (with-backtrace (syntax->datum stx2) + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-parse stx2 + [(_ . args) body0 . body]))))) + + (define-syntax-rule (define-syntax/case (name . args) literals body0 . body) + (define-syntax (name stx2) + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-case stx2 literals + [(_ . args) (let () body0 . body)])))) + + (define-syntax-rule (λ/syntax-parse args . body) + (λ (stx2) + (with-backtrace (syntax->datum stx2) + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-parse stx2 + [args . body]))))) + + (define-syntax-rule (λ/syntax-case args literals . body) + (λ (stx2) + (with-backtrace (syntax->datum stx2) + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-case stx2 literals + [args (let () . body)]))))) + + (define-syntax (define-for-syntax/case-args wstx) + (syntax-case wstx () + [(_ (name args ...) . body) + (with-syntax ([(param ...) (generate-temporaries #'(args ...))]) + #'(define-for-syntax (name param ...) + (with-syntax ([args param] ...) + . body)))])) + + (define-syntax (define/case-args wstx) + (syntax-case wstx () + [(_ (name args ...) . body) + (with-syntax ([(param ...) (generate-temporaries #'(args ...))]) + #'(define (name param ...) + (with-syntax ([args param] ...) + . body)))])) + + ;; λstx + (begin + (define-syntax-rule (λstx (param ...) body ...) + (λ (param ...) + (with-syntax ([param param] ...) + body ...))) + + (module+ test + (require typed/rackunit) + (check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b)) + (syntax->datum #'(a b))))) + + ;; template/loc + (begin + (define-syntax-rule (template/loc loc . tmpl) + (quasisyntax/loc loc #,(template . tmpl)))) + + ;; quasitemplate/loc + (begin + (define-syntax-rule (quasitemplate/loc loc . tmpl) + (quasisyntax/loc loc #,(quasitemplate . tmpl)))) + + ;; template/debug + (begin + (define-syntax (template/debug stx) + (syntax-parse stx + [(_ debug-attribute:id . rest) + #'((λ (x) + (when (attribute debug-attribute) + (pretty-write (syntax->datum x))) + x) + (template . rest))]))) + + ;; quasitemplate/debug + (begin + (define-syntax (quasitemplate/debug stx) + (syntax-parse stx + [(_ debug-attribute:id . rest) + #'((λ (x) + (when (attribute debug-attribute) + (pretty-write (syntax->datum x))) + x) + (quasitemplate . rest))]))) + + ;; meta-eval + (begin + ;; TODO: this is kind of a hack, as we have to write: + #;(with-syntax ([(x ...) #'(a bb ccc)]) + (let ([y 70]) + (quasitemplate + ([x (meta-eval (+ #,y (string-length + (symbol->string + (syntax-e #'x)))))] + ...)))) + ;; Where we need #,y instead of using: + ;; (+ y (string-length etc.)). + (module m-meta-eval racket + (provide meta-eval) + (require syntax/parse/experimental/template) + + (define-template-metafunction (meta-eval stx) + (syntax-case stx () + [(_ . body) + #`#,(eval #'(begin . body))]))) + (require 'm-meta-eval)) + + (define-syntax (identity-macro stx) + (syntax-case stx () + [(_ . rest) + (remove-use-site-scope #'rest)])) + + (module m-name-or-curry racket/base + (provide (all-defined-out)) + (require syntax/parse) + (define-syntax-class name-or-curry + #:attributes (id) + (pattern id:id) + (pattern (:name-or-curry . curry-args)))) + (require 'm-name-or-curry)) \ No newline at end of file diff --git a/test-framework.rkt b/test-framework.rkt new file mode 100644 index 0000000..70e5134 --- /dev/null +++ b/test-framework.rkt @@ -0,0 +1,60 @@ +#lang typed/racket + +;; TODO: Warning: this file may be deprecated or out of date. + +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + ;; Using check-equal? on some values result in the following error message: + ;; Attempted to use a higher-order value passed as `Any` in untyped code + ;; check-equal? and check-not-equal? are replaced by versions that work with + ;; “higher-order values” below. + + (require (except-in (only-meta-in 0 typed/rackunit) + ;; Above: typed/racket risks complaining that it can't do + ;; for-meta in all-from-out if we don't use `only-meta-in` + check-equal? + check-not-equal?)) + + (provide (all-from-out typed/rackunit) + check-equal? + check-not-equal? + check-eval-equal? + check-eval-string-equal? + check-eval-string-equal?/ns) + + (require "eval-get-values.rkt") + + (require syntax/parse/define) + + (define-simple-macro (check-equal? x y . message) + (check-true (equal? x y) . message)) + + (define-simple-macro (check-not-equal? x y . message) + (check-true (not (equal? x y)) . message)) + + (define-simple-macro (check-eval-equal? to-eval y . message) + (check-true (equal? (eval-get-values to-eval + (variable-reference->namespace + (#%variable-reference))) + y) + . message)) + + (define-simple-macro (check-eval-string-equal? to-eval y . message) + (check-true (equal? (eval-get-values (read (open-input-string to-eval)) + (variable-reference->namespace + (#%variable-reference))) + y) + . message)) + + (define-simple-macro (check-eval-string-equal?/ns ns-anchor to-eval y + . message) + (check-true (equal? (eval-get-values (read (open-input-string to-eval)) + (namespace-anchor->namespace + ns-anchor)) + y) + . message)) + + (define-syntax-rule (test-module body ...) + (module* test typed/racket + (require (submod "..")) + body ...))) \ No newline at end of file diff --git a/test/list-lang-test.rkt b/test/list-lang-test.rkt new file mode 100644 index 0000000..3308250 --- /dev/null +++ b/test/list-lang-test.rkt @@ -0,0 +1,12 @@ +#lang s-exp phc-toolkit/list-lang + +(require typed/rackunit) +(check-equal? whole-list '((a 1) b c (3 4 5))) + +(define-list-values whole-list : (Listof (U Symbol (Listof (U Symbol Number))))) +;; All the items below are quoted and aggregated into whole-list. +(a 1) +b + +c +(3 4 5) diff --git a/test/list-test.rkt b/test/list-test.rkt new file mode 100644 index 0000000..df6198d --- /dev/null +++ b/test/list-test.rkt @@ -0,0 +1,145 @@ +#lang typed/racket +(require "../typed-untyped.rkt") +(define-typed/untyped-test-module + (require-typed/untyped phc-toolkit/list + phc-toolkit/typed-rackunit) + + (check-equal?: (indexof 'c '(c)) 0) + (check-equal?: (indexof 'c '(c a b c d a b c d)) 0) + (check-equal?: (indexof 'c '(a b c d a b c d)) 2) + (check-equal?: (indexof 'x '()) #f) + (check-equal?: (indexof 'x '(c)) #f) + (check-equal?: (indexof 'x '(c a b c d a b c d)) #f) + (check-equal?: (indexof 'x '(a b c d a b c d)) #f) + + (define-syntax (skip<=6.6 stx) + (syntax-case stx () + [(_ . rest) + (if (or (regexp-match #px"^6(\\.[012345](\\..*|)|)$" (version)) + (regexp-match #px"^6.6$" (version)) + (regexp-match #px"^[123245]\\..*$" (version))) + #'(begin) + #'(begin . rest))])) + + ;; replace-first + (skip<=6.6 + (check-equal?: (replace-first 'c 'r '(c)) '(r)) + (check-equal?: (replace-first 'c 'r '(c a b c d a b c d)) + '(r a b c d a b c d)) + (check-equal?: (replace-first 'c 'r '(a b c d a b c d)) '(a b r d a b c d)) + (check-equal?: (replace-first 'x 'r '()) '()) + (check-equal?: (replace-first 'x 'r '(c)) '(c)) + (check-equal?: (replace-first 'x 'r '(c a b c d a b c d)) + '(c a b c d a b c d)) + (check-equal?: (replace-first 'x 'r '(a b c d a b c d)) '(a b c d a b c d)) + + (struct s ([a : Number]) #:transparent) + (check-equal?: (replace-first (s 2) 'r (list (s 3) (s 2) (s 1) (s 2))) + (list (s 3) (s 2) (s 1) (s 2))) + (check-equal?: (replace-first (s 2) + 'r + (list (s 3) (s 2) (s 1) (s 2)) + equal?) + (list (s 3) 'r (s 1) (s 2))) + + (define-type (Test-List3-Maybe Start Mid End) + (U (Pairof Start (Test-List3-Maybe Start Mid End)) + Null + (Pairof Mid (Listof End)))) + + (check-equal?: (replace-first (s 3) 'r (list (s 4) (s 3) (s 2) (s 1) (s 3))) + : (Test-List3-Maybe s 'r s) + (list (s 4) (s 3) (s 2) (s 1) (s 3))) + + (check-equal?: (replace-first (s 3) 'r (list (s 4) (s 3) (s 2) (s 1) (s 3))) + : (Rec R (U (Pairof s R) + Null + (Pairof 'r (Listof s)))) + (list (s 4) (s 3) (s 2) (s 1) (s 3))) + + (check-equal?: (replace-first (s 3) 'r (list (s 4) (s 3) (s 2) (s 1) (s 3))) + : (List3-Maybe s 'r s) + (list (s 4) (s 3) (s 2) (s 1) (s 3))) + + (check-equal?: (replace-first 'r (list 'a 'b 'c 'a 'b 'c) + (λ (x) (eq? x 'c))) + : (List3-Maybe (U 'a 'b) 'r (U 'a 'b 'c)) + (list 'a 'b 'r 'a 'b 'c)) + + ;; TR is not strong enough yet to infer the type to use, but at least we can + ;; prove the result has the desired type without using casts: + (check-equal?: ((inst (ann replace-first + (∀ (A B1 B2 C D) + (→ C + (Listof* A (U Null (Pairof B2 D))) + (→ (U A B2) Any : + #:+ (! A) ;; ∴ (and (! A) B2) + #:- (! B2)) + (Listof* A (U Null (Pairof C D)))))) + (U 'a 'b) Nothing 'c 'r (Listof (U 'd 'e))) + 'r + (ann (list 'a 'b 'c 'd 'e) + (List3-Maybe (U 'a 'b) 'c (U 'd 'e))) + (λ (x) (eq? x 'c))) + : (List3-Maybe (U 'a 'b) 'r (U 'd 'e)) + (list 'a 'b 'r 'd 'e)) + + ;; TR is not strong enough yet to infer the type to use, but at least we can + ;; prove the result has the desired type without using casts: + (check-equal?: ((inst (ann replace-first + (∀ (A B1 B2 C D) + (→ C + (Listof* A (Pairof B2 D)) + (→ (U A B2) Any : + #:+ (! A) ;; ∴ (and (! A) B2) + #:- (! B2)) + (Listof* A (Pairof C D))))) + (U 'a 'b) Nothing 'c 'r (Listof (U 'd 'e))) + 'r + (ann (list 'a 'b 'c 'd 'e) + (List3 (U 'a 'b) 'c (U 'd 'e))) + (λ (x) (eq? x 'c))) + : (List3 (U 'a 'b) 'r (U 'd 'e)) + (list 'a 'b 'r 'd 'e)) + + ;; TR is not strong enough yet to infer the type to use, but at least we can + ;; prove the result has the desired type without using casts: + (check-equal?: ((inst (ann replace-first + (∀ (A B1 B2 C D) + (→ C + (Listof* A (Pairof B2 D)) + (→ (U A B2) Any : + #:+ (! A) ;; ∴ (and (! A) B2) + #:- (! B2)) + (Listof* A (Pairof C D))))) + (U 'a 'b) Nothing 'c 'r (List)) + 'r + (ann (list 'a 'b 'c) + (Listof* (U 'a 'b) (List 'c))) + (λ (x) (eq? x 'c))) + : (Listof* (U 'a 'b) (List 'r)) + (list 'a 'b 'r))) + + ;; map+fold + (begin + (check-equal?: (let-values ([(l a) (map+fold (λ ([e : Number] [a : Number]) + (values (add1 e) + (+ a e))) + 0 + '(1 2 3 4 5))]) + (list l a)) + '((2 3 4 5 6) 15)) + + (check-equal?: (let-values ([(l a) (map+fold (λ ([e : Number] [a : Number]) + (values 1 2)) + 7 + '())]) + (list l a)) + '(() 7)) + + (check-equal?: (let-values ([(l a) (map+fold (λ ([e : Number] [a : Number]) + (values 1 2)) + 7 + '(3))]) + (list l a)) + '((1) 2)))) \ No newline at end of file diff --git a/test/meta-struct-test.rkt b/test/meta-struct-test.rkt new file mode 100644 index 0000000..96f203c --- /dev/null +++ b/test/meta-struct-test.rkt @@ -0,0 +1,79 @@ +#lang racket/base + +(require (for-syntax racket/base) + phc-toolkit/meta-struct + rackunit) + +(define-syntax (test-subtype? stx) + (syntax-case stx () + [(_ sub super) + #`#,(if (meta-struct-subtype? #'sub #'super) + #t + #f)])) + +(module m1 racket + (struct sa ()) + (provide (struct-out sa))) +(module m2 racket + (require (submod ".." m1)) + (struct sb sa ()) + (provide (rename-out [sa sa2])) + (provide (struct-out sb))) +(require 'm1) +(require 'm2) +(struct sc sb ()) + +(check-true (test-subtype? sa sa)) +(check-true (test-subtype? sa2 sa)) +(check-true (test-subtype? sb sa)) +(check-true (test-subtype? sc sa)) + +(check-true (test-subtype? sa sa2)) +(check-true (test-subtype? sa2 sa2)) +(check-true (test-subtype? sb sa2)) +(check-true (test-subtype? sc sa2)) + +(check-false (test-subtype? sa sb)) +(check-false (test-subtype? sa2 sb)) +(check-true (test-subtype? sb sb)) +(check-true (test-subtype? sc sb)) + +(check-false (test-subtype? sa sc)) +(check-false (test-subtype? sa2 sc)) +(check-false (test-subtype? sb sc)) +(check-true (test-subtype? sc sc)) + + + + + +(struct s (f) #:mutable) +(struct t s (g)) +(struct u (f)) +(struct v u (g)) +(begin-for-syntax + (require rackunit) + (check-false (struct-type-id-is-immutable? #'s)) + (check-false (struct-type-id-is-immutable? #'t)) + (check-true (struct-type-id-is-immutable? #'u)) + (check-true (struct-type-id-is-immutable? #'v))) + +(struct ts (f) #:mutable #:transparent) +(struct tt ts (g) #:transparent) +(struct tu ([f #:mutable] g h) #:transparent) +(struct tv tu (i j k l) #:transparent) +(struct tw (f g h) #:transparent) +(struct tx tu (i j k l) #:transparent) + +(require rackunit) +(check-false (struct-instance-is-immutable? (s 1))) +(check-false (struct-instance-is-immutable? (t 1 2))) +;; can't tell for u, because the struct is opaque. +(check-false (struct-instance-is-immutable? (u 1))) + +(check-false (struct-instance-is-immutable? (ts 1))) +(check-false (struct-instance-is-immutable? (tt 1 2))) +(check-false (struct-instance-is-immutable? (tv 1 2 3 4 5 6 7))) +(check-false (struct-instance-is-immutable? (tu 1 2 3))) +(check-true (struct-instance-is-immutable? (tw 1 2 3))) +(check-false (struct-instance-is-immutable? (tx 1 2 3 4 5 6 7))) \ No newline at end of file diff --git a/test/test-define-temp-ids.rkt b/test/test-define-temp-ids.rkt new file mode 100644 index 0000000..162a426 --- /dev/null +++ b/test/test-define-temp-ids.rkt @@ -0,0 +1,26 @@ +#lang racket +(require (submod "../main.rkt" untyped)) + +(with-syntax ([((foo ...) ...) #'((aa bb cc) (x1 x2))]) + (define-temp-ids "___~a.truc" ((foo ...) ...) #:first-base fst) + (syntax->datum #'((___foo.truc ...) ...)) + (syntax->datum #'(fst ___fst.truc)) + (void)) + +(with-syntax ([(foo ...) #'(aa bb cc)]) + (define-temp-ids "___~a.truc" (foo ...) #:first-base fst) + (syntax->datum #'(___foo.truc ...)) + (syntax->datum #'(fst ___fst.truc)) + (void)) + +(with-syntax ([foo #'aa]) + (define-temp-ids "___~a.truc" foo) + (syntax->datum #'___foo.truc) + (syntax->datum #'(fst ___fst.truc)) + (void)) + +(with-syntax ([((foo ...) ...) #'((aa bb cc) (x1 x2))]) + (define-temp-ids "___~a.truc" ((foo ...) ...) #:first-base fst) + (syntax->datum #'(___foo.truc ... ...)) + (syntax->datum #'(fst ___fst.truc)) + (void)) diff --git a/test/test-fixnum.rkt b/test/test-fixnum.rkt new file mode 100644 index 0000000..38dd287 --- /dev/null +++ b/test/test-fixnum.rkt @@ -0,0 +1,9 @@ +#lang typed/racket +(require "../typed-untyped.rkt") +(define-typed/untyped-test-module + (require-typed/untyped phc-toolkit/fixnum) + (check-equal? (fxxor2 13206 23715) 28469) + (check-equal? (fxxor 0) 0) + (check-equal? (fxxor 13206) 13206) + (check-equal? (fxxor 13206 23715) 28469) + (check-equal? (fxxor 13206 23715 314576) 304101)) \ No newline at end of file diff --git a/test/test-format-id-record-inject.rkt b/test/test-format-id-record-inject.rkt new file mode 100644 index 0000000..0ea046f --- /dev/null +++ b/test/test-format-id-record-inject.rkt @@ -0,0 +1,69 @@ +#lang racket + +(require rackunit + (for-syntax phc-toolkit/untyped + racket/syntax + racket/string + racket/function + rackunit) + (for-meta 2 racket/base) + (for-meta 2 phc-toolkit/untyped)) + +(define-syntax (foo stx) + (syntax-case stx () + [(_ a b) + (let () + (define/with-syntax a-b (format-id #'a "~a-~a" #'a #'b)) + ;#'(define a-b 42) + #'(inject-sub-range-formats ([#'a "~a-~a" #'a #'b]) + (define a-b 42)))])) + +(foo x y) + +;; The arrows are properly drawn here. +(check-equal? x-y 42) + +(define-syntax (bar stx) + (syntax-case stx () + [(_ a b) + (let () + (define/with-syntax a-b (format-id #'a "~a-~a" #'a #'b)) + #'(begin-for-syntax + (inject-sub-range-formats ([#'a "~a-~a" #'a #'b]) + (define a-b 42))))])) + +(bar x y) + +;; The arrows are properly drawn here. +(begin-for-syntax (check-equal? x-y 42)) + +(define-syntax (baz stx) + (syntax-case stx () + [(_ a b) + (with-format-ids/inject-binders + ([a-b #'a "~a-~a" #'a #'b]) + #'(begin-for-syntax + (inject-sub-range-binders ... + (define a-b 42))))])) + +(baz x z) + +;; The arrows are properly drawn here. +(begin-for-syntax (check-equal? x-z 42)) + +(define-syntax (test-hyphen-let stx) + (syntax-case stx () + [(_ [a b c] d e) + (with-format-ids/inject-binders + ([abc #'a "~a-~a-~a" #'a #'b #'c] + [ac #'a "~a++~a" #'a #'c]) + #`(let () + (inject-sub-range-binders ... + (define abc 123) + (define ac 456) + (check-equal? d 123) + (check-equal? e 456))))])) + +;; The arrows are properly drawn here. +(test-hyphen-let [a b c] + a-b-c a++c) diff --git a/test/test-format-id-record.rkt b/test/test-format-id-record.rkt new file mode 100644 index 0000000..1875fe9 --- /dev/null +++ b/test/test-format-id-record.rkt @@ -0,0 +1,89 @@ +#lang racket + +(require (for-syntax "../untyped-only/format-id-record.rkt" + racket/syntax + racket/string + racket/function) + rackunit) + +(define-syntax (test-hyphen stx) + (syntax-case stx () + [(_ [a ...] b) + (with-sub-range-binders + #`(begin (define #,(apply format-id/record + (car (syntax->list #'(a ...))) + (string-join (map (const "~a") + (syntax->list #'(a ...))) + "-") + (syntax->list #'(a ...))) + 123) + (check-equal? b 123)))])) + +(test-hyphen [a b c xyz] a-b-c-xyz) +(let () + (test-hyphen [a b c xyz] a-b-c-xyz)) + +(define-syntax (test-concat stx) + (syntax-case stx () + [(_ [a b c] d) + (with-sub-range-binders + #`(begin (define #,(format-id/record #'a "~a~a~a" #'a #'b #'c) + 9) + (check-equal? d 9)))])) + +(test-concat [a bb ccc] abbccc) +;; Misaligned sub-range-binders are due to +;; https://github.com/racket/drracket/issues/68 +(test-concat [1 81 6561] |1816561|) +(let () + (test-concat [a bb ccc] abbccc) + (test-concat [1 81 6561] |1816561|)) + + +(define-syntax (test-arrows stx) + (syntax-case stx () + [(_ [a b c] d e) + (with-arrows + #`(begin (define #,(format-id/record #'a "~a~a~a" #'a #'b #'c) + 321) + (check-equal? d #,(syntax-local-value/record #'e number?))))])) + +(define-syntax the-e 321) +(test-arrows [xxx yy z] xxxyyz the-e) + +(let () + (define-syntax the-e 321) + (test-arrows [xxx yy z] xxxyyz the-e)) + +;; Does not work. I suspect that the 'sub-range-binders must have the exact same +;; scope as the bound identifier, but `let` introduces new scopes that the +;; identifiers within sub-range-binders won't have. +(define-syntax (test-hyphen-let stx) + (syntax-case stx () + [(_ [a ...] b) + #`(let () + #,(with-sub-range-binders + #`(begin + (define #,(apply format-id/record + (car (syntax->list #'(a ...))) + (string-join (map (const "~a") + (syntax->list #'(a ...))) + "-") + (syntax->list #'(a ...))) + 123) + (check-equal? b 123))))])) + +(test-hyphen-let [a b c xyz2] a-b-c-xyz2) + +(define-syntax (test-fmt stx) + (syntax-case stx () + [(_ fmt [a b c] d) + (with-sub-range-binders + #`(begin (define #,(format-id/record #'fmt #'fmt #'a #'b #'c) + 9) + (check-equal? d 9)))])) + +;; Draws the following arrows: +;; w→w 1→1 x~~x→x~x 2→2 y→y 3→3 z→z +;; Nothing drawn from or to the "~a" themselves. +(test-fmt "w~ax~~x~ay~az" [1 2 3] w1x~x2y3z) \ No newline at end of file diff --git a/test/test-ids.rkt b/test/test-ids.rkt new file mode 100644 index 0000000..aa2d5bc --- /dev/null +++ b/test/test-ids.rkt @@ -0,0 +1,58 @@ +#lang racket + +(require "../typed-untyped.rkt") +(define-typed/untyped-test-module + (require-typed/untyped phc-toolkit/ids) + (require-typed/untyped phc-toolkit/typed-rackunit) + (require (for-syntax racket/syntax + phc-toolkit/untyped/ids)) + + (check-equal?: (format-ids #'a "~a-~a" #'() #'()) + '()) + + (check-equal?: (map syntax->datum + (format-ids #'a "~a-~a" #'(x1 x2 x3) #'(a b c))) + '(x1-a x2-b x3-c)) + + ;; Since the presence of "Syntax" in the parameters list makes format-ids + ;; require a chaperone contract instead of a flat contract, we can't run the + ;; two tests below directly, we would need to require the untyped version of + ;; this file, which causes a cycle in loading. + + (define-syntax (test1 stx) + (syntax-case stx () + [(_ (let1 d1) x y) + (begin + (define/with-syntax (foo-x foo-y) + (format-ids (λ (xy) + (if (string=? (symbol->string (syntax->datum xy)) + "b") + stx + #'())) + "foo-~a" + #'(x y))) + #'(let1 d1 (let ((foo-b 2) (foo-c 'b)) (cons foo-x foo-y))))])) + + (check-equal?: (test1 (let ((foo-b 1) (foo-c 'a))) b c) + '(1 . b)) + + (define-syntax (fubar stx) + (define/with-syntax (v1 ...) #'(1 2 3)) + (define/with-syntax (v2 ...) #'('a 'b 'c)) + ;; the resulting ab and ab should be distinct identifiers: + (define/with-syntax (id1 ...) (format-temp-ids "~a" #'(ab cd ab))) + (define/with-syntax (id2 ...) (format-temp-ids "~a" #'(ab cd ab))) + #'(let ([id1 v1] ...) + (let ([id2 v2] ...) + (list (cons id1 id2) ...)))) + + (check-equal?: (fubar) '((1 . a) (2 . b) (3 . c))) + + (define-syntax (test-concise stx) + (syntax-case stx () + [(_ a ...) + (let () + (define-temp-ids #:concise "~a!" (a ...)) + #''(a! ...))])) + (check-equal? (test-concise one "two" 3) + '(one! two! 3!))) \ No newline at end of file diff --git a/test/test-stx.rkt b/test/test-stx.rkt new file mode 100644 index 0000000..3a62338 --- /dev/null +++ b/test/test-stx.rkt @@ -0,0 +1,99 @@ +#lang typed/racket +(require "../typed-untyped.rkt") +(define-typed/untyped-test-module + (require-typed/untyped "../typed-rackunit.rkt" + "../typed-rackunit-extensions.rkt" + "../stx.rkt") + + (check-ann #'() (Stx-List? (Syntaxof Number))) + (check-ann #'(1) (Stx-List? (Syntaxof Number))) + (check-ann #'(1 2 3) (Stx-List? (Syntaxof Number))) + (check-ann #'(1 2 . ()) (Stx-List? (Syntaxof Number))) + (check-ann #'(1 . (2 . (3 . ()))) (Stx-List? (Syntaxof Number))) + (check-ann #'(1 . (2 3 . ())) (Stx-List? (Syntaxof Number))) + (check-ann #'(1 2 . (3 4 . (5))) (Stx-List? (Syntaxof Number))) + + (test-begin + (check-equal?: (match #'(1 2 3) + [(stx-list a b c) (list (syntax-e c) + (syntax-e b) + (syntax-e a))]) + '(3 2 1)) + + (check-equal?: (match #'(1 2 3) + [(stx-list a ...) (map (inst syntax-e Positive-Byte) a)]) + '(1 2 3)) + + #;(check-equal?: (match #`(1 . (2 3)) + [(stx-list a b c) (list (syntax-e c) + (syntax-e b) + (syntax-e a))]) + '(3 2 1))) + + (test-begin + (check-equal? (match #'x [(stx-e s) s]) 'x) + (check-equal? (match #'(x . y) [(stx-e (cons a b)) (cons (syntax-e b) + (syntax-e a))]) + '(y . x))) + + (test-begin + (check-equal? (match #'(x . y) [(stx-pair a b) (cons (syntax-e b) + (syntax-e a))]) + '(y . x)) + (check-equal? (match #'(x y z) [(stx-pair a b) (cons (map syntax->datum b) + (syntax->datum a))]) + '((y z) . x))) + + (test-begin + (check-equal? (stx-null? #f) #f) + (check-equal? (stx-null? 'a) #f) + (check-equal? (stx-null? '()) #t) + (check-equal? (stx-null? #'()) #t) + (check-equal? (stx-null? #''()) #f) + (check-equal? (stx-null? #'a) #f)) + + (test-begin + (check-equal? (syntax->datum + (ann (stx-cons #'a #'(b c)) + (Syntaxof (Pairof (Syntaxof 'a) + (Syntaxof (List (Syntaxof 'b) + (Syntaxof 'c))))))) + '(a b c)) + + (check-equal? (syntax->datum + (ann (stx-cons #'1 (ann #'2 (Syntaxof 2))) + (Syntaxof (Pairof (Syntaxof 1) + (Syntaxof 2))))) + '(1 . 2))) + + (test-begin + (let ((y 3)) + (check-equal? (nameof y) 'y))) + + (define-syntax (skip<6.6 stx) + (syntax-case stx () + [(_ . rest) + (if (or (regexp-match #px"^6(\\.[012345](\\..*|)|)$" (version)) + (regexp-match #px"^[123245]\\..*$" (version))) + #'(begin) + #'(begin . rest))])) + (skip<6.6 + (test-begin + (check-ann (stx-e #'(a . b)) + (Pairof (Syntaxof 'a) (Syntaxof 'b))) + + (check-ann (stx-e `(,#'a . ,#'b)) + (Pairof (Syntaxof 'a) (Syntaxof 'b))) + + (check-ann (stx-e '(a . b)) + (Pairof 'a 'b)) + + (check-ann (stx-e #'(a b . (c d))) + (List* (Syntaxof 'a) (Syntaxof 'b) + (Syntaxof (List (Syntaxof 'c) + (Syntaxof 'd))))) + + (check-ann (stx-e `(,#'a ,#'b . ,#'(c d))) + (List* (Syntaxof 'a) (Syntaxof 'b) + (Syntaxof (List (Syntaxof 'c) + (Syntaxof 'd)))))))) \ No newline at end of file diff --git a/test/test-syntax-parse.rkt b/test/test-syntax-parse.rkt new file mode 100644 index 0000000..1299227 --- /dev/null +++ b/test/test-syntax-parse.rkt @@ -0,0 +1,72 @@ +#lang racket + +(require "../untyped-only/syntax-parse.rkt" + syntax/parse + rackunit + syntax/macro-testing + (for-syntax racket/match)) + +(check-equal? (map syntax->datum + (syntax-case #'(1 2 3) () + [(x ...) (attribute* x)])) + '(1 2 3)) + +(check-equal? (map syntax->datum + (syntax-parse #'(1 2 3) + [(x ...) (attribute* x)])) + '(1 2 3)) + +(check-exn #rx"not bound as an attribute or pattern variable" + (λ () + (convert-compile-time-error + (let ([x #'(1 2 3)]) + (attribute* x))))) + +(define-syntax-class stxclass + (pattern foo)) +(check-true + (syntax-parse #'(1 2 3) + [(a ... sc:stxclass) + #:attr b 42 + (syntax-case #'(4 5 6) () + [(c ...) + (let () + (define-syntax (tst stx) + #`#,(match (list (attribute-info #'a) + (attribute-info #'sc) + (attribute-info #'sc.foo) + (attribute-info #'b) + (attribute-info #'c) + ; + (attribute-info #'a '(pvar)) + (attribute-info #'sc '(pvar)) + (attribute-info #'sc.foo '(pvar)) + (attribute-info #'b '(pvar)) + (attribute-info #'c '(pvar)) + ; + (attribute-info #'a '(attr) #f) + (attribute-info #'sc '(attr) #f) + (attribute-info #'sc.foo '(attr) #f) + (attribute-info #'b '(attr) #f) + (attribute-info #'c '(attr) #f)) + [(list (list 'attr _ 1 'a #t) + (list 'attr _ 0 'sc #t) + (list 'attr _ 0 'sc.foo #t) + (list 'attr _ 0 'b #f) + (list 'pvar _ 1) + ; + (list 'pvar _ 1) + (list 'pvar _ 0) + (list 'pvar _ 0) + (list 'pvar _ 0) + (list 'pvar _ 1) + ; + (list 'attr _ 1 'a #t) + (list 'attr _ 0 'sc #t) + (list 'attr _ 0 'sc.foo #t) + (list 'attr _ 0 'b #f) + #f) + #t] + [_ + #f])) + tst)])])) \ No newline at end of file diff --git a/threading.rkt b/threading.rkt new file mode 100644 index 0000000..a434b2c --- /dev/null +++ b/threading.rkt @@ -0,0 +1,23 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + ;; raco pkg install alexis-util + ;; or: + ;; raco pkg install threading + (require alexis/util/threading + (for-syntax racket/syntax + syntax/parse)) + + (define-syntax-rule (~>_ clause ... expr) (~> expr clause ...)) + (define-syntax (<~ stx) + (syntax-parse stx + [(_ expr clause ...) + (define/with-syntax (r-clause ...) + (reverse (syntax->list #'(clause ...)))) + #'(~> expr r-clause ...)])) + + (define-syntax-rule (<~_ clause ... expr) (<~ expr clause ...)) + + (provide <~ <~_ ~>_ + (rename-out [_ ♦] [<~_ <~♦] [~>_ ~>♦]) + (all-from-out alexis/util/threading))) \ No newline at end of file diff --git a/tmpl-multiassoc-syntax.rkt b/tmpl-multiassoc-syntax.rkt new file mode 100644 index 0000000..1c78d4f --- /dev/null +++ b/tmpl-multiassoc-syntax.rkt @@ -0,0 +1,25 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide tmpl-cdr-assoc-syntax + (rename-out [tmpl-cdr-assoc-syntax !cdr-assoc])) + + (module m-tmpl-cdr-assoc-syntax racket + (provide tmpl-cdr-assoc-syntax) + + (require syntax/parse + syntax/parse/experimental/template + (submod "stx.rkt" untyped) + (submod "multiassoc-syntax.rkt" untyped) + phc-toolkit/untyped/aliases) + + (define-template-metafunction (tmpl-cdr-assoc-syntax stx) + (syntax-parse stx + [(_ (~optional (~seq #:default default)) query [k . v] …) + (if (attribute default) + (let ([r (assoc-syntax #'query #'([k . v] …))]) + (if r + (stx-cdr r) + #'default)) + (cdr-assoc-syntax #'query #'([k . v] …)))]))) + (require 'm-tmpl-cdr-assoc-syntax)) \ No newline at end of file diff --git a/tmpl.rkt b/tmpl.rkt new file mode 100644 index 0000000..ade54aa --- /dev/null +++ b/tmpl.rkt @@ -0,0 +1,14 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide !each) + + (module m-!each racket + (provide !each) + (require syntax/parse/experimental/template) + + (define-template-metafunction (!each stx) + (syntax-case stx () + [(_ a b) #'b]))) + + (require 'm-!each)) \ No newline at end of file diff --git a/todo.rkt b/todo.rkt new file mode 100644 index 0000000..080967b --- /dev/null +++ b/todo.rkt @@ -0,0 +1,15 @@ +#lang racket + +(module m racket + (require syntax/parse + syntax/parse/experimental/template) + (provide (rename-out [template syntax] + [quasitemplate quasisyntax]) + (all-from-out syntax/parse + syntax/parse/experimental/template))) + +(require 'm) + +(syntax-parse #'(a b) + [(x (~optional y) z) + #'(x (?? y 1) z)]) \ No newline at end of file diff --git a/type-inference-helpers.rkt b/type-inference-helpers.rkt new file mode 100644 index 0000000..5fdad06 --- /dev/null +++ b/type-inference-helpers.rkt @@ -0,0 +1,50 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide cars cdrs lists maybe-vector->list) + + #| + ;; This does not work, in the end. + (provide imap) + (define-syntax (imap stx) + (syntax-parse stx + [(_ lst:expr var:id (~optional (~literal →)) . body) + #'(let () + (define #:∀ (T) (inlined-map [l : (Listof T)]) + (if (null? l) + '() + (cons (let ([var (car l)]) . body) + (inlined-map (cdr l))))) + (inlined-map lst))])) + |# + + (: cars (∀ (A) (→ (Listof (Pairof A Any)) (Listof A)))) + (define (cars l) ((inst map A (Pairof A Any)) car l)) + + (: cdrs (∀ (B) (→ (Listof (Pairof Any B)) (Listof B)))) + (define (cdrs l) ((inst map B (Pairof Any B)) cdr l)) + + (: lists (∀ (A) (→ (Listof A) (Listof (List A))))) + (define (lists l) ((inst map (List A) A) (λ (x) (list x)) l)) + + (module m-maybe-vector->list racket/base + (provide maybe-vector->list) + (define (maybe-vector->list v) + (if (vector? v) + (vector->list v) + #f))) + + (require (only-in typed/racket/unsafe unsafe-require/typed) + "typed-untyped.rkt") + (if-typed + (unsafe-require/typed 'm-maybe-vector->list + [maybe-vector->list (→ Any (U (Listof Any) #f))]) + (require 'm-maybe-vector->list)) + + (when-typed + (require type-expander) + (provide maybe-apply-type) + (define-type-expander (maybe-apply-type stx) + (syntax-case stx () + [(_ τ) #'τ] + [(_ τ . args) #'(τ . args)])))) \ No newline at end of file diff --git a/typed-rackunit-extensions.rkt b/typed-rackunit-extensions.rkt new file mode 100644 index 0000000..e9eeb94 --- /dev/null +++ b/typed-rackunit-extensions.rkt @@ -0,0 +1,145 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + (provide check-equal?-classes + check-equal?-classes: + check-tc + check-not-tc + check-ann + (for-syntax eval-tc)) + + (require "typed-untyped.rkt") + (require-typed/untyped "syntax-parse.rkt" + "sequence.rkt" + "typed-rackunit.rkt") + + (require (for-syntax syntax/parse + syntax/parse/experimental/template + racket/syntax + type-expander/expander + phc-toolkit/untyped/aliases + (submod "syntax-parse.rkt" untyped) + (submod "repeat-stx.rkt" untyped) + (submod "stx.rkt" untyped)) + typed/rackunit) + + + + (define-syntax/parse (check-ann value type:type-expand! (~optional message)) + (quasitemplate + ((λ _ (void)) (ann value type.expanded)))) + + (: check-equal?-classes (∀ (A ...) (→ (Pairof String (Listof A)) ... Void))) + (define (check-equal?-classes . classes) + (for* ([(head tail) (in-split* classes)]) + (let ([this-class (sequence-ref tail 0)] + [different-classes (in-sequences head (sequence-tail tail 1))]) + (for ([val (cdr this-class)]) + (for ([other-val (cdr this-class)]) + #;(displayln (format "Test ~a ∈ ~a = ~a ∈ ~a …" + val + (car this-class) + other-val + (car this-class))) + (check-equal?: val other-val + (format "Test ~a ∈ ~a = ~a ∈ ~a failed." + val + (car this-class) + other-val + (car this-class)))) + (for ([different-class different-classes]) + (for ([different-val (cdr different-class)]) + #;(displayln (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a …" + val + (car this-class) + different-val + (car different-class) + (map (λ ([c : (Pairof String Any)]) + (car c)) + (sequence->list + different-classes)))) + (check-not-equal?: val different-val + (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a failed." + val + (car this-class) + different-val + (car different-class) + (map (λ ([c : (Pairof String Any)]) + (car c)) + (sequence->list + different-classes)))))))))) + + (define-syntax/parse + (check-equal?-classes: + [{~maybe #:name {~or name:str name-id:id}} + ;; TODO: should be {~lit :), but still accept the ":" + ;; from type-expander + {~maybe :colon c-type:type-expand!} + {~and {~or {~seq single-val-id:id {~maybe {~lit :} _}} + {~seq _ …}} + {~seq {~seq val {~maybe :colon v-type:type-expand!}} …}}] + …) + (define/with-syntax ([a-val …] …) + (template ([(?? (ann val v-type.expanded) val) …] …))) + (define/with-syntax ([aa-val …] …) + (let () + ;; TODO: this is ugly, repeat-stx should handle missing stuff instead. + (define/with-syntax (xx-c-type …) + (template ((?? (c-type.expanded) ()) …))) + (syntax-parse (repeat-stx (xx-c-type …) ([val …] …)) + [([({~optional c-type-rep}) …] …) + (template ([(?? (ann a-val c-type-rep) a-val) …] …))]))) + (template + (check-equal?-classes (list (?? (?? name (symbol->string 'name-id)) + (?? (symbol->string 'single-val-id) "")) + aa-val …) …))) + + + ;; check-tc and check-not-tc + (begin + ;; Adapted from https://github.com/racket/typed-racket/issues/87 + (define-for-syntax (eval-tc checker expr [loc-stx #f]) + (quasisyntax/top-loc (or loc-stx #'here) + (begin + (: ns-anchor Namespace-Anchor) + (define-namespace-anchor ns-anchor) + #,(checker (quasisyntax/top-loc loc-stx + (λ () + (define output (open-output-string)) + (parameterize ([current-output-port output]) + (eval `(#%top-interaction . #,expr) + (namespace-anchor->namespace ns-anchor))) + (get-output-string output))))))) + + (define-syntax (check-tc stx) + (eval-tc (λ (f) (quasisyntax/top-loc stx + (check-not-exn #,f))) + (syntax-case stx () + [(_ body0) #'body0] + [(_ . body) (syntax/top-loc stx + (begin . body))]) + stx)) + + (define-for-syntax tc-error-regexp + (pregexp + (string-append + "Type Checker: (" + "type mismatch" + "|Polymorphic function .*could not be applied to arguments)"))) + (define-syntax check-not-tc + (syntax-parser + [(_ (~optional (~seq #:message-regexp message-regexp) + #:defaults ([message-regexp #`#,tc-error-regexp])) + . (~or (body₀) body*)) + (eval-tc (λ (code) (quasisyntax/top-loc this-syntax + (check-exn: + (λ (ex) + (and (exn:fail:syntax? ex) + (regexp-match? message-regexp + (exn-message ex)))) + #,code))) + (if (attribute body₀) + #'body₀ + (syntax/top-loc this-syntax + (begin . body*))) + this-syntax)])))) \ No newline at end of file diff --git a/typed-rackunit.rkt b/typed-rackunit.rkt new file mode 100644 index 0000000..dbe4465 --- /dev/null +++ b/typed-rackunit.rkt @@ -0,0 +1,171 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules #:no-test + ;; TODO: these won't expand types in the ann. + (provide check-equal?: + check-eq?: + check-true: + check-not-false: + check-false: + check-not-equal?: + check-exn: + check-not-exn:) + + (require "typed-untyped.rkt" + (for-syntax type-expander/expander)) + + (require/typed rackunit + [(check-true untyped:check-true) + (->* (Any) (String) Any)] + [(check-exn untyped:check-exn) + (->* ((U Regexp (→ Any Any)) (→ Any)) (String) Any)] + [(check-not-exn untyped:check-not-exn) + (->* ((→ Any)) (String) Any)] + [#:struct check-info ([name : Symbol] [value : Any])] + [make-check-info (→ Symbol Any check-info)] + [make-check-location (→ (List Any + (U Number False) + (U Number False) + (U Number False) + (U Number False)) + check-info)] + [make-check-name (→ Any check-info)] + [make-check-params (→ Any check-info)] + [make-check-actual (→ Any check-info)] + [make-check-expected (→ Any check-info)] + [make-check-expression (→ Any check-info)] + [make-check-message (→ Any check-info)] + [with-check-info* (→ (Listof check-info) (→ Any) Any)]) + (require (only-in typed/rackunit check-exn check-not-exn)) + + (require (for-syntax syntax/parse + syntax/parse/experimental/template)) + (require-typed/untyped "syntax-parse.rkt") + + (define-syntax/parse + (check-equal?: actual + (~optional (~seq (~datum :) type:type-expand!)) + expected + (~optional message:expr)) + (quasitemplate + (with-check-info* (list (make-check-actual (format "~s" actual)) + (make-check-expected (format "~s" expected)) + (make-check-name 'check-equal?:) + (make-check-params + (format "~s" `(,actual (?? 'type) ,expected))) + (make-check-location '(#,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx))) + (make-check-expression '#,(syntax->datum stx))) + (λ () + (untyped:check-true + (equal? (?? (ann actual type.expanded) actual) + expected)))))) + + ;; TODO: factor out some of this code. + (define-syntax/parse + (check-eq?: actual + (~optional (~seq (~datum :) type:type-expand!)) + expected + (~optional message:expr)) + (quasitemplate + (with-check-info* (list (make-check-actual (format "~s" actual)) + (make-check-expected (format "~s" expected)) + (make-check-name 'check-eq?:) + (make-check-params + (format "~s" `(,actual (?? 'type) ,expected))) + (make-check-location '(#,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx))) + (make-check-expression '#,(syntax->datum stx))) + (λ () + (untyped:check-true + (eq? (?? (ann actual type.expanded) actual) + expected)))))) + + (define-syntax-rule (define-check-1 name process) + (define-syntax/parse (name actual (~optional message:expr)) + (quasitemplate + (with-check-info* (list (make-check-actual (format "~s" actual)) + (make-check-expected (format "~s" #t)) + (make-check-name 'name) + (make-check-params + (format "~s" `(,actual))) + (make-check-location '(#,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx))) + (make-check-expression '#,(syntax->datum stx))) + (λ () + (untyped:check-true (process actual))))))) + + (define-check-1 check-true: identity) + (define-check-1 check-not-false: (λ (v) (not (not v)))) + (define-check-1 check-false: not) + + (define-syntax/parse + (check-not-equal?: actual + (~optional (~seq (~datum :) type:type-expand!)) + expected + (~optional message)) + (quasitemplate + (with-check-info* (list (make-check-actual (format "~s" actual)) + (make-check-expected (format "~s" expected)) + (make-check-name 'check-not-equal?:) + (make-check-params + (format "~s" `(,actual (?? 'type) ,expected))) + (make-check-location '(#,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx))) + (make-check-expression '#,(syntax->datum stx))) + (λ () + (untyped:check-true + (not (equal? (?? (ann actual type.expanded) actual) + expected))))))) + + (define-syntax/parse + (check-exn: exn-predicate-or-regexp:expr + thunk + (~optional message:expr)) + (quasitemplate + (with-check-info* (list (make-check-name 'check-eq?:) + (make-check-location '(#,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx))) + (make-check-params + (list exn-predicate-or-regexp thunk)) + (?? (make-check-message message)) + (make-check-expression '#,(syntax->datum stx))) + (λ () + (untyped:check-exn + exn-predicate-or-regexp + thunk + (?? message)))))) + + (define-syntax/parse + (check-not-exn: thunk + (~optional message:expr)) + (quasitemplate + (with-check-info* (list (make-check-name 'check-eq?:) + (make-check-location '(#,(syntax-source stx) + #,(syntax-line stx) + #,(syntax-column stx) + #,(syntax-position stx) + #,(syntax-span stx))) + (make-check-params + (list thunk)) + (?? (make-check-message message)) + (make-check-expression '#,(syntax->datum stx))) + (λ () + (untyped:check-not-exn + thunk + (?? message))))))) \ No newline at end of file diff --git a/typed-untyped.rkt b/typed-untyped.rkt new file mode 100644 index 0000000..02e3fab --- /dev/null +++ b/typed-untyped.rkt @@ -0,0 +1,230 @@ +#lang racket + +(provide ;typed/untyped + require-typed/untyped-typed + require-typed/untyped + require/provide-typed/untyped + define-typed/untyped-modules + define-typed/untyped-light-modules + define-typed/untyped-test-module + if-typed + when-typed + when-untyped) + +(require typed/untyped-utils + racket/require-syntax + (for-syntax syntax/parse + racket/syntax + syntax/stx + syntax/strip-context)) + +(module m-typed typed/racket + (provide (rename-out [require tr:require] + [provide tr:provide]) + ;typed/untyped + #;require-typed/untyped) + + #;(require (for-syntax syntax/parse + racket/syntax + syntax/stx + syntax/strip-context) + racket/require-syntax) + + + + #;(define-syntax (require-typed/untyped stx) + (syntax-case stx () + [(_ m) + (let () + (define/with-syntax sb (datum->syntax #'m 'submod #'m #'m)) + (define/with-syntax ty (datum->syntax #'m 'typed #'m #'m)) + #'(require (sb m ty)))]))) + +#;(require 'm-typed) + +;; require +(define-syntax (require-typed/untyped-typed stx) + (syntax-parse stx + [(_ . (~and ms (m ...))) + (replace-context #'ms #'(require (submod m typed) ...))])) + +#;(define-require-syntax (typed/untyped-typed stx) + (syntax-case stx () + [(_ m) (replace-context stx #'(submod m typed))])) + +#;(define-require-syntax (typed/untyped-untyped stx) + (syntax-case stx () + [(_ m) (replace-context stx #'(submod m untyped))])) + +(define-syntax (require-typed/untyped-untyped stx) + (syntax-parse stx + [(_ . (~and ms (m ...))) + (replace-context #'ms #'(require (submod m untyped) ...))])) + +(define-typed/untyped-identifier require-typed/untyped + require-typed/untyped-typed + require-typed/untyped-untyped) + +#;(define-typed/untyped-identifier typed/untyped + typed/untyped-typed + typed/untyped-untyped) + +;; require/provide +;; TODO: make a require expander instead. +(define-syntax (require/provide-typed/untyped-typed stx) + (syntax-parse stx + [(_ . (~and ms (m ...))) + (replace-context #'ms + #'(begin + (require (submod m typed) ...) + (provide (all-from-out (submod m typed) ...))))])) + +(define-syntax (require/provide-typed/untyped-untyped stx) + (syntax-parse stx + [(_ . (~and ms (m ...))) + (replace-context #'ms + #'(begin + (require (submod m untyped) ...) + (provide (all-from-out (submod m untyped) ...))))])) + +(define-typed/untyped-identifier require/provide-typed/untyped + require/provide-typed/untyped-typed + require/provide-typed/untyped-untyped) + +#| +(module mt typed/racket + (define-syntax-rule (require/provide-typed/untyped m) + (require m)) + (provide require/provide-typed/untyped)) +(require 'mt) +|# + +;; define-typed/untyped-modules +(begin + (define-syntax (define-typed/untyped-modules stx) + (syntax-parse stx + [(def-t/u-mod (~optional (~and no-test #:no-test)) + (~optional (~and untyped-first #:untyped-first)) . body) + (define (ds sym) (datum->syntax #'def-t/u-mod sym #'def-t/u-mod)) + (define/with-syntax module-typed + #`(module #,(ds 'typed) #,(ds 'typed/racket) + . body)) + (define/with-syntax module-untyped + #`(module #,(ds 'untyped) #,(ds 'typed/racket/no-check) + #,(ds '(require (for-syntax racket/base))) + . body)) + #`(begin + #,(if (attribute untyped-first) #'module-untyped #'module-typed) + #,(if (attribute untyped-first) #'module-typed #'module-untyped) + #,@(if (attribute no-test) + #'() + #`((module #,(ds 'test) #,(ds 'typed/racket) + #,(ds `(require (submod ".." typed test))) + #,(ds `(require (submod ".." untyped test)))))) + #,(ds '(require 'typed)) + #,(ds '(provide (all-from-out 'typed))))])) + + (define-syntax (define-typed/untyped-light-modules stx) + (syntax-parse stx + [(def-t/u-mod (~optional (~and no-test #:no-test)) + (~optional (~and untyped-first #:untyped-first)) . body) + (define (ds sym) (datum->syntax #'def-t/u-mod sym #'def-t/u-mod)) + (define/with-syntax module-typed + #`(module #,(ds 'typed) #,(ds 'typed/racket) + . body)) + (define/with-syntax module-untyped + #`(module #,(ds 'untyped) #,(ds 'racket/base) + #,(ds '(require (for-syntax racket/base))) + . body)) + #`(begin + #,(if (attribute untyped-first) #'module-untyped #'module-typed) + #,(if (attribute untyped-first) #'module-typed #'module-untyped) + #,@(if (attribute no-test) + #'() + #`((module #,(ds 'test) #,(ds 'typed/racket) + #,(ds `(require (submod ".." typed test))) + #,(ds `(require (submod ".." untyped test)))))) + #,(ds '(require 'typed)) + #,(ds '(provide (all-from-out 'typed))))])) + + (define-syntax (define-typed/untyped-test-module stx) + (syntax-parse stx + [(def-t/u-t-mod (~optional (~and untyped-first #:untyped-first)) . body) + (define (ds sym) (datum->syntax #'def-t/u-t-mod sym #'def-t/u-t-mod)) + (define/with-syntax module-typed + #`(module #,(ds 'typed-test) #,(ds 'typed/racket) + #,(ds '(require typed/rackunit + "../typed-untyped.rkt")) + . body)) + (define/with-syntax module-untyped + #`(module #,(ds 'untyped-test) #,(ds 'typed/racket/no-check) + #,(ds '(require (for-syntax racket/base) + rackunit + "../typed-untyped.rkt")) + . body)) + #`(begin + #,(if (attribute untyped-first) #'module-untyped #'module-typed) + #,(if (attribute untyped-first) #'module-typed #'module-untyped) + (module #,(ds 'test) #,(ds 'typed/racket) + #,(ds `(require (submod ".." typed-test))) + #,(ds `(require (submod ".." untyped-test)))) + #,(ds '(require 'typed-test)) + #,(ds '(provide (all-from-out 'typed-test))))])) + + #| ;; test: should work in no-check but not in typed: + (define-typed/untyped-modules moo + (: foo One) + (define foo 2)) + |#) + +;; if-typed +(define-syntax-rule (if-typed-typed t u) t) +(define-syntax-rule (if-typed-untyped t u) u) +(define-typed/untyped-identifier if-typed + if-typed-typed + if-typed-untyped) + +;; when-typed and when-untyped +(define-syntax-rule (when-typed . t) (if-typed (begin . t) (begin))) +(define-syntax-rule (when-untyped . t) (if-typed (begin) (begin . t))) + +;; typed/untyped-prefix +(begin + (define-syntax-rule (typed/untyped-prefix [typed-prefix ...] + [untyped-prefix ...] + . rest) + (if-typed (typed-prefix ... . rest) + (untyped-prefix ... . rest))) + #| + ;; test: should work in no-check but not in typed: + (typed/untyped-prefix + [module moo2 typed/racket] + [module moo2 typed/racket/no-check] + (: foo One) + (define foo 2)) + |#) + +;; define-modules +(begin + ;; define-modules + (define-syntax define-modules + (syntax-rules (no-submodule) + [(_ ([no-submodule] [name lang] ...) . body) + (begin (begin . body) + (module name lang . body) ...)] + [(_ ([name lang] ...) . body) + (begin (module name lang . body) ...)])) + + #| + ;; TODO: tests: test with a macro and check that we can use it in untyped. + ;; TODO: tests: test with two mini-languages with different semantics for some + ;; function. + (define-modules ([foo typed/racket] [foo-untyped typed/racket/no-check]) + (provide x) + (: x (→ Syntax Syntax)) + (define (x s) s)) + + (module test racket + (require (submod ".." foo-untyped)) + (x #'a)) + |#) \ No newline at end of file diff --git a/unstable.rkt b/unstable.rkt new file mode 100644 index 0000000..7cc075c --- /dev/null +++ b/unstable.rkt @@ -0,0 +1,148 @@ +#lang typed/racket + +(require phc-toolkit) +(require "eval-get-values.rkt") + +(provide (all-from-out phc-toolkit) + (all-from-out "eval-get-values.rkt")) + +;; Types +(provide AnyImmutable) +;; Functions +(provide (rename-out [∘ compose])) +;; Macros +;(provide mapp) +(provide comment) + +(require (for-syntax syntax/parse + racket/syntax)) + +(define-syntax (comment stx) + #'(values)) + +(define-type AnyImmutable (U Number + Boolean + True + False + String + Keyword + Symbol + Char + Void + ;Input-Port ;; Not quite mutable, nor immutable. + ;Output-Port ;; Not quite mutable, nor immutable. + ;Port ;; Not quite mutable, nor immutable. + + ;; I haven't checked the mutability of the ones + ;; inside in the #||# comments below + #| + Path + Path-For-Some-System + Regexp + PRegexp + Byte-Regexp + Byte-PRegexp + Bytes + Namespace + Namespace-Anchor + Variable-Reference + |# + Null + #| + EOF + Continuation-Mark-Set + |# + ;; We definitely don't Undefined, it's not mutable + ;; but it's an error if present anywhere 99.9% of + ;; the time. Typed/racket is moving towards making + ;; occurrences of this type an error, anyway. + ; Undefined + #| + Module-Path + Module-Path-Index + Resolved-Module-Path + Compiled-Module-Expression + Compiled-Expression + Internal-Definition-Context + Pretty-Print-Style-Table + Special-Comment + Struct-Type-Property + Impersonator-Property + Read-Table + Bytes-Converter + Parameterization + Custodian + Inspector + Security-Guard + UDP-Socket ;; Probably not + TCP-Listener ;; Probably not + Logger ;; Probably not + Log-Receiver ;; Probably not + Log-Level + Thread + Thread-Group + Subprocess + Place + Place-Channel + Semaphore ;; Probably not + FSemaphore ;; Probably not + Will-Executor + Pseudo-Random-Generator + Path-String + |# + (Pairof AnyImmutable AnyImmutable) + (Listof AnyImmutable) + ; Plus many others, not added yet. + ;; Don't include closures, because they can contain + ;; mutable variables, and we can't eq? them. + ; -> + ; maybe Prefab? Or are they mutable? + )) + +#| +(define-syntax (mapp stx) + (syntax-parse stx + [(_ var:id lst:expr body ...) + #'(let ((l lst)) + (if (null? l) + '() + (let ((result (list (let ((var (car l))) + body ...)))) + (set! l (cdr l)) + (do ([stop : Boolean #f]) + (stop (reverse result)) + (if (null? l) + (set! stop #t) + (begin + (set! result + (cons (let ((var (car l))) + body ...) + result)) + (set! l (cdr l))))))))])) +|# + + +;; TODO: this does not work, because Null is (Listof Any) +; (mapp x (cdr '(1)) (* x x)) + +;; TODO: foldll +(define-syntax (foldll stx) + (syntax-parse stx + [(_ var:id acc:id lst:expr init:expr body ...) + #'(let ((l lst)) + (if (null? l) + '() + (let ((result (list (let ((var (car l))) + body ...)))) + (set! l (cdr l)) + (do ([stop : Boolean #f]) + (stop (reverse result)) + (if (null? l) + (set! stop #t) + (begin + (set! result + (cons (let ((var (car l))) + body ...) + result)) + (set! l (cdr l))))))))])) + diff --git a/untyped-only.rkt b/untyped-only.rkt new file mode 100644 index 0000000..f2ed054 --- /dev/null +++ b/untyped-only.rkt @@ -0,0 +1,3 @@ +#lang reprovide +"untyped/for-star-list-star.rkt" +"untyped/format-id-record.rkt" \ No newline at end of file diff --git a/untyped-only/for-star-list-star.rkt b/untyped-only/for-star-list-star.rkt new file mode 100644 index 0000000..6db7238 --- /dev/null +++ b/untyped-only/for-star-list-star.rkt @@ -0,0 +1,71 @@ +#lang racket + +(provide for*/list*) + +(require (for-syntax syntax/parse)) + +(define-syntax (for*/list* stx) + (define-syntax-class sequences + #:description "([id seq-expr] ...) or (* [id seq-expr] ...)" + (pattern ((~optional (~and star (~datum *))) (id:id seq-expr:expr) ...) + #:with for-kind (if (attribute star) #'for*/list #'for/list))) + + (syntax-parse stx + [(_ [sequences:sequences ...] . body) + (foldl (λ (for-kind clauses acc) + #`(#,for-kind #,clauses #,acc)) + #'(let () . body) + (reverse (syntax-e #'(sequences.for-kind ...))) + (reverse (syntax-e #'(([sequences.id sequences.seq-expr] ...) + ...))))])) + +;; Test for*/list* +(module* test racket + (require rackunit) + (require (submod "..")) + (check-equal? (for*/list* [([x '(a b c)] + [y '(1 2 3)]) + (* [z '(d e f)] + [t '(4 5 6)])] + (list x y z t)) + '(((a 1 d 4) (a 1 d 5) (a 1 d 6) + (a 1 e 4) (a 1 e 5) (a 1 e 6) + (a 1 f 4) (a 1 f 5) (a 1 f 6)) + ((b 2 d 4) (b 2 d 5) (b 2 d 6) + (b 2 e 4) (b 2 e 5) (b 2 e 6) + (b 2 f 4) (b 2 f 5) (b 2 f 6)) + ((c 3 d 4) (c 3 d 5) (c 3 d 6) + (c 3 e 4) (c 3 e 5) (c 3 e 6) + (c 3 f 4) (c 3 f 5) (c 3 f 6)))) + (check-equal? (for*/list* [([x '(a b c)]) + ([y '(1 2 3)]) + (* [z '(d e f)] + [t '(4 5 6)])] + (list x y z t)) + '((((a 1 d 4) (a 1 d 5) (a 1 d 6) + (a 1 e 4) (a 1 e 5) (a 1 e 6) + (a 1 f 4) (a 1 f 5) (a 1 f 6)) + ((a 2 d 4) (a 2 d 5) (a 2 d 6) + (a 2 e 4) (a 2 e 5) (a 2 e 6) + (a 2 f 4) (a 2 f 5) (a 2 f 6)) + ((a 3 d 4) (a 3 d 5) (a 3 d 6) + (a 3 e 4) (a 3 e 5) (a 3 e 6) + (a 3 f 4) (a 3 f 5) (a 3 f 6))) + (((b 1 d 4) (b 1 d 5) (b 1 d 6) + (b 1 e 4) (b 1 e 5) (b 1 e 6) + (b 1 f 4) (b 1 f 5) (b 1 f 6)) + ((b 2 d 4) (b 2 d 5) (b 2 d 6) + (b 2 e 4) (b 2 e 5) (b 2 e 6) + (b 2 f 4) (b 2 f 5) (b 2 f 6)) + ((b 3 d 4) (b 3 d 5) (b 3 d 6) (b 3 e 4) + (b 3 e 5) (b 3 e 6) (b 3 f 4) + (b 3 f 5) (b 3 f 6))) + (((c 1 d 4) (c 1 d 5) (c 1 d 6) (c 1 e 4) + (c 1 e 5) (c 1 e 6) (c 1 f 4) + (c 1 f 5) (c 1 f 6)) + ((c 2 d 4) (c 2 d 5) (c 2 d 6) (c 2 e 4) + (c 2 e 5) (c 2 e 6) (c 2 f 4) + (c 2 f 5) (c 2 f 6)) + ((c 3 d 4) (c 3 d 5) (c 3 d 6) (c 3 e 4) + (c 3 e 5) (c 3 e 6) (c 3 f 4) + (c 3 f 5) (c 3 f 6)))))) \ No newline at end of file diff --git a/untyped-only/format-id-record.rkt b/untyped-only/format-id-record.rkt new file mode 100644 index 0000000..c46fb3a --- /dev/null +++ b/untyped-only/format-id-record.rkt @@ -0,0 +1,239 @@ +#lang racket/base + +(module m racket/base + (require racket/contract + racket/syntax + racket/stxparam + syntax/stx + syntax/parse + (submod "../syntax-parse.rkt" untyped) + (for-syntax racket/base)) + + (provide sub-range-binder/c + current-recorded-sub-range-binders + maybe-record-sub-range-binders! + record-sub-range-binders! + with-sub-range-binders + with-arrows + syntax-parser-with-arrows + format-id/record) + + (define sub-range-binder/c + (or/c (vector/c syntax? + exact-nonnegative-integer? exact-nonnegative-integer? + (real-in 0 1) (real-in 0 1) + syntax? + exact-nonnegative-integer? exact-nonnegative-integer? + (real-in 0 1) (real-in 0 1)) + (vector/c syntax? + exact-nonnegative-integer? exact-nonnegative-integer? + syntax? + exact-nonnegative-integer? exact-nonnegative-integer?))) + + (define/contract current-recorded-sub-range-binders + (parameter/c (or/c (listof sub-range-binder/c) false/c)) + (make-parameter #f)) + + ;; TODO: should use a parameter in addition to the error? argument. + (define/contract ((record-sub-range-binders/check! error?) sub-range-binders) + (-> boolean? + (-> (or/c sub-range-binder/c (listof sub-range-binder/c)) + void?)) + (if (current-recorded-sub-range-binders) + (if (list? sub-range-binders) + (current-recorded-sub-range-binders + (append sub-range-binders (current-recorded-sub-range-binders))) + (current-recorded-sub-range-binders + (cons sub-range-binders (current-recorded-sub-range-binders)))) + (when error? + (error + (format + (string-append "record-sub-range-binders should be used within the" + " dynamic extent of with-sub-range-binders," + " with-arrows or a similar form. Arguments were: ~a") + sub-range-binders))))) + + (define/contract maybe-record-sub-range-binders! + (-> (or/c sub-range-binder/c (listof sub-range-binder/c)) + void?) + (record-sub-range-binders/check! #f)) + + (define/contract record-sub-range-binders! + (-> (or/c sub-range-binder/c (listof sub-range-binder/c)) + void?) + (record-sub-range-binders/check! #t)) + + (define-syntax-rule (with-sub-range-binders . body) + (parameterize ([current-recorded-sub-range-binders '()]) + (syntax-property (let () . body) + 'sub-range-binders + (current-recorded-sub-range-binders)))) + + (define-syntax-rule (with-arrows . body) + (with-disappeared-uses + (with-sub-range-binders + . body))) + + (define-syntax-rule (syntax-parser-with-arrows . opts+clauses) + (λ (stx2) + (with-disappeared-uses + (with-sub-range-binders + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + ((syntax-parser . opts+clauses) stx2)))))) + + (define (identifier-length id) + (string-length (symbol->string (syntax-e id)))) + + (define (formatted-length v) + (identifier-length (format-id #f "~a" v))) + + (define (format-length fmt) + (identifier-length (format-id #f fmt))) + + (define/contract (format-id/record lctx + fmt + #:source [src #f] + #:props [props #f] + . vs) + ;; TODO: use check-restricted-format-string from racket/syntax.rkt + (->* {(or/c syntax? #f) + (or/c string? (syntax/c string?))} + {#:source (or/c syntax? #f) + #:props (or/c syntax? #f)} + #:rest (listof (or/c string? symbol? keyword? char? number? + (syntax/c string?) + identifier? + (syntax/c keyword?) + (syntax/c char?) + (syntax/c number?))) + identifier?) + + (define e-vs (stx-map (λ (v) (if (and (syntax? v) (not (identifier? v))) + (syntax-e v) + v)) + vs)) + (define str-fmt (if (syntax? fmt) (syntax-e fmt) fmt)) + (define whole (apply format-id lctx str-fmt e-vs + #:source src + #:props props)) + (define split-fmt (regexp-split #px"~[aA]" str-fmt)) + + ;; sub-range-binder for the first static part of the format + (when (syntax? fmt) + (record-sub-range-binders! + (vector (syntax-local-introduce whole) + 0 (format-length (car split-fmt)) + fmt + 1 (string-length (car split-fmt))))) ;; +1 for #\" + + (for/fold ([input-len (+ 1 (string-length (car split-fmt)))] ;; +1 for #\" + [output-len (string-length (car split-fmt))]) + ([v (in-list vs)] + [e-v (in-list e-vs)] + [fmt-part (cdr split-fmt)]) + (define v-len (formatted-length e-v)) + (define fmt-output-len (format-length fmt-part)) + (define fmt-input-len (string-length fmt-part)) + ;; sub-range binder for the ~a + (record-sub-range-binders! + (vector (syntax-local-introduce whole) + output-len v-len + v + 0 v-len)) + ;; sub-range-binder for the static part of the format + (when (syntax? fmt) + (record-sub-range-binders! + (vector (syntax-local-introduce whole) + (+ output-len v-len) fmt-output-len + fmt + (+ input-len 2) fmt-input-len))) ;; +2 for the "~a" + ;; loop with format-len and output-len = + (values (+ input-len 2 fmt-input-len) ;; +2 for the "~a" + (+ output-len v-len fmt-output-len))) + whole)) + +(module m2 racket/base + (require (for-syntax (submod ".." m) + phc-toolkit/untyped/aliases + syntax/parse + racket/function + syntax/stx + (only-in (submod "../stx.rkt" untyped) + remove-use-site-scope))) + (provide inject-sub-range-formats) + + (require racket/splicing + (for-syntax racket/base)) + + (define-syntax (inject-sub-range-formats stx) + ;; for some reason, callijng remove-use-site-scope on the whole stx object + ;; does not work. + (define clean-stx (remove-use-site-scope stx)) + (syntax-case stx (); parser + [(_ ([lctx fmt vs …] …) . body);(_ ([-lctx -fmt -vs …] …) . -body) + ;#:with (lctx …) (stx-map remove-use-site-scope #'(-lctx …)) + ;#:with (fmt …) (stx-map remove-use-site-scope #'(-fmt …)) + ;#:with ((vs …) …) (stx-map (curry stx-map remove-use-site-scope) + ; #'((-vs …) …)) + ;#:with body (remove-use-site-scope #'-body) + (remove-use-site-scope + #'(splicing-let-syntax + ([tmp (λ _ + (with-sub-range-binders + (format-id/record lctx fmt vs …) + … + (remove-use-site-scope + (syntax-local-introduce + (quote-syntax (begin . body))))))]) + (tmp)))]))) + +(module m3 racket/base + (require racket/require-syntax + (for-syntax racket/base + racket/list) + racket/stxparam + racket/syntax) + + (define-require-syntax (for-many stx) + (syntax-case stx () + [(_ require-spec ...) + #`(combine-in #,@(map (λ (n) #`(for-meta #,n require-spec ...)) + (range -16 17)))])) + ;; If the level 1 macro using with-format-ids/inject-binders places + ;; inject-sub-range-binders ... in a level 0 form, then 'm2 is needed + ;; for-template. However, if inject-sub-range-binders ... appears in + ;; a level 1 form, then 'm2 is needed for-meta 0. If + ;; inject-sub-range-binders ... appears in a level 2 form, then 'm2 is + ;; needed for-meta 1, etc. We therefore require it many times, for all + ;; meta-levels from -16 to 16, which should be plenty enough for all + ;; practical purposes. + (require (for-template (for-many (submod ".." m2)))) + + (provide with-format-ids/inject-binders + inject-sub-range-binders) + + (define-syntax (inject-sub-range-binders-init stx) + (raise-syntax-error 'inject-sub-range-binders + "must be used inside with-format-ids/inject" + stx)) + (define-rename-transformer-parameter inject-sub-range-binders + (make-rename-transformer #'inject-sub-range-binders-init)) + + (define-syntax-rule + (with-format-ids/inject-binders ([id lctx fmt vs ...] ...) . body) + (with-syntax + ([(fmts (... ...)) + #'(inject-sub-range-formats ([lctx fmt vs ...] ...))]) + (syntax-parameterize + ([inject-sub-range-binders (make-rename-transformer #'fmts)]) + (with-syntax ([id (format-id lctx fmt vs ...)] ...) + (let () + . body)))))) + +(require 'm + (for-template 'm2) + 'm3) + +(provide (all-from-out 'm) + (for-template inject-sub-range-formats) + (all-from-out 'm3)) \ No newline at end of file diff --git a/untyped-only/quasitemplate.rkt b/untyped-only/quasitemplate.rkt new file mode 100644 index 0000000..753dbdc --- /dev/null +++ b/untyped-only/quasitemplate.rkt @@ -0,0 +1,85 @@ +#lang racket + +(require syntax/parse/experimental/template + (for-syntax syntax/parse + racket/syntax)) + +(provide quasitemplate + (all-from-out syntax/parse/experimental/template)) + +;; subst-quasitemplate returns a stx-pair, with definitions for +;; with-syntax in the stx-car, and a template in the stx-cdr. +;; The template is either of the form ('eh-tmpl . tmpl), in which case it is an +;; ellipsis-head template, or of the form ('tmpl . tmpl), in which case it is +;; a regular template. + +;; Appending the stx-car from the two branches at each recursion step is +;; extremely inefficient (in the worst case O(n²)), so while gathering them, we +;; store them as a binary tree, and then we flatten it with flatten-defs. + +;; Note that quasitemplate can still take O(n²) time, because of ellipsis-head +;; templates which are not handled very efficiently. + +(define-for-syntax (flatten-defs stx acc) + (syntax-parse stx + [(l r) (flatten-defs #'r (flatten-defs #'l acc))] + [() acc] + [(def) #`(def . #,acc)])) + +;; There are two cases for the transformation of #,@(expr): +;; If it is in a car position, we write: +;; (with-syntax ([(tmp ...) expr]) (tmp ... . the-cdr)) +;; If it is in a cdr position, we write: +;; (with-syntax ([tmp expr]) (the-car . tmp)) +(define-for-syntax (subst-quasitemplate car? stx) + (syntax-parse stx #:literals (unsyntax unsyntax-splicing) + [(unsyntax expr) + (with-syntax ([tmp (gensym)]) + #`(([tmp expr]) . #,(if car? #'{tmp} #'tmp)))] + [(unsyntax-splicing expr) + (with-syntax ([tmp (gensym)]) + (if car? + #'(... (([(tmp ...) expr]) . {tmp ...})) + #'(([tmp expr]) . tmp)))] + [((unsyntax-splicing expr)) ;; In last position in a list + (if car? + #'(([tmp expr]) . {tmp}) + #'(([tmp expr]) . tmp))] + [(a . b) + (with-syntax ([(defs-a sa ...) (subst-quasitemplate #t #'a)] + [(defs-b . sb) (subst-quasitemplate #f #'b)]) + #`((defs-a defs-b) . #,(if car? #'{(sa ... . sb)} #'(sa ... . sb))))] + [x + #`(() . #,(if car? #'{x} #'x))])) + +(define-syntax (quasitemplate stx) + (syntax-parse stx + [(_ tmpl) + (with-syntax* ([(defs . new-tmpl) (subst-quasitemplate #f #'tmpl)] + [(flattened-defs ...) (flatten-defs #'defs #'())]) + #'(with-syntax (flattened-defs ...) + (template new-tmpl)))])) + +(module+ test + (require rackunit) + (define-syntax-rule (check . tmpl) + (check-equal? (syntax->datum (quasitemplate . tmpl)) + (syntax->datum (quasisyntax . tmpl)))) + + (check (a #,(+ 1 2))) + (check (a #,(+ 1 2) #,(+ 3 4))) + (check (a #,@(list 1 2) #,@(list 3 4))) + (check (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6))) + (check (a (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)) c)) + (check (a . (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)))) + (check (a (#,@(list 1 2) #,@(list 3 4) . #,(list* 5 6)))) + + (check (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6))) + (check (a (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)) c)) + (check (a . (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)))) + (check (a (#,@(list 1 2) #,@(list 3 4) #,@(list* 5 6)))) + (check (a #,@1)) + (check (a (#,@1))) + (check (a (#,@1) c)) + (check ((#,@1) b)) + (check ((#,@1) b))) \ No newline at end of file diff --git a/untyped-only/stx.rkt b/untyped-only/stx.rkt new file mode 100644 index 0000000..59f5235 --- /dev/null +++ b/untyped-only/stx.rkt @@ -0,0 +1,23 @@ +#lang racket/base + +(require (for-template racket/base) + (for-syntax racket/base) + "../stx/fold.rkt") + +(provide make-rest-transformer + make-id+call-transformer + make-id+call-transformer-delayed) + +(define (make-rest-transformer f) + (λ (stx) + (syntax-case stx () + [(_ . rest) (f #'rest)]))) + +(define (make-id+call-transformer-delayed stx-value) + (λ (stx) + (syntax-case stx () + [(_ . args) (quasisyntax/top-loc stx (#,(stx-value) . args))] + [id (identifier? #'id) (stx-value)]))) + +(define (make-id+call-transformer stx-value) + (make-id+call-transformer-delayed (λ () stx-value))) diff --git a/untyped-only/syntax-parse.rkt b/untyped-only/syntax-parse.rkt new file mode 100644 index 0000000..253b6d4 --- /dev/null +++ b/untyped-only/syntax-parse.rkt @@ -0,0 +1,92 @@ +#lang racket/base + +(require (for-syntax racket/base + racket/private/sc + racket/contract + racket/syntax) + syntax/parse + (prefix-in - syntax/parse/private/residual)) + +(provide attribute* + (for-syntax attribute-info) + define-raw-attribute + define-raw-syntax-mapping) + +(define-syntax (attribute* stx) + (syntax-case stx () + [(_ a) + (with-disappeared-uses + (let () + (record-disappeared-uses (list #'a)) + (let ([slv (syntax-local-value #'a (λ () #f))]) + (if (syntax-pattern-variable? slv) + (let* ([valvar (syntax-mapping-valvar slv)] + [valvar-slv (syntax-local-value valvar (λ () #f))]) + (if (-attribute-mapping? valvar-slv) + (-attribute-mapping-var valvar-slv) + valvar)) + (raise-syntax-error + 'attribute* + "not bound as an attribute or pattern variable" + stx + #'a)))))])) + +;; The "accept" parameter allows forwards compatibility: +;; if a new sort of syntax pattern variable is added, either it degrades +;; gracefully into one of the accepted kinds, or an error is raised. +;; The client does not have to deal with unknown cases, unless accept is #t. +(begin-for-syntax + (define/contract (attribute-info a [accept #t] [error? #t]) + (->* {identifier?} + {(or/c #t (listof symbol?)) + boolean?} + (or/c #f + (list/c 'attr + identifier? exact-nonnegative-integer? symbol? boolean?) + (list/c 'pvar + identifier? exact-nonnegative-integer?))) + (define slv (syntax-local-value a (λ () #f))) + ;; (assert (syntax-pattern-variable? slv)) + (define attr (and slv + (syntax-local-value (syntax-mapping-valvar slv) + (λ () #f)))) + (cond + [(and attr + (-attribute-mapping? attr) + (or (eq? #t accept) (and (list? accept) (memq 'attr accept)))) + (list 'attr + (-attribute-mapping-var attr) + (-attribute-mapping-depth attr) + (-attribute-mapping-name attr) + (-attribute-mapping-syntax? attr))] + [(and (syntax-pattern-variable? slv) + (or (eq? #t accept) (and (list? accept) (memq 'pvar accept)))) + (list 'pvar + (syntax-mapping-valvar slv) + (syntax-mapping-depth slv))] + [else + (when error? + (raise-syntax-error 'attribute-info + "not defined as an attribute or pattern variable" + a)) + #f]))) + +(define-syntax-rule (define-raw-attribute name valvar val depth syntax?) + (begin + (define valvar + val) + (define-syntax tmp-attr + (-make-attribute-mapping (quote-syntax valvar) + 'name + 'depth + 'syntax?)) + (define-syntax name + (make-syntax-mapping 'depth + (quote-syntax tmp-attr))))) + + (define-syntax-rule (define-raw-syntax-mapping name valvar val depth) + (begin + (define valvar + val) + (define-syntax name + (make-syntax-mapping 'depth (quote-syntax valvar))))) \ No newline at end of file diff --git a/untyped.rkt b/untyped.rkt new file mode 100644 index 0000000..1495afc --- /dev/null +++ b/untyped.rkt @@ -0,0 +1,4 @@ +#lang racket/base + +(require (submod "main.rkt" untyped)) +(provide (all-from-out (submod "main.rkt" untyped))) diff --git a/untyped/aliases.rkt b/untyped/aliases.rkt new file mode 100644 index 0000000..0d9656e --- /dev/null +++ b/untyped/aliases.rkt @@ -0,0 +1,4 @@ +#lang s-exp phc-toolkit/light-no-check +(require phc-toolkit/partial-include) +(require phc-toolkit/is-untyped) +(include-without-first-line up "aliases.rkt") \ No newline at end of file diff --git a/untyped/backtrace.rkt b/untyped/backtrace.rkt new file mode 100644 index 0000000..6bc952f --- /dev/null +++ b/untyped/backtrace.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../backtrace.rkt" untyped) diff --git a/untyped/compat.rkt b/untyped/compat.rkt new file mode 100644 index 0000000..b87b2cc --- /dev/null +++ b/untyped/compat.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../compat.rkt" untyped) diff --git a/untyped/cond-let.rkt b/untyped/cond-let.rkt new file mode 100644 index 0000000..0b60cce --- /dev/null +++ b/untyped/cond-let.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../cond-let.rkt" untyped) diff --git a/untyped/contract.rkt b/untyped/contract.rkt new file mode 100644 index 0000000..11e57d3 --- /dev/null +++ b/untyped/contract.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../contract.rkt" untyped) diff --git a/untyped/eval-get-values.rkt b/untyped/eval-get-values.rkt new file mode 100644 index 0000000..9962f60 --- /dev/null +++ b/untyped/eval-get-values.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../eval-get-values.rkt" untyped) diff --git a/untyped/fixnum.rkt b/untyped/fixnum.rkt new file mode 100644 index 0000000..bfb986f --- /dev/null +++ b/untyped/fixnum.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../fixnum.rkt" untyped) diff --git a/untyped/for-star-list-star.rkt b/untyped/for-star-list-star.rkt new file mode 100644 index 0000000..57beb8b --- /dev/null +++ b/untyped/for-star-list-star.rkt @@ -0,0 +1,2 @@ +#lang reprovide +"../untyped-only/for-star-list-star.rkt" diff --git a/untyped/format-id-record.rkt b/untyped/format-id-record.rkt new file mode 100644 index 0000000..26d9fed --- /dev/null +++ b/untyped/format-id-record.rkt @@ -0,0 +1,2 @@ +#lang reprovide +"../untyped-only/format-id-record.rkt" \ No newline at end of file diff --git a/untyped/generate-indices.rkt b/untyped/generate-indices.rkt new file mode 100644 index 0000000..e46336e --- /dev/null +++ b/untyped/generate-indices.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../generate-indices.rkt" untyped) diff --git a/untyped/ids.rkt b/untyped/ids.rkt new file mode 100644 index 0000000..447d4c4 --- /dev/null +++ b/untyped/ids.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../ids.rkt" untyped) diff --git a/untyped/in.rkt b/untyped/in.rkt new file mode 100644 index 0000000..8b86a85 --- /dev/null +++ b/untyped/in.rkt @@ -0,0 +1,2 @@ +#lang reprovide +"../in.rkt";; already untyped. diff --git a/untyped/list.rkt b/untyped/list.rkt new file mode 100644 index 0000000..562d738 --- /dev/null +++ b/untyped/list.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../list.rkt" untyped) diff --git a/untyped/logn-id.rkt b/untyped/logn-id.rkt new file mode 100644 index 0000000..0507c3e --- /dev/null +++ b/untyped/logn-id.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../logn-id.rkt" untyped) diff --git a/untyped/main.rkt b/untyped/main.rkt new file mode 100644 index 0000000..5c43169 --- /dev/null +++ b/untyped/main.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../main.rkt" untyped) diff --git a/untyped/meta-struct.rkt b/untyped/meta-struct.rkt new file mode 100644 index 0000000..b69404d --- /dev/null +++ b/untyped/meta-struct.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../meta-struct.rkt" untyped) \ No newline at end of file diff --git a/untyped/misc.rkt b/untyped/misc.rkt new file mode 100644 index 0000000..4ac95b1 --- /dev/null +++ b/untyped/misc.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../misc.rkt" untyped) \ No newline at end of file diff --git a/untyped/multiassoc-syntax.rkt b/untyped/multiassoc-syntax.rkt new file mode 100644 index 0000000..b523440 --- /dev/null +++ b/untyped/multiassoc-syntax.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../multiassoc-syntax.rkt" untyped) diff --git a/untyped/not-implemented-yet.rkt b/untyped/not-implemented-yet.rkt new file mode 100644 index 0000000..e7e0a48 --- /dev/null +++ b/untyped/not-implemented-yet.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../not-implemented-yet.rkt" untyped) diff --git a/untyped/percent.rkt b/untyped/percent.rkt new file mode 100644 index 0000000..1a48dd0 --- /dev/null +++ b/untyped/percent.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../percent.rkt" untyped) diff --git a/untyped/repeat-stx.rkt b/untyped/repeat-stx.rkt new file mode 100644 index 0000000..9f1ad06 --- /dev/null +++ b/untyped/repeat-stx.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../repeat-stx.rkt" untyped) diff --git a/untyped/require-provide.rkt b/untyped/require-provide.rkt new file mode 100644 index 0000000..cac61c0 --- /dev/null +++ b/untyped/require-provide.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../require-provide.rkt" untyped) diff --git a/untyped/sequence.rkt b/untyped/sequence.rkt new file mode 100644 index 0000000..81717dc --- /dev/null +++ b/untyped/sequence.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../sequence.rkt" untyped) diff --git a/untyped/set.rkt b/untyped/set.rkt new file mode 100644 index 0000000..afcaf04 --- /dev/null +++ b/untyped/set.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../set.rkt" untyped) diff --git a/untyped/stx.rkt b/untyped/stx.rkt new file mode 100644 index 0000000..a029772 --- /dev/null +++ b/untyped/stx.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../stx.rkt" untyped) diff --git a/untyped/syntax-parse.rkt b/untyped/syntax-parse.rkt new file mode 100644 index 0000000..d89eeb3 --- /dev/null +++ b/untyped/syntax-parse.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../syntax-parse.rkt" untyped) diff --git a/untyped/test-framework.rkt b/untyped/test-framework.rkt new file mode 100644 index 0000000..4b97b7f --- /dev/null +++ b/untyped/test-framework.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../test-framework.rkt" untyped) diff --git a/untyped/threading.rkt b/untyped/threading.rkt new file mode 100644 index 0000000..14c8ae9 --- /dev/null +++ b/untyped/threading.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../threading.rkt" untyped) diff --git a/untyped/tmpl-multiassoc-syntax.rkt b/untyped/tmpl-multiassoc-syntax.rkt new file mode 100644 index 0000000..543063e --- /dev/null +++ b/untyped/tmpl-multiassoc-syntax.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../tmpl-multiassoc-syntax.rkt" untyped) diff --git a/untyped/tmpl.rkt b/untyped/tmpl.rkt new file mode 100644 index 0000000..c05ba13 --- /dev/null +++ b/untyped/tmpl.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../tmpl.rkt" untyped) diff --git a/untyped/type-inference-helpers.rkt b/untyped/type-inference-helpers.rkt new file mode 100644 index 0000000..a70b79f --- /dev/null +++ b/untyped/type-inference-helpers.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../type-inference-helpers.rkt" untyped) diff --git a/untyped/typed-rackunit-extensions.rkt b/untyped/typed-rackunit-extensions.rkt new file mode 100644 index 0000000..eca8859 --- /dev/null +++ b/untyped/typed-rackunit-extensions.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../typed-rackunit-extensions.rkt" untyped) diff --git a/untyped/typed-rackunit.rkt b/untyped/typed-rackunit.rkt new file mode 100644 index 0000000..a5678de --- /dev/null +++ b/untyped/typed-rackunit.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../typed-rackunit.rkt" untyped) diff --git a/untyped/typed-untyped.rkt b/untyped/typed-untyped.rkt new file mode 100644 index 0000000..85a10c4 --- /dev/null +++ b/untyped/typed-untyped.rkt @@ -0,0 +1,2 @@ +#lang reprovide +"../typed-untyped.rkt" ;; already untyped diff --git a/untyped/values.rkt b/untyped/values.rkt new file mode 100644 index 0000000..9bc18b6 --- /dev/null +++ b/untyped/values.rkt @@ -0,0 +1,2 @@ +#lang reprovide +(submod "../values.rkt" untyped) diff --git a/values.rkt b/values.rkt new file mode 100644 index 0000000..aa1f604 --- /dev/null +++ b/values.rkt @@ -0,0 +1,51 @@ +#lang typed/racket +(require "typed-untyped.rkt") +(define-typed/untyped-modules + (provide first-value second-value third-value fourth-value fifth-value + sixth-value seventh-value eighth-value ninth-value tenth-value + cons→values + (rename-out [cons→values cons->values])) + + (define-syntax-rule (define-value-getter name accessor) + (define-syntax-rule (name expr) + ;; Using just (call-with values (λ () expr) accessor) does not work well + ;; when expr returns AnyValues (tested with eval below). + (call-with-values (λ () expr) (λ vs (accessor vs))))) + + (define-value-getter first-value first) + (define-value-getter second-value second) + (define-value-getter third-value third) + (define-value-getter fourth-value fourth) + (define-value-getter fifth-value fifth) + (define-value-getter sixth-value sixth) + (define-value-getter seventh-value seventh) + (define-value-getter eighth-value eighth) + (define-value-getter ninth-value ninth) + (define-value-getter tenth-value tenth) + + (module+ test + (require typed/rackunit) + (check-equal? (first-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 1) + (check-equal? (second-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 2) + (check-equal? (third-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 3) + (check-equal? (fourth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 4) + (check-equal? (fifth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 5) + (check-equal? (sixth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 6) + (check-equal? (seventh-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 7) + (check-equal? (eighth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 8) + (check-equal? (ninth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 9) + (check-equal? (tenth-value (values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)) 10) + ;; eval returns AnyValues, which behaves differently + (let ([ev '(values 1 2 3 4 5 6 7 8 9 10 11 12 13 14)]) + (check-equal? (first-value (eval ev)) 1) + (check-equal? (second-value (eval ev)) 2) + (check-equal? (third-value (eval ev)) 3) + (check-equal? (fourth-value (eval ev)) 4) + (check-equal? (fifth-value (eval ev)) 5) + (check-equal? (sixth-value (eval ev)) 6) + (check-equal? (seventh-value (eval ev)) 7) + (check-equal? (eighth-value (eval ev)) 8) + (check-equal? (ninth-value (eval ev)) 9) + (check-equal? (tenth-value (eval ev)) 10))) + + (define #:∀ (A B) (cons→values [x : (Pairof A B)]) (values (car x) (cdr x)))) \ No newline at end of file