commit 109659c456ca011163ed2dc909a29e35b63a276d Author: Georges Dupéron Date: Thu Apr 27 23:38:55 2017 +0200 Squashed commits 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 0000000..ba21887 Binary files /dev/null and b/perf.rkt.ods differ 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