From 494537057f6c8f705e3ada3d3ce4af9f3e3a2178 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Fri, 9 Oct 2015 15:23:15 +0200 Subject: [PATCH] Initial commit. --- .gitmodules | 8 + graph/.gitignore | 6 + graph/Makefile | 15 + graph/README | 262 ++++++ graph/graph/dotlang.rkt | 26 + graph/graph/equatable.rkt | 49 ++ graph/graph/graph.lp2.rkt | 885 ++++++++++++++++++++ graph/graph/list-lang.rkt | 16 + graph/graph/remember.rkt | 40 + graph/graph/structure.lp2.rkt | 499 ++++++++++++ graph/graph/type-system.scrbl | 107 +++ graph/graph/variant.lp2.rkt | 255 ++++++ graph/lib/doc.rkt | 132 +++ graph/lib/doc/MathJax | 1 + graph/lib/doc/bracket | 1 + graph/lib/doc/example.lp2.rkt | 59 ++ graph/lib/doc/math-scribble | 1 + graph/lib/doc/math.rkt | 36 + graph/lib/doc/template.lp2.rkt | 70 ++ graph/lib/eval-get-values.rkt | 11 + graph/lib/lib.rkt | 153 ++++ graph/lib/low-untyped.rkt | 16 + graph/lib/low.rkt | 344 ++++++++ graph/lib/path.rkt | 15 + graph/lib/syntax/quasitemplate.rkt | 85 ++ graph/lib/test-framework.rkt | 44 + graph/lib/untyped.rkt | 5 + graph/lib/untyped/for-star-list-star.rkt | 46 ++ graph/lib/untyped/ids.rkt | 114 +++ graph/main.rkt | 207 +++++ graph/make/.gitignore | 1 + graph/make/lib.rkt | 194 +++++ graph/make/make.rkt | 82 ++ graph/type-expander/multi-id.lp2.rkt | 182 +++++ graph/type-expander/type-expander.lp2.rkt | 943 ++++++++++++++++++++++ 35 files changed, 4910 insertions(+) create mode 100644 .gitmodules create mode 100644 graph/.gitignore create mode 100644 graph/Makefile create mode 100644 graph/README create mode 100644 graph/graph/dotlang.rkt create mode 100644 graph/graph/equatable.rkt create mode 100644 graph/graph/graph.lp2.rkt create mode 100644 graph/graph/list-lang.rkt create mode 100644 graph/graph/remember.rkt create mode 100644 graph/graph/structure.lp2.rkt create mode 100644 graph/graph/type-system.scrbl create mode 100644 graph/graph/variant.lp2.rkt create mode 100644 graph/lib/doc.rkt create mode 160000 graph/lib/doc/MathJax create mode 160000 graph/lib/doc/bracket create mode 100644 graph/lib/doc/example.lp2.rkt create mode 120000 graph/lib/doc/math-scribble create mode 100644 graph/lib/doc/math.rkt create mode 100644 graph/lib/doc/template.lp2.rkt create mode 100644 graph/lib/eval-get-values.rkt create mode 100644 graph/lib/lib.rkt create mode 100644 graph/lib/low-untyped.rkt create mode 100644 graph/lib/low.rkt create mode 100644 graph/lib/path.rkt create mode 100644 graph/lib/syntax/quasitemplate.rkt create mode 100644 graph/lib/test-framework.rkt create mode 100644 graph/lib/untyped.rkt create mode 100644 graph/lib/untyped/for-star-list-star.rkt create mode 100644 graph/lib/untyped/ids.rkt create mode 100644 graph/main.rkt create mode 100644 graph/make/.gitignore create mode 100644 graph/make/lib.rkt create mode 100644 graph/make/make.rkt create mode 100644 graph/type-expander/multi-id.lp2.rkt create mode 100644 graph/type-expander/type-expander.lp2.rkt diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..8bb38a06 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,8 @@ +[submodule "graph/lib/doc/bracket"] + path = graph/lib/doc/bracket + url = https://github.com/soegaard/bracket + branch = master +[submodule "graph/lib/doc/MathJax"] + path = graph/lib/doc/MathJax + url = https://github.com/mathjax/MathJax.git + branch = master diff --git a/graph/.gitignore b/graph/.gitignore new file mode 100644 index 00000000..80a4d9b3 --- /dev/null +++ b/graph/.gitignore @@ -0,0 +1,6 @@ +*.css +*.js +*.html +/docs/ +*~ +compiled diff --git a/graph/Makefile b/graph/Makefile new file mode 100644 index 00000000..2e50b1c5 --- /dev/null +++ b/graph/Makefile @@ -0,0 +1,15 @@ +.PHONY: all +all: make/make + make/make + +make/make: make/make.rkt make/lib.rkt + raco exe make/make.rkt + +.PHONY: clean +clean: + rm -fr make/make docs coverage + find \( -path ./lib/doc/bracket -prune -and -false \) -or -name compiled -print0 | xargs -0 rm -rf + +.PHONY: build-dep +build-dep: + raco pkg install --deps search-auto --update-deps --skip-installed alexis-util cover diff --git a/graph/README b/graph/README new file mode 100644 index 00000000..c4e91719 --- /dev/null +++ b/graph/README @@ -0,0 +1,262 @@ +How to build this project +========================= + +To install the build dependencies of this project on a clean Ubuntu 14.04 +machine, you need to install a recent version of racket. First, you need to +install a recent version of racket (as of the time of writing, version +20151017-6b93b18 has a bug that prevents normal execution of the graph library, +but the slightly older version 6.2.900.11 works fine). Then run the following +commands after doing a cd into the directory containing this README file: + + sudo apt-get install git + git submodule init + git submodule update + make build-dep + +To build the project, simply run `make`: + + make + +List of files +============= + +Graph library +------------- + +* graph/graph.lp2.rkt + + Implements a graph construction library. The user specifies a series of + transformations from a root input value to a result node, and can safely call + other transformations, without risking to run into an infinite loop. + + The make-graph-constructor takes the types of the result nodes, and the + transformations, and creates a graph-construction routine that detects cycles, + and prevents infinite recursion. + + For now, in the result, calls to other transformations are replaced by link + requests, but later versions will allow seamless access to the target result + node. + + The make-graph-constructor macro can be used like this: + + (define make-g + (make-graph-constructor + ([ma (fav String) (faa ma) (fab mb)] + [mb (fbv String) (fba ma)]) + [transform-a (s String) : ma + (ma s + (transform-a s) + (transform-b "b"))] + [transform-b (s String) : mb + (mb s + (transform-a s))])) + + Then, when the resulting graph constructor is called: + + (make-g "root-arg") + + We get the following graph as a result: + + (ma "root-arg" ) + ^ | | + `-------------------' ,------' + v + (mb "b" ) + ^ | + ,--------------------------- | -----------' + v | + (ma "b" ) + ^ | + `------------' + +* graph/type-system.scrbl + + Documentation about the type system implemented by graph/graph2.lp2.rkt, + graph/variant.lp2.rkt, graph/structure.lp2.rkt. + +* graph/variant.lp2.rkt + + Implements tagged unions, similar to those in caml, F#, or the unions in C if + a tag field is added, with a distinct tag value for each type in the union. + +* graph/structure.lp2.rkt + + Implements structures with anonymous access: accessing the field “b” of a + structure instance i can be written: (get i b), independently of the structure + type of the instance. Traditionnally, if one creates two structs in Racket, + using: + + (struct s1 ([a : Number] [b : String])) + (struct s2 ([b : String] [c : Boolean])) + + then, to access the “b” field from an instance “i” of “s1”, one has to write + “(s1-b i)”, whereas to access the field “b” from an instance “j” of “s2”, one + has to write “(s2-b j)”. The fact that we need to know the type of an instance + to access one of its fields is impractical when one needs to work with a large + number of structs which share some field names. + + Inheritance could solve this problem, but Racket only has single inheritance + for structs, not multiple inheritance. + + With the syntax offered by this library, one can write (get i b) for the first + case and (get j b), therefore allowing more flexible use of structures + containing similar fields. + +* graph/equatable.rkt + + Provides a struct in typed/racket with customizable equality, hashing and + printing. This is similar to overriding .equals(), .hashCode() and .toString() + in Java. + + Untyped racket provides these features out of the box, but they are not + normally available in typed/racket. + +* graph/dotlang.rkt + + Small programming language extension that allows writing “instance.f.g.h” + instead of “(get (get (get instance f) g) h)”. + +* graph/remember.rkt + + This utility module is used by graph/structure.lp2.rkt to memoize structure + descriptiors. When the “structure” macro defined in graph/structure.lp2.rkt + encounters an unknown list of field names, it adds it to the file + graph/remember.rkt. The memoized descriptors are used to know all possible + structs that can contain a field with the desired name when aceesing it with + “(get instance field-name)”. The “get” macro can then dispatch on these types, + and retrieve the field's value using the right accessor (for example + “(s123-field-name instance)”). + +* graph/list-lang.rkt + + Tiny programming language extension that allows constructing a list with the + contents of all trailing lines in the file. This is used by graph/remember.rkt + to easily add elements to the list of memoized structure descriptors, by just + appending to the end of the file. + +Type-expander +------------- + +* type-expander/type-expander.lp2.rkt + + This library extends the type system to allow type-expander macros, much in + the same way that “(match …)” allows match-expanders. For example, one can + write the “(Repeat t n)” type-expander, which expands to a list of “n” + elements of type “t”: + + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) + #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + + It can then be used in places where a regular type is expected: + + (: count-five-more (→ Number (Repeat Number 5))) + (define (count-five-more x) + (list (+ x 1) (+ x 2) (+ x 3) (+ x 4) (+ x 5))) + + (count-five-more 3) + ;; => '(4 5 6 7 8) + + (ann (count-five-more 15) (Repeat Number 5)) + ;; => '(16 17 18 19 20) + + This will be used by the graph library in graph/graph.lp2.rkt to allow + expressing graph types anonymously: + + (: x-to-string (→ (graph (a [x Number] [b b]) + (b [a a] [y Boolean])) + (graph (a [x String] [b b]) + (b [a a] [y Boolean])))) + (define (x-to-string g) …) + +* type-expander/multi-id.lp2.rkt + + This library allows easy definition of an identifier with multiple semantics: + the same identifier can be used as a constructor function, match expander, + type, type-expander, expanded type (i.e. a type containing type-expanders, + that has been expanded once), regular mutable or immutable variable, and with + a custom write procedure. + + It allows defining a new type with its constructor and match expander with + very little boilerplate code. + +Library functions and utilities +------------------------------- + +* lib/eval-get-values.rkt + + Wrapper for the racket “eval” function that allows evaluation of code with + multiple return values in typed/racket. + +* lib/lib.rkt + + Utilities that complement racket and typed/racket's standard libraries. + +* lib/low.rkt + + Lower-level utilities that complement racket and typed/racket's standard + libraries. + +* lib/low-untyped.rkt + + Wrapper around lib/low.rkt that allows using it from a untyped racket file. + +* lib/untyped/ids.rkt + + Some untyped racket utilities to manipulate identifiers inside macros. + +* lib/untyped/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. + +* lib/untyped.rkt + + Aggregates lib/low-untyped.rkt, lib/untyped/ids.rkt and + lib/untyped/for-star-list-star.rkt. + +* lib/test-framework.rkt + + Some wrappers and utilities that allow easier use of the rackunit test + framework from typed/racket files. + +* lib/syntax/quasitemplate.rkt + + Extension of the syntax/parse/experimental/template library, that allows using + “unsyntax” and “unsyntax-splicing” inside a “quasitemplate”, just like in the + normal “quasisyntax”. + +* lib/path.rkt + + Filesystem path manipulation utilities. + +* lib/doc.rkt + + Enhancements and utilities for documentation and literate programming files + using scribble and scribble/lp2. + +* lib/doc/math.rkt + + Allows typesetting mathematical formulas in documentation and literate + programming files using scribble and scribble/lp2. + +* lib/doc/template.lp2.rkt + + Example document using the features in lib/doc.rkt and lib/doc/math.rkt. + +* lib/doc/example.lp2.rkt + + Other example document using the features in lib/doc.rkt and lib/doc/math.rkt. + +Makefile +-------- + +* make/make.rkt + This program acts like a Makefile, it is used to compile the rest of + the code. + +* make/lib.rkt + Function definitions for the "unix make"-like tool, used by + make/make.rkt diff --git a/graph/graph/dotlang.rkt b/graph/graph/dotlang.rkt new file mode 100644 index 00000000..eddc803c --- /dev/null +++ b/graph/graph/dotlang.rkt @@ -0,0 +1,26 @@ +#lang typed/racket + +(module dotlang racket + (require typed/racket) + (provide (except-out (all-from-out typed/racket) #%top) + (rename-out [new-#%top #%top])) + + (require (for-syntax racket/string)) + + (define-syntax-rule (dot . xyz) + '(dot . xyz)) + + (define-syntax (new-#%top stx) + (syntax-case stx () + [(_ . x) + (let ([components (string-split (symbol->string (syntax->datum #'x)) + ".")]) + (if (> (length components) 1) + #`(dot . #,components) + #'(#%top . x)))]))) + +(module test (submod ".." dotlang) + (require typed/rackunit) + (let ((foo.bar 42)) + (check-equal? foo.bar 42)) + (check-equal? foo.bar '(dot "foo" "bar"))) diff --git a/graph/graph/equatable.rkt b/graph/graph/equatable.rkt new file mode 100644 index 00000000..384f69a1 --- /dev/null +++ b/graph/graph/equatable.rkt @@ -0,0 +1,49 @@ +#lang racket + +(module untyped racket + (provide (struct-out untyped-object)) + + (define-struct untyped-object () + #:transparent + ;#:property prop:procedure (λ (self . rest) (apply (untyped-object-proc self) rest)) + #:methods gen:custom-write + [(define write-proc (λ (self port mode) (((vector-ref (struct->vector self) 1) 'write-proc) port mode)))] + #:methods gen:equal+hash + [(define equal-proc (λ (x y recursive-equal?) (((vector-ref (struct->vector x) 1) 'equal-proc) y recursive-equal?))) + (define hash-proc (λ (x recursive-equal-hash-code?) (((vector-ref (struct->vector x) 1) 'hash-proc) recursive-equal-hash-code?))) + (define hash2-proc (λ (x recursive-equal-secondary-hash-code?) (((vector-ref (struct->vector x) 1) 'hash2-proc) recursive-equal-secondary-hash-code?)))])) + + +(module typed typed/racket + (require/typed (submod ".." untyped) + [#:struct untyped-object ()]) + + (define-type Field-Present (Vector Any)) + + (: field-present (→ Any Field-Present)) + (define (field-present x) (vector x)) + + (: field-present-get-value (→ Field-Present Any)) + (define (field-present-get-value fp) (vector-ref fp 0)) + + (struct (T) Equatable untyped-object + ([f : (case→ [→ 'value T] ;; Sadly, we can't extend a case→ described by T, so we have to chain two calls to access any field. + ;; TODO: we could just directly accept the other parameters + [→ 'write-proc (→ Output-Port (U #t #f 0 1) Any)] + [→ 'equal-proc (→ (U Equatable Any) (→ Any Any Boolean) Boolean)] + [→ 'hash-proc (→ (→ Any Fixnum) Fixnum)] + [→ 'hash2-proc (→ (→ Any Fixnum) Fixnum)] + [→ 'reflect (→ (U Index Symbol) (U Field-Present #f))])]) + #:transparent) + + (: Equatable-value (∀ (T) (→ (Equatable T) T))) + (define (Equatable-value e) ((Equatable-f e) 'value)) + + (provide (struct-out Equatable) + Equatable-value + Field-Present + field-present + field-present-get-value)) + +(require 'typed) +(provide (all-from-out 'typed)) diff --git a/graph/graph/graph.lp2.rkt b/graph/graph/graph.lp2.rkt new file mode 100644 index 00000000..478fabd5 --- /dev/null +++ b/graph/graph/graph.lp2.rkt @@ -0,0 +1,885 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Graph implementation} + +This module provides (a simplified form of) recursive algebraic data structures, +with the ability to handle the structure as a collection of nodes, and process +them all in a way similar to what @tc[map] provides. Traditionally, immutable +data structures can't form cycles, but can easily be traversed to reach all +nodes. Conversely, traversing a cyclic data structure (based on lazy evaluation +or thunks) is difficult if at all possible. + +More formally, this module offers fold operations on heterogeneous, richly typed +graphs. + +@(table-of-contents) + +@section{Notes on complex transform result types} + +We wish at one point to support complex result types for the transforms, instead +of only allowing a single node type. + +We have to impose a constraint: do not have a cycle inside the transform's +result that doesn't go through a node, since we break cycles by replacing nodes +with a promise. The safest way to satisfy that constraint is to enforce the +absence of loops at the type level. + +We would then inline the called transform's results, breaking the cycles by +replacing nodes with a thunk that returns the desired node. That thunk will be +wrapped into a Promise that calls it, so that typed/racket's occurrence typing +is happy, but we don't rely on the memoization semantics. + +@subsection{Compile-time handling of complex transform result types} + +During macro-expansion, we generate procedures that process nodes found in +transforms' results, by inlining the results of called transforms. If we find a +@tc[transform/link-request] type in some place we don't know how to rewrite +(like a function type, for example), we throw an error. Similarly, if we +encounter a cycle in the type that does not go through a node type, we throw an +error. + +These procedures will help generate code to make a facade node from the +incomplete one. When inlining results from called transforms, they will request +other incomplete nodes from the database. + +@subsection{Two-step graph creation} + +Writing a graph-generation macro that allows complex return types for transforms +seems difficult, and it would be easier to write a simple graph-generation +macro, that only accepts transforms with return a single node type. We could +build on top of that a more flexible macro, that would first generate a graph +where each transform's result is wrapped in an ad-hoc single-field node. Then, +we would automatically generate a second graph transformation that produces the +desired nodes from that graph. + +Example: transform @tc[t1] takes a list of numbers as input, and produces a list +of either calls to transform @tc[t2] or nodes @tc[ni] as output. The @tc[t2] +transform generates a pair of nodes @tc[(ni [x Number])] and +@tc[(nj [y String])]. + +The user would describe the graph like this: + +@chunk[ + (make-graph ([root (Listof (U ni (Pairof ni nj)))] + [ni [x Number]] + [nj [y String]]) + [(t1 [ln : (Listof Number)] : (Listof (U ni t2)) + (map (λ (x) (if (even? x) + (t2 x) + (ni x))) + ln))] + [(t2 [n : Number] : (Pairof ni nj) + (cons (ni n) (nj (format "~a" n))))])] + +In the above, the result type of @tc[t1] has to be @tc[(Listof (U ni t2))] +instead of @tc[(Listof (U ni (Pairof ni nj)))], because otherwise we can't +easily automatically infer that @tc[(Pairof ni nj)] was actually @tc[t2], +without looking at the body of the transform. In a more advanced version, we +could substitute every @tc[result-type] found in another transform's +@tc[result-type] by @tc[(U result-type transform/link-request)], however that +would likely produce spurious cycles that do not go through a node, so it's +probably best to make things explicit, and let the user write @tc[U]. + +@chunk[ + (graph ([r-t1 [result (Listof (U ni t2))]] + [r-t2 [result (Pairof ni nj)]]) + [(t1 [ln : (Listof Number)] : r-t1 + (r-t1 (map (λ (x) (if (even? x) + (t2 x) + (ni x))) + ln)))] + [(t2 [n : Number] : r-t2 + (r-t2 (cons (ni n) + (nj (format "~a" n)))))])] + +Then use this graph transform: + +@chunk[ + (make-graph ([root [result (Listof (Pairof ni nj))]] + [ni [x Number]] + [nj [y String]]) + [(r-t1→root [t1 : r-t1]) : root + (root (map (λ (v) + (match v + [(? list?) (r-t2-result v)] + [(ni _) v])) + (r-t1-result t1)))])] + +@subsection{Many to one transforms} + +This example covers one to many transforms. What about many to one transforms? +The macro we are building allows generating graphs, but does not care about the +input. In the case were transforming a graph of @tc[house]s, @tc[street]s and a +@tc[city], and we want to condense all the @tc[house]s on one side of each +@tc[street] to a @tc[suburb], we would write a transform @tc[t1] for@tc[street] +which passes the whole list of @tc[house]s to a transform @tc[t2]. The @tc[t2] +transform would create a @tc[suburb] from those, without calling a transform for +each @tc[house]. + +@subsection{Implicit rule names} + +In order to allow implicit rule names, when there's only one rule with the +desired result node, we can use the node's name as the transform name. We should +think about naming conflicts: when calling @tc[n], should it insert a link +request for the transform, or should it create an incomplete node? + +@subsection[#:tag "complex-transforms-return-type-conclusion"]{Conclusion} + +With this approach, we can write the graph creation macro with the guaranty +that the result of a transform always is exactly one node type. More complex +transform result types can be decomposed into to two passes. + +A downside is that we can't inspect the result of a call to another transform, +since it's not actually calling it, and we're only getting an opaque link +request back. We couldn't call the other transform anyway, because it could half +of the time return a value immediately, and half of the time call us back (with +the same arguments), causing an infinite loop. For that, we could declare some +#:helper transforms, that get called immediately (but if they run into an +infinite loop it's not our fault). + +@section{Comparison with @racket[make-placeholder] and + @racket[make-reader-graph]} + +Comparison of this approach with @tc[make-placeholder] and +@tc[make-reader-graph]: + +@itemlist[ + @item{They don't guarantee at compile-time that you'll fill in all + placeholders. We could use @racket[make-placeholder] and + @racket[make-reader-graph] wrapped inside a macro that makes sure that all + placeholders are filled (same approach as we have).} + @item{I don't think you can iterate over all the nodes or over the nodes of a + specific type, and @racket[make-placeholder] isn't typed (yet) anyway I + guess).}] + +@section{Constructor} + +Here is an overview of the architecture of the graph constructor: + +@itemlist[ + @item{We first save the parameter types in the old context, because we later + shadow the node names, and the parameters should refer to the old types. + Depending on how we write the rest, this might not be necessary though, since + it is possible we need to write @racket[(og node)] to refer to nodes types + from the old graph @racket[og].} + @item{We then define the node names as constructors for incomplete types — + which means that they can contain link requests for the results other + transforms} + @item{We define data structures representing link requests. Each link request + encapsulates a thunk that performs the transform's work when called, as well + as the name of the transform and its arguments, used to detect when we have + two identical link requests (which can be due to cycles in the resulting + graph, for example).} + @item{We then define the transforms as procedures that return a link request.}] + +@chunk[ + (define-syntax/parse + (make-graph-constructor ([node (field:id field-type:expr) ...] ...) + [transform:id (param:id param-type:expr) ... + (~literal :) result-type:id + body ...] + ...) + + + + + + + #`(let () + + (let () + + + + + + make-graph-database)))] + +@chunk[ + (define make-g (make-graph-constructor + ([ma (fav String) (faa ma) (fab mb)] + [mb (fbv String) (fba ma)]) + [transform-a (s String) : ma + (ma s + (transform-a s) + (transform-b "b"))] + [transform-b (s String) : mb + (mb s + (transform-a s))])) + (make-g "root-arg")] + +@subsection{Saving parameter types in old context} + +@chunk[ + (define/with-syntax ((param-type/old ...) ...) + (stx-map (λ (ps) + (with-syntax ([(t sps ...) ps]) + (format-temp-ids "~a/~a/memorized-type" #'t #'(sps ...)))) + #'((transform param ...) ...)))] + +@chunk[ + (define-type param-type/old param-type) + ... + ...] + +@subsection{Incomplete nodes} + +When a transform returns an object, it is incomplete (it potentially contains +link requests instead of actual references to the nodes). + +We prepare some template variables. The first is the name of the tagged variant +representing an incomplete node: + +@chunk[ + (define/with-syntax (node/incomplete ...) + (format-temp-ids "~a/incomplete" #'(node ...)))] + +Then, we build a reverse map, which from a node type obtains all the transforms +returning that node type. More specifically, we are interested in the +transform's link request type. + +@chunk[ + (define/with-syntax ((node/link-request-types ...) ...) + (for/list ([x (in-syntax #'(node ...))]) + (multiassoc-syntax x + #'([result-type . transform/link-request] ...))))] + +The third template variable we define maps transforms to the incomplete type for +their returned node. + +@chunk[ + (define/with-syntax (transform/result-node/incomplete ...) + (for/list ([x (in-syntax #'(result-type ...))]) + (assoc-syntax x #'([node . node/incomplete] ...))))] + +@CHUNK[ + (define-type node (U node/link-request-types ...) + #:omit-define-syntaxes) + ... + (define-tagged node/incomplete [field field-type] ...) + ... + (define-multi-id node + #:match-expander-id node/incomplete + #:call-id node/incomplete) + ...] + +@subsection{Link requests for nodes} + +When a transform wants to produce a reference to the result of another transform +of some data, it generates instead a link request, which encapsulates the +desired transform and arguments, without actually performing it. + +@chunk[ + (define/with-syntax (transform/link-request ...) + (format-temp-ids "~a/link-request" #'(transform ...)))] + +Due to an issue with @tc[typed/racket] (@tc[struct]s aren't properly declared +inside a @tc[let]), we need to pre-declare the @tc[transform/link-request] +@tc[struct]. Since the call to make-graph could itself be inside a @tc[let], we +need to pre-declare it in this file, instead of declaring it at the top of the +macro. + +We're making the structure transparent for easier debugging, but at the time of +writing this, it needs not be. + +@chunk[ + (struct (TKey) + transform/link-request-pre-declared + ([key : TKey]) + #:transparent)] + +@chunk[ + (define-type transform/link-request + (transform/link-request-pre-declared + (List 'transform + param-type/old ...))) + ...] + +@subsection{Transforms} + +@chunk[ + (define/with-syntax (transform/link-request→incomplete ...) + (format-temp-ids "~a/link-request→incomplete" #'(transform ...)))] + +@chunk[ + (begin + (: transform/link-request→incomplete + (→ param-type/old ... transform/result-node/incomplete)) + (define (transform/link-request→incomplete param ...) + body ...)) + ...] + +@chunk[ + (begin + (: transform + (→ param-type/old ... transform/link-request)) + (define (transform param ...) + ((inst transform/link-request-pre-declared + (List 'transform + param-type/old ...)) + (list 'transform param ...)))) + ...] + +@section{Queue} + +@chunk[ + (define/with-syntax (root-transform . _) #'(transform ...)) + (define/with-syntax ((root-transform/param-type ...) . _) + #'((param-type ...) ...)) + (define/with-syntax ((root-transform/param ...) . _) + #'((param ...) ...)) + (define/with-syntax (transform/transformed ...) + (format-temp-ids "~a/transformed" #'(transform ...))) + (define/with-syntax (root-transform/link-request . _) + #'(transform/link-request ...)) + (define/with-syntax recursive-call + #'(process-queue pending-requests + processed-requests + transform/transformed ...)) + (define/with-syntax (node/extract-link-requests ...) + (format-temp-ids "~a/extract-link-requests" #'(node ...))) + + + ] + +To build the graph database, we take the parameters for the root transform, and +return lists incomplete nodes (one for each transform). + +The parameters for the root transform, addition to the transform's name, form +the first link request. To fulfil this link request and the ones found later, +we call the desired transform which returns an incomplete node. We extract any +link requests found in that incomplete node, and queue them. The incomplete node +itself is added to the appropriate list, to be returned once the queue has been +fully processed. + +@CHUNK[ + (: make-graph-database + (→ root-transform/param-type ... + (List (Listof transform/result-node/incomplete) ...)))] + +The @tc[make-graph-database] function consists mainly in the process-queue +function, which takes a queue for each transform, and a list of +already-processed incomplete nodes for each transform, and returns these lists, +once all queues are empty. + +@CHUNK[ + (define (make-graph-database root-transform/param ...) + (: process-queue (→ (Setof (U transform/link-request ...)) + (Setof (U transform/link-request ...)) + (Listof transform/result-node/incomplete) + ... + (List (Listof transform/result-node/incomplete) + ...))) + (define (process-queue pending-requests + processed-requests + transform/transformed + ...) + ;; TODO: Can probably be moved out. + ) + + )] + +The @tc[process-queue] function is initially called with empty lists for all +queues and all result lists, except for the root transform's queue, which +contains the initial link request. + +@CHUNK[ + (process-queue (set (root-transform root-transform/param ...)) + (set) + (begin 'transform/transformed '()) + ...)] + +Process-queue is a standard queue handler using sets. + +@CHUNK[ + (if (set-empty? pending-requests) + (list transform/transformed ...) + (let* ([request (set-first pending-requests)] + [pending-requests (set-rest pending-requests)] + [processed-requests (set-add processed-requests request)] + [tag (car (transform/link-request-pre-declared-key request))]) + ))] + +To process each link request, we first match on its type, and once we found it, +we call the result thunk, extract any link requests contained within, and add +those to the queue. + +@CHUNK[ + (cond + [(eq? tag 'transform) + (let* ([transformed + : transform/result-node/incomplete + (apply transform/link-request→incomplete + (cdr (transform/link-request-pre-declared-key request)))] + [transform/transformed + (cons transformed transform/transformed)] + [extracted + (list->set + (transform/result-node/extract-link-requests transformed))] + [pending-requests + (set-union pending-requests + (set-subtract extracted processed-requests))]) + recursive-call)] + ...)] + +@subsection{TODO} + +We need to traverse the @tc[transformed] node (which is an incomplete node), +and find the link requests within. These link requests will be added to the +corresponding @tc[pending-requests] queue. Below is the body of a for-syntax +function that transforms a type with link-requests into the @tc[match] patterns +that will be used at run-time to traverse the incomplete node. In most cases, +there is only one pattern, but the @tc[U] requires one for each possibility. + +When we encounter a link request, we prepend it to the corresponding queue. +For the type @tc[(List Number n/link-request)], the function will look like +this: + +@chunk[ + (match transformed + [(list a b) + (match a [a2 a2]) + (match b [(and t + (transform/link-request-pre-declared + (cons 'transform1 _))) + (set! pending-requests + (cons t pending-requests))])])] + +@subsubsection{Match clauses} + +We first transform the type into the different match clauses. For that, we +define the @tc[fold-type-clauses] function, which takes the identifier to +destructure at run-time, and its type. The function returns a list of clauses. + +@chunk[ + (define (fold-type-clauses val t) + (syntax-parse t + ))] + +When a link request is found in the type, we produce the corresponding match +clause, which body prepends the request to the queue of pending requests. For +now we use @racket[set!] to prepend the request, but it would be cleaner to use +recursion. We wouldn't even need to flatten the pending-requests list, because +it could be a tree instead of a flat list, since we only need to add to it and +later pop elements. + +TODO: we currently ignore potential hiding of identifiers due to type variables +bound by Rec, for example. This is a case where having a fold-type function +provided by the type-expander library would be interesting. + +@CHUNK[ + [x:id + #:when (ormap (curry free-identifier=? #'x) + (syntax->list #'(node/incomplete ...))) + (define/with-syntax (this-field-type ...) + (assoc-syntax #'x #'((node/incomplete field-type ...) ...))) + + (define/with-syntax (tmp ...) + (generate-temporaries #'(this-field-type ...))) + #`([(x tmp ...) + (append #,@(stx-map fold-type + #'(tmp ...) + #'(this-field-type ...)))])]] + +@CHUNK[ + [x:id + #:when (ormap (curry free-identifier=? #'x) + (syntax->list #'(node ...))) + #`([(and t (transform/link-request-pre-declared (cons 'transform _))) + (cons (ann t transform/link-request) '())] + ...)]] + +We handle fixed-length lists by calling @tc[fold-type] on each element type. + +@CHUNK[ + [((~literal List) a ...) + (define/with-syntax (tmp ...) (generate-temporaries #'(a ...))) + #`([(list tmp ...) + (append #,@(stx-map fold-type #'(tmp ...) #'(a ...)))])]] + +We iterate variable-length lists at run-time. + +@CHUNK[ + [((~literal Listof) a) + #`([(list tmp (... ...)) + (append-map (λ (tmp1) #,(fold-type #'tmp1 #'a)) + tmp)])]] + +Pairs and vectors are handled similarly: + +@CHUNK[ + [((~literal Pairof) a b) + #`([(cons tmpa tmpb) + (list #,(fold-type #'tmpa #'a) + #,(fold-type #'tmpb #'b))])]] + +@CHUNK[ + [((~literal Vectorof) a) + #'([(vector tmp (... ...)) + (append-map (λ (tmp1) #,(fold-type #'tmp1 #'a)) + tmp)])]] + +For unions, we return several clauses, obtained via a recursive call to +@tc[fold-type-clauses]. + +@CHUNK[ + [((~literal U) a ...) + #`(#,@(stx-map fold-type-clauses val #'(a ...)))]] + +We handle other cases by leaving them as-is, but we still check that they don't +contain a reference to a node type, because we would otherwise leave the +link-request there. + +And the fourth maps transforms to the link-requests extraction procedure for +their returned node. + +@chunk[ + (define/with-syntax (transform/result-node/extract-link-requests ...) + (for/list ([x (in-syntax #'(result-type ...))]) + (assoc-syntax x #'([node . node/extract-link-requests] ...))))] + +The last case is when we encounter an unknown type. We assume that it does not +contain any link-requests and therefore return an empty list. + +@CHUNK[ + [x:id + #`([_ '()])]] + +@subsubsection{Folding the type: extracting link requests} + +The for-syntax function @tc[fold-type] generates code that uses @tc[match] to +extract the @tc[link-request]s from an incomplete node (or part of it) with type +@tc[t]. The match clauses are those returned by @tc[fold-type-clauses] defined +above. + +@CHUNK[ + (define (fold-type val t) + #`(begin + (match #,val #,@(fold-type-clauses val t))))] + +@subsubsection{Fold function for each incomplete node} + +For each node type, we wish to declare a function that extracts link requests +from the incomplete type. We should work on the expanded type. + +@chunk[ + (define-template-metafunction (fold-type-tmpl stx) + (syntax-case stx () [(_ val t) (fold-type #'val #'t)]))] +@CHUNK[ + #,@(for/list ([name (in-syntax #'(node/extract-link-requests ...))] + [val-type (in-syntax #'(node/incomplete ...))] + [field-types (in-syntax #'((field-type ...) ...))]) + #`(define (#,name [val : #,val-type]) + : (Listof (U transform/link-request ...)) + #,(fold-type #'val val-type)))] + +@subsubsection{TODO} + +Later, we will replace link requests with thunks returning the desired node, +wrapped in a promise in order to please occurrence typing. Below is the body of +the for-syntax function that transforms a type with link-requests into a type +with actual nodes. It's probably not useful, because we obtain the same result +with scopes. + +@CHUNK[ + [x:id + #:when + (ormap (curry free-identifier=? #'x) + (syntax->list #'(node/link-request ...))) + #`(Promise (→ #,(assoc-syntax #'x #'((node/link-request . node) ...))))] + [((~literal List) a ...) #`(List #,@(stx-map fold-type #'(a ...)))] + [((~literal Listof) a) #`(Listof #,@(stx-map fold-type #'(a ...)))] + [((~literal Pairof) a b) #`(Pairof #,(fold-type #'a) #,(fold-type #'b))] + [((~literal Vectorof) a) #'(Vectorof #,(fold-type #'a))] + [((~literal U) a ...) #'(U #,(stx-map fold-type #'(a ...)))]] + +@section{@racket[incomplete] type-expander} + +We define a @tc[type-expander] @tc[(incomplete n)] that returns the incomplete +node type for the node type @tc[n]. This type-expander allows the user to refer +to the incomplete type of the node in the body of a transform, if annotations +are needed for a value containing such a node. + +@chunk[ + (define-type-expander (incomplete stx) + (syntax-case stx () + [(_ n) + (raise-syntax-error + 'incomplete + (format "Type doesn't have an incomplete counterpart: ~a" + (syntax->datum #'n)) + #'n)]))] + +@chunk[ + (define-type-expander (outer-incomplete stx) + (syntax-case stx () [(_ n) #'(incomplete n)]))] + +@chunk[ + (let () + + (let () + (define-type node + (tagged node [field (Promise field-type)] ...)) + ... + + (define-type node/incomplete + ;; TODO: substitute link-requests here + (tagged node [field (Promise field-type)] ...)) + + (define-type-expander (incomplete stx) + (syntax-parse stx () + [(_ (~litral node)) #'node/incomplete] + [_ #'(outer-incomplete n)])) + ))] + +@section{Transforming @racket[incomplete] nodes into complete ones} + +@subsection{Initial version} + +We will start with a very simple traversal function, that will just substitute +link requests immediately in the fields of a node. + +@chunk[ + (define (substitute-link-requests v) + (match v + [(node/incomplete field ...) + (node ...)] + ...))] + +@chunk[ + (match field + [(transform/link-request key _) (transform/key→promise key)] ;; TODO + ...)] + +@chunk[ + ] + +@subsection{More complex attempt} + +We know for sure that all references to future nodes are actually incomplete +ones, but we have no guarantee about the contents of the fields of a node. Since +they may contain a mix of link requests and primitives (via a @tc[U] type for +example), and may contain lists of nodes etc. we need to traverse them at +run-time, in order to find and replace references to link requests. + +However, if we were to write this as a simple recursive function, we wouldn't be +able to express its type without knowing anything about the node's type: + +@chunk[ + (case→ (→ node/link-request node) ... + (→ (Pairof may-contain-link-request + may-contain-link-request) + (Pairof doesnt-contain-link-request + doesnt-contain-link-request)))] + +Writing the @tc[may-contain-link-request] and @tc[doesnt-contain-link-request] +as functions, while expressing the contraint that the output is the same type as +the input — except for the link requests that turned into nodes, would be +impossible in typed/racket. I suppose that with GADTs one could write such a +type. + +Instead, we will, during macro-expansion, traverse the type, and generate +conversion procedures accordingly. + +@chunk[ + [(~literal node/link-request) #''link-request] + ... + [((~literal List) a ...) #'(List #,@(stx-map fold-type #'(a ...)))] + [((~literal Listof) a) #''Listof] + [((~literal Pairof) a) #''Pairof] + [((~literal Vectorof) a) #''Vectorof] + [((~literal U) a ...) #''U]] + +@chunk[ + (→ (List a ...) (List replaced-a ...))] + +@chunk[ + [(list? v) (map traverse-list v)] + [(pair? v) (cons (traverse-list (car v)) + (traverse-list (cdr v)))] + [(vector? v) ]] + +@subsection{Unions} + +Unions are difficult to handle: At one extreme, we confuse two different types +like @tc[(Listof Number)] and @tc[(Listof String)], by using just the @tc[list?] +predicate. On the other end of the spectrum, we try to distinguish them with +@tc[typed/racket]'s @tc[make-predicate], which doesn't work in all cases. + +Handling this in the best way possible is out of the scope of this project, so +we will just add special cases as-needed. + +@subsection{Unhandled} + +We currently don't handle structure types, prefab structures, hash tables, +syntax objects and lots of other types. + +On the other hand, we can't handle fixed-length @tc[(Vector ...)] types, because +occurrence typing currently can't track which case we are in when we check the +length with @tc[(vector-length constant)]. We also can't handle functions, for +hopefully obvious reasons. + +@; TODO: insert a link to the type-expander document in the paragraph below. + +We run into a problem though with types declared via define-type without +informing the type-expander. The type-expander handles these by expanding just +their arguments, and leaving the type untouched, but we can't ignore them in our +case. + +For all these other cases, we'll just check that they don't contain any +reference to a link-request type. + +@chunk[ + [other + (fold-check-no-link-requests #'other) + #'other]] + +The checker below is approximate, and is just meant to catch the error as soon +as possible, and we include a fall-back case for anything we couldn't handle +properly. If we let a link-request slip, it should be caught by the type +checker, unless it is absorbed by a larger type, like in +@tc[(U Any link-request)], in which case it doesn't matter. + +@chunk[ + (define (fold-check-no-link-requests stx) + (syntax-parse stx + [(~and whole (~or (~literal node/link-request) ...)) + (raise-syntax-error + 'graph + "Found a link request buried somewhere I can't access" + whole)] + [(~and whole (t ...)) + (stx-map fold-check-no-link-requests #'(t ...))] + [whole whole]))] + +@section{TODO} + +@chunk[ + (define (multiassoc-syntax query alist) + (map stx-cdr + (filter (λ (xy) (free-identifier=? query (stx-car xy))) + (syntax->list alist)))) + (define (assoc-syntax query alist) + (let ([res (assoc query (map syntax-e (syntax->list alist)) + free-identifier=?)]) + (unless res (raise-syntax-error '? (format "Can't find ~a in ~a" + query + alist))) + (cdr res)))] + +@CHUNK[ + ;; The actual traversal code: + ;; TODO: write a tail-recursive version, it's cleaner than using set!. + (: make-graph-database + (→ root-transform.param.type ... + (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) + ...))) + (define (make-graph-database root-transform.param.name ...) + (let ([pending : (Listof (U node.link-request ...)) + (list (cons (list 'root-transform.name + root-transform.param.name ...) + (λ () (root-transform.function + root-transform.param.name ...))))] + [all-transformed : (Listof (Pairof Symbol Any)) '()] + ;; the key is actually the second element in a + ;; link-request-???, but should be just a number like in + ;; the C# version. + [node.transformed : (Listof (Pairof Any node.incomplete)) '()] + ...) + (do : (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) + ...) + () + [(null? pending) + (ann (λ (selector) + (cond [(eq? selector 'node.name) node.transformed] ...)) + (case→ (→ 'node.name (Listof (Pairof Any node.incomplete))) + ...))] + (let ((request (car pending))) + ;; Must be immediately after the (let (...), because we cons to + ;; that list in the block below. + (set! pending (cdr pending)) + ;; Skip already-transformed link requests. TODO: map a number + ;; for each. + (unless (member (car request) all-transformed) + ;; Call the lambda-part of the request. + (let ([transformed ((cdr request))]) + (cond + [(eq? (car transformed) 'node.name) + (set! pending + (list* ((cdr transformed) + 'node/field-filter-out-primitives/name) + ... + pending)) + (set! all-transformed (cons (car request) + all-transformed)) + (set! node.transformed + (cons (cons (car request) (cdr transformed)) + node.transformed))] + ... + ;; Make sure all cases are treated, at compile-time. + [else (typecheck-fail #'#,stx + "incomplete coverage")])))))))] + +@section{Tests} + +@chunk[ + (values)] + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require (for-syntax racket/sequence + ;; in-syntax on older versions + ;;;unstable/sequence + syntax/parse + syntax/parse/experimental/template + racket/syntax + racket/function + syntax/stx + racket/pretty + "../lib/low-untyped.rkt" + "../lib/untyped.rkt") + (prefix-in DEBUG-tr: typed/racket) + syntax/parse + "../lib/low.rkt" + "structure.lp2.rkt" + "variant.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") + (provide make-graph-constructor + #|graph|#) + + (begin-for-syntax + ) + + + + + #||#) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + "../type-expander/type-expander.lp2.rkt" + "../lib/test-framework.rkt") + + ;; Debug + + (require syntax/parse + "../lib/low.rkt" + "structure.lp2.rkt" + "variant.lp2.rkt" + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt") + ;; + + + + + (require (submod ".." doc))))] \ No newline at end of file diff --git a/graph/graph/list-lang.rkt b/graph/graph/list-lang.rkt new file mode 100644 index 00000000..6575f874 --- /dev/null +++ b/graph/graph/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/graph/graph/remember.rkt b/graph/graph/remember.rkt new file mode 100644 index 00000000..168c8fd8 --- /dev/null +++ b/graph/graph/remember.rkt @@ -0,0 +1,40 @@ +#lang s-exp "list-lang.rkt" + +(provide all-remembered-list all-remembered-alist) + +;; For older versions: +#| +(require/typed unstable/list + [(group-by group-by-untyped) + (∀ (A B) (->* [(→ A B) (Listof A)] + [(→ B B Any)] + (Listof (Listof A))))]) + +;; Circumvent problem with contracts: with the imported untyped version, +;; two identical keys are never equal?. I think this is because the keys are +;; wrapped with contracts when they are passed to equal?, and therefore are not +;; equal?, because we're comparing two distinct contract wrappers, instead of +;; comparing their contents. +(: group-by (∀ (A B) (->* [(→ A B) (Listof A)] + [(→ B B Any)] + (Listof (Listof A))))) +(define (group-by key lst [same? equal?]) + (group-by-untyped key lst (λ ([x : B] [y : B]) (same? x y)))) +|# + +(define all-remembered-alist + (map (λ ([g : (Listof (Pairof Symbol Any))]) : (Pairof Symbol (Listof Any)) + (cons (caar g) (remove-duplicates (map (inst cdr Symbol Any) g)))) + (group-by (inst car Symbol Any) all-remembered-list))) + +(define-list-values all-remembered-list : (Listof (Pairof Symbol Any))) +(structure a b c) +(structure a b c d) +(structure a b c y) +(structure a b) +(structure x y z) +(structure) +(structure f g) +(structure faa fab fav) +(structure fba fbv) +(structure fav) diff --git a/graph/graph/structure.lp2.rkt b/graph/graph/structure.lp2.rkt new file mode 100644 index 00000000..09746b66 --- /dev/null +++ b/graph/graph/structure.lp2.rkt @@ -0,0 +1,499 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Implementation of structures} + +@(table-of-contents) + +@section{@racket[define-structure]} + +Structures are represented using regular racket @tc[struct]s, see +@seclink["structures" #:doc "type-system.scrbl"]{the overview document}. +@;secref["structures" #:doc "type-system.scrbl"]. + +@chunk[ + (define-multi-id structure + #:type-expander structure-type-expander + #:match-expander structure-match-expander + #:call (λ/syntax-parse (_ [field value] ...) + #'((make-structure-constructor field ...) value ...)))] + +@chunk[ + (define-syntax (define-structure stx) + (syntax-parse stx + [(_ name [field type] ...) + (define/with-syntax ([sorted-field sorted-type] ...) + (sort-car-fields #'([field type] ...))) + (define/with-syntax (pat ...) (generate-temporaries #'(field ...))) + #'(define-multi-id name + #:type-expand-once + (structure [field type] ...) + #:match-expander + (λ (stx2) + (syntax-case stx2 () + [(_ pat ...) #'(structure [field pat] ...)])) + #:else + (inst (make-structure-constructor field ...) type ...))]))] + + +@chunk[ + (define-structure st [a Number] [b String]) + (define-structure st2 [b String] [a Number])] + +Test constructor: + +@chunk[ + (check-equal:? (get (st 1 "b") b) : String "b") + (check-equal:? (get (st2 "a" 2) b) : String "a")] + +Test constructor, as id: + +@chunk[ + (check-equal:? (get (cadr (map st '(1 2 3) '("x" "y" "z"))) b) + : String "y") + (check-equal:? (get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b) + : String "e")] + +Test the type-expander: + +@chunk[ + (check-equal? (get (ann (st2 "g" 123) st2) b) "g")] + +Test the match-expander: + +@chunk[ + (check-equal:? (match (st2 "h" 7) [(st x y) (cons x y)]) + : (Pairof Number String) + '(7 . "h"))] + +Test equality: + +@chunk[ + (check-equal? (ann (st 1 "i") st) (st 1 "i")) + (check-equal? (ann (st2 "j" 2) st2) (st2 "j" 2)) + (check-equal? (ann (st 1 "k") st) (st2 "k" 1))] + +@section{Pre-declaring structs} + +We wish to pre-declare all @tc[struct] types for various reasons: + +@itemlist[ + @item{Anonymous, on-the-fly declaration (otherwise we need to be in a + definition-context to be able to declare a @racket[struct]).} + @item{If we use @code{(get-field s b)} in module @code{A}, and define a + @racket[struct] type with a field @code{b} in module @code{B}, then the module + @code{A} would have to require @code{B}, and we could easily run into cyclic + dependencies. + + Moving the @racket[struct] definition to another place solves that problem.}] + +In order to pre-declare the @tc[struct]s, we need to remember them across +compilations, for that we use @tc[remember-all] and @tc[get-remembered] defined +below in section @secref{remember}. We then need to make these identifiers +available in the correct syntax scope. The easiest way to do that, is to have a +private macro @tc[(declare-all-structs (name field ...) ...)] which does all the +required definitions, namely defining the struct, as well as @tc[make-struct], +@tc[get-field], and the match-expander eventually. + +We do not wish to remember the type of each field, as they may be a non-exported +identifier from some module. It should not cause any problem when declaring the +parameter type @tc[(U g1 g2 …)] for a compiler pass, because by then, we should +have access to all the types we care about, and fill the rest with @tc[∀] types. + +@chunk[ + (define-for-syntax (check-remember-fields fields) + (check-remember-all 'structure (sort-fields fields)))] + +Since get-field is a macro, it should not care about the type of the field(s), +and the code it expands to should be a @tc[cond] which only tests the field part +of the structure. + +@CHUNK[ + (define-syntax/parse (declare-all-structs fields→stx-name-alist:id + (name field ...) ...) + #'(begin + + + (define-for-syntax fields→stx-name-alist + (map (λ (x) (cons (map syntax->datum + (syntax->list (stx-cdr x))) + (stx-car x))) + (syntax->list #'((name field ...) ...))))))] + +This macro should be called only once, and given as parameters the whole +remembered list of structs: + +@CHUNK[ + (define-syntax/parse (call-declare-all-structs fields→stx-name-alist:id) + #`(declare-all-structs fields→stx-name-alist + #,@named-sorted-structures)) + + (call-declare-all-structs fields→stx-name-alist)] + +This list of structures associates their collection of fields with an arbitrary +name. The fields are sorted lexicographically and duplicate entries are removed, +so that @tc[(structure a b)] and @tc[(structure b a)] are equivalent, and only +one low-level @tc[struct] is generated for them. + +@CHUNK[ + (define-for-syntax named-sorted-structures + (for/list ([s (remove-duplicates (map (λ (s) (sort s symbolsymbol (format "struct-~a" i)) . ,s)))] + +We will also need utility functions to sort the fields when querying this +associative list. + +@chunk[ + (define-for-syntax (sort-car-fields car-fields) + (sort (syntax->list car-fields) + symbol + (define-for-syntax (sort-fields fields) + (sort (syntax->list fields) + symbol + (struct (field ...) name ([field : field] ...) #:transparent) + ...] + +@section{Constructor} + +We provide a macro which returns an anonymous @tc[structure] constructor. It can +be used to make @tc[structure] instances like this: + +@chunk[ + (check-equal? (begin ((make-structure-constructor a b c) 1 "b" #t) + #t) + #t)] + +To create such an instance, we use the underlying @tc[struct]'s constructor. +First, we need to check if the list of fields was already remembered, in which +case we return the associated @tc[struct] name. Otherwise, we trigger an error, +knowing that the list of fields has been remembered, so the next compilation +should succeed. + +@CHUNK[ + (define-syntax/parse (make-structure-constructor field ...) + (if (check-remember-fields #'(field ...)) + (let () + (define/with-syntax (sorted-field ...) + (sort-fields #'(field ...))) + (define/with-syntax (TTemp ...) + (generate-temporaries #'(field ...))) + #`(λ #:∀ (TTemp ...) ([field : TTemp] ...) + (#,(fields→stx-name #'(field ...)) sorted-field ...))) + (remember-all-errors #'list stx #'(field ...))))] + +To get the structure name from the list of fields, we need to sort +lexicographically the list of fields during lookup in +@tc[fields→stx-name-alist]. +The fields in @tc[fields→stx-name-alist] are already sorted. + +@chunk[ + (define-for-syntax (fields→stx-name fields) + (cdr (assoc (syntax->datum (datum->syntax #f (sort-fields fields))) + fields→stx-name-alist)))] + +@subsection{Accessor} + +@CHUNK[ + (define-syntax/parse (get v field:id) + (define structs (filter (λ (s) + (member (syntax->datum #'field) (car s))) + fields→stx-name-alist)) + (define/with-syntax (name? ...) + (map (λ (s) ) structs)) + (define/with-syntax (name-field ...) + (map (λ (s) ) structs)) + #`(let ([v-cache v]) + (cond + [(name? v-cache) + (let ([accessor name-field]) + (accessor v-cache))]; cover does not see the call otherwise? + ... + [else (typecheck-fail #,stx #:covered-id v-cache)])))] + +@chunk[ + (my-st-type-info-predicate (get-struct-info stx (cdr s)))] + +@CHUNK[ + (list-ref (my-st-type-info-accessors (get-struct-info stx (cdr s))) + (indexof (syntax->datum #'field) (reverse (car s))))] + +@chunk[ + (check-equal:? + (get ((make-structure-constructor a b c d) 1 "b" 'value-c 4) c) + : 'value-c + 'value-c)] + +@subsection{Match-expander} + +@chunk[ + (begin-for-syntax + (define-syntax-class match-field-or-field-pat + (pattern [field:id pat ...]) + (pattern field:id #:with (pat ...) #'())))] + +@chunk[ + + (define-for-syntax (structure-match-expander stx) + (syntax-parse stx + [(_ :match-field-or-field-pat ...) + (if (check-remember-fields #'(field ...)) + (let () + (define/with-syntax name (fields→stx-name #'(field ...))) + (define/with-syntax ([sorted-field sorted-pat ...] ...) + (sort-car-fields #'((field pat ...) ...))) + #'(name (and sorted-field sorted-pat ...) ...)) + )]))] + +If we just return @racket[(remember-all-errors list stx #'(field ...))] when a +recompilation is needed, then the identifier @tc[delayed-error-please-recompile] +becomes a variable bound by @tc[match], and may proceed without triggering any +error, if the body of the clause works without that part of the pattern (either +it does not use the variables defined within, or they were shadowing other +variables). + +Therefore, we use that unbound identifier in a way for it to be read (to trigger +the error), but not bound to part of a pattern. Furthermore, in case the +sub-patterns in @tc[(pat ...)] contain themselves structs that have not yet been +remembered, we use them (without caring about what they match), so that they are +expanded, and get a chance to remember what they need for the next compilation, +instead of needing an extra recompilation. + +@CHUNK[ + #`(app #,(remember-all-errors #'list stx #'(field ...)) + (and pat ...) ...)] + +@chunk[ + (let ([test-match + (λ ([val : Any]) + (match val + [(structure a b c y) (list a b c y)] + [(structure d + [a (? number?)] + [c (? symbol?) 'value-c] + [b bb (? string?)]) + (list a bb c d)] + [else 'other]))]) + (check-equal? (test-match + ((make-structure-constructor a b c d) 1 "b" 'value-c 4)) + '(1 "b" value-c 4)) + (check-equal? (test-match + ((make-structure-constructor a b c y) 1 2 3 4)) + '(1 2 3 4)) + (check-equal? (test-match 'bad) 'other))] + +@subsection{Anonymous type} + +@subsection{Accessing information about racket's structs at compile-time} +@chunk[ + (begin-for-syntax + (struct my-st-type-info + (type-descriptor + constructor + predicate + accessors + mutators + super-type) + #:transparent))] + +@CHUNK[ + (define-for-syntax (get-struct-info stx s) + (let* ([fail (λ () (raise-syntax-error 'get-struct-info + "not a structure definition" + stx + s))] + [v (if (identifier? s) + (syntax-local-value s fail) + (fail))] + [i (if (not (struct-info? v)) (fail) (extract-struct-info v))]) + (apply my-st-type-info i)))] + +@subsection{Type-expander} + +@CHUNK[ + (define-for-syntax (structure-type-expander stx) + (syntax-parse stx + [(_ [field type] ...) + (if (check-remember-fields #'(field ...)) + (let () + (define/with-syntax ([sorted-field sorted-type] ...) + (sort-car-fields #'((field type) ...))) + (if (null? (syntax->list #'(sorted-type ...))) + (fields→stx-name #'(field ...)) + #`(#,(fields→stx-name #'(field ...)) sorted-type ...))) + (remember-all-errors #'U stx #'(field ...)))]))] + +@chunk[ + (check-equal? (get (ann ((make-structure-constructor a b c) 1 "b" #t) + (structure [a Number] [c Boolean] [b String])) + b) + "b")] + +@section[#:tag "remember"]{Closed-world assumption and global compilation} + +In order to be able to access elements in the list as deep as they can be, we +need to know the length of the longest structure used in the whole program. + +Knowing what structures exist and what elements they contain can only help, so +we'll remember that instead. + +The @tc[remember-all] for-syntax function below memorizes its arguments across +compilations, and adds them to the file “@code{remember.rkt}”: + +@CHUNK[ + (require (for-syntax "remember.rkt")) + + (define-for-syntax (check-remember-all category value) + (let ([datum-value (syntax->datum (datum->syntax #f value))]) + (if (not (member (cons category datum-value) all-remembered-list)) + (let ((file-name (build-path (this-expression-source-directory) + "remember.rkt"))) + ;; Add the missing field names to all-fields.rkt + (with-output-file [port file-name] #:exists 'append + (writeln (cons category datum-value) port)) + #f) + #t))) + + (define-for-syntax (remember-all-errors id fallback stx-list) + ; + #`(#,id #,(for/list ([cause `(,@(syntax->list stx-list) ,fallback)]) + (syntax/loc cause delayed-error-please-recompile))))] + +@CHUNK[ + (raise-syntax-error + (car (syntax->datum stx)) + (format "The fields ~a were added to ~a. Please recompile now." + (string-join (map symbol->string missing) ", ") + file-name) + #f + #f + (filter (λ (f) (not (member (syntax->datum f) all-fields))) + (syntax->list fields)))] + +We can, during subsequent compilations, retrieve the list of already-memorized +fields for a given tag. + +@CHUNK[ + (define-for-syntax (get-remembered category) + (cdr (or (assoc category all-remembered-alist) '(_))))] + +If we start with an empty “@code{remember.rkt}” file, it will throw an error at +each call with a not-yet-remembered value. In order to avoid that, we use the +macro @tc[(delayed-error-please-recompile)], which expands to an undefined +identifier @code{please-recompile}. That error is caught later, and gives a +chance to more calls to @tc[remember-all] to be executed during macro-expansion. +We define @tc[delayed-error-please-recompile] in a submodule, to minimize the +chances that we could write a definition for that identifier. + +@CHUNK[ + (begin-for-syntax + (module m-please-recompile typed/racket + (define-syntax (delayed-error-please-recompile stx) + #'please-recompile) + (provide delayed-error-please-recompile)) + + (require 'm-please-recompile))] + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require (for-syntax racket + racket/syntax + syntax/parse + mzlib/etc + racket/struct-info + syntax/stx + racket/sequence + ;; in-syntax on older versions: + ;;;unstable/sequence + "../lib/low-untyped.rkt") + "../lib/low.rkt" + "../type-expander/type-expander.lp2.rkt" + "../type-expander/multi-id.lp2.rkt") + (provide define-structure + make-structure-constructor + get + structure) + + + + + + + + + + + + + + + + + ; + + + + + + ) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + "../lib/low.rkt" + "../type-expander/type-expander.lp2.rkt" + typed/rackunit) + + + + + + + + (require (submod ".." doc))))] + +@section{Optimizing access to fields} + +We can represent the structuress as lists of key/value pairs. Then, if we know +the field @tc[b] can be at indices 3, 5 and 8 (for exeample), then we can access +it in 3, 5 or 8 steps, depending on the value's structure type, because we have +to traverse the list elements until we reach its value. In the worst case, the +access can be done in @${O(\mathit{max\_index\_for\_b})}, but on average it +should be less because of the fields with low indices. + +We can also represent the structures using racket's structs, this is the method +chosen above. Then, to access the field @tc[b], we need to use the @tc[sᵢ-b] +field, where @tc[sᵢ] is the struct type of the value. To know that type, we need +to test the value's type against all the struct types, which costs +@${O(\left\vert{}S\right\vert)} then the access via @tc[sᵢ-b] can be done in +@${O(1)}. + +A possible optimization would be to add an extra @tc[type-tag] field to all +structs, via a base struct @tc[(struct (T) Base ([type-tag : T]))]. Then, the +child structs would be defined so: + +@chunk[ + (struct (T) Child-Struct Base ([g : String])) + (define-type Child (Child-Struct Child-Tag))] + +The tag can be constructed so that a value's struct type can be known in +@${O(\log{} \left\vert{}S\right\vert)}. diff --git a/graph/graph/type-system.scrbl b/graph/graph/type-system.scrbl new file mode 100644 index 00000000..0c8760e8 --- /dev/null +++ b/graph/graph/type-system.scrbl @@ -0,0 +1,107 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Overview of the implementation choices for structures, graphs and passes} + +@;(table-of-contents) + +@section[#:tag "structures"]{Structures} + +@;(+ 1 2 3) gives @(format "~a" (+ 1 2 3)). + +@;@(require racket/string racket/list) +@;@(string-join (map (λ (x) (format "~a bottles of beer on the wall, take one down and pass it around, ~a bottles of beer on the wall" x (- x 1))) +@; (reverse (range 1 99))) +@; "\n") + +Structures are represented as lists of key/value pairs. +@note{We need lists and can't use vectors (or hash tables) because the latter are mutable in @code|{typed/racket}|, + and the typing system has no guarantee that accessing the same element twice will yield the same value (so occurence typing can't narrow the type in branches of conditionnals).} +@note{Actually, we can use structs (they are immutable by default, and the occurrence typing knows that). There are two problems with them: + we can't have subtyping (although knowing all the structs used in the program means we can just filter them and use a @code{(U S1 S2 …)}, + and to declare the structs, we would need to be in a define-like environment (therefore making anonymous structure types problematic), although since we know all the structs in advance, we can pre-declare them in a shared file.} + +@chunk[ + (define-type abc (List (Pairof 'a Number) + (Pairof 'b String) + (Pairof 'c (U 'x 'y)))) + + (: make-abc (→ Number String (U 'x 'y) abc)) + (define (make-abc a b c) + (list (cons 'a a) (cons 'b b) (cons 'c c))) + (make-abc 1 "b" 'x)] + +Occurrence typing works: + +@chunk[ + (: f (→ abc (U 'x #f))) + (define (f v) + (if (eq? 'x (cdr (cddr v))) + (cdr (cddr v)) + #f))] + +@section{Passes, subtyping and tests} + + +Below is the definition of a function which works on @tc[(structure [a Number] [b String] [c Boolean])], and returns the same structure extended with a field @tc[[d Number]], +but only cares about fields @tc[a] and @tc[c], so tests don't need to provide a value for @tc[b]. + +@chunk[ + (: pass-calc-d (∀ (TB) (→ (List (Pairof 'a Number) + (Pairof 'b TB) + (Pairof 'c Boolean)) + (List (Pairof 'a Number) + (Pairof 'b TB) + (Pairof 'c Boolean) + (Pairof 'd Number))))) + (define (pass-calc-d v) + (list (car v) ; a + (cadr v) ; b + (caddr v) ; c + (cons 'd (+ (cdar v) (if (cdaddr v) 0 1)))))] + +The example above can be called to test it with a dummy value for @tc[b]: + +@chunk[ + (pass-calc-d '((a . 1) (b . no-field) (c . #t)))] + +But when called with a propper value for @tc[b], we get back the original string as expected, and the type is correct: + +@chunk[ + (ann (pass-calc-d '((a . 1) (b . "some string") (c . #t))) + (List (Pairof 'a Number) + (Pairof 'b String) + (Pairof 'c Boolean) + (Pairof 'd Number)))] + +If the pass should be able to work on multiple graph types (with more or less info), then it should be easy to mark it as a @tc[case→] function. +It's probably better to avoid too permissive subtyping, otherwise, imagine we have a pass which removes @tc[Addition]s and @tc[Substraction]s from an AST, +and replaces them with a single @tc[Arithmetic] node type. If we have full duck typing, we could call it with @tc[Addition]s and @tc[Substraction] hidden in fields +it does not know about, and so it would fail to replace them. Also, it could be called with an already-processed AST which already contains just @tc[Arithmetic] node types, +which would be a bug most likely. Therefore, explicitly specifying the graph type on which the passes work seems a good practice. Some parts +can be collapsed easily into a @tc[∀] type @tc[T], when we're sure there shouldn't be anything that interests us there. + +@section{Graphs} + +In order to be able to have cycles, while preserving the benefits of occurrence typing, we need to make sure that from the type system's point of view, accessing a successor node twice will return the same value each time. + +The easiest way is to wrap the to-be-created value inside a @tc[Promise]. Occurrence typing works on those: + +@chunk[ + (: test-promise-occurence (→ (Promise (U 'a 'b)) (U 'a #f))) + (define (test-promise-occurence p) + (if (eq? (force p) 'a) + (force p) + #f))] + +@section{Conclusion} + +@chunk[<*> + (module main typed/racket + + + + + + )] diff --git a/graph/graph/variant.lp2.rkt b/graph/graph/variant.lp2.rkt new file mode 100644 index 00000000..978cd6cc --- /dev/null +++ b/graph/graph/variant.lp2.rkt @@ -0,0 +1,255 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Variants} + +@(table-of-contents) + +@section{Introduction} + +We define variants (tagged unions), with the following constraints: + +@itemlist[ + @item{Unions are anonymous: two different unions can contain the same tag, and + there's no way to distinguish these two occurrences of the tag} + @item{The tag can be followed by zero or more “fields”} + @item{An instance of a variant only @racket[match]es with its constructor and + the same number of fields}] + +See @url{https://github.com/andmkent/datatype/} for an existing module providing +Algebraic Data Types. + +@section{@racket[constructor]} + +We define the variant as a @tc[list], with the tag symbol in the first element. +We can't use a @tc[vector], because these are mutable in @tc[typed/racket], and +occurrence typing can't work properly on mutable data structures (yet). + +@chunk[ + (define-multi-id constructor + #:type-expander + #:match-expander + #:call )] + +@chunk[ + (check-equal? (ann (constructor a 1 "x") + (constructor a Number String)) + (list 'a 1 "x")) + (check-equal? (ann (constructor b) + (constructor b)) + (list 'b)) + (check-equal? (ann (constructor c 2 "y") + (constructor c Number String)) + (constructor c 2 "y")) + (check-not-equal? (constructor d 2 "y") + (constructor d 2 "y" 'z)) + (check-not-equal? (constructor e 2 "y") + (constructor F 2 "y"))] + +@subsection{Type-expander} + +@chunk[ + (λ/syntax-parse (_ tag:id type:expr ...) + #'(List 'tag type ...))] + +@subsection{Match-expander} + +@chunk[ + (λ/syntax-parse (_ tag:id pat:expr ...) + #'(list 'tag pat ...))] + +@subsection{Actual constructor} + +@chunk[ + (λ/syntax-parse (_ tag:id value:expr ...) + (define/with-syntax (arg ...) (generate-temporaries #'(value ...))) + (define/with-syntax (T ...) (generate-temporaries #'(value ...))) + #'((λ #:∀ (T ...) ([arg : T] ...) : (List 'tag T ...) + (list 'tag arg ...)) + value ...))] + +@section{@racket[define-variant]} + +In @tc[define-variant], we only define the type (which is the union of all the +possible constructors. We don't define the constructors, for two reasons: the +same @tc[constructor]s could appear in several variants, so we would define them +twice, and it is likely that a constructor will have the same identifier as an +existing variable or function. + +@chunk[ + (define-syntax/parse (define-variant name [tag:id type:expr ...] ...) + #'(define-type name (U (constructor tag type ...) ...)))] + +@chunk[ + (define-variant v1 [x Number String] [y String Number] [z Number String]) + (check-equal? (ann (constructor x 1 "a") + (U [constructor w Number String] + [constructor x Number String] + [constructor y String Number])) + (constructor x 1 "a")) + (check-equal? (constructor x 1 "a") + (constructor x 1 "a")) + (check-equal? (ann (constructor x 1 "a") v1) + (constructor x 1 "a")) + (check-equal? (ann (constructor x 1 "a") v1) + (ann (constructor x 1 "a") v1)) + (check-not-equal? (ann (constructor x 2 "b") v1) + (ann (constructor y "b" 2) v1)) + (check-not-equal? (ann (constructor x 3 "c") v1) + (ann (constructor z 3 "c") v1))] + +This makes pattern-matching more verbose, though, since we have to specify +@tc[(variant tag pat ...)] each time, instead of just @tc[(tag pat ...)]. I +don't really know how to solve that. It should be noted that constructors are +likely to have names starting with a capital letter, so maybe this reduces the +number of name collisions. + +@section{@racket{tagged}} + +@CHUNK[ + (define-multi-id tagged + #:type-expander + (λ/syntax-parse (_ tag:id . structure-type) + #`(constructor tag #,(syntax/loc #'structure-type + (structure . structure-type)))) + #:match-expander + (λ/syntax-parse (_ tag:id . structure-pat) + #`(constructor tag #,(syntax/loc #'structure-pat + (structure . structure-pat)))) + #:call + (λ/syntax-parse (_ tag:id . structure-field-value) + #`(constructor tag #,(syntax/loc #'structure-field-value + (structure . structure-field-value)))))] + +@chunk[ + (check-equal? (match (ann (tagged foo [x "o"] [y 3] [z 'z]) + (tagged foo + [x String] + [z 'z] + [y Fixnum])) + [(tagged foo z x y) (list z y x)]) + '(z 3 "o"))] + +@section{@racket{define-tagged}} + +@chunk[ + (define-syntax/parse (define-tagged tag:id [field type] ... + (~optional #:type-noexpand)) + (define/with-syntax (pat ...) (generate-temporaries #'(field ...))) + (define/with-syntax (value ...) (generate-temporaries #'(field ...))) + #'(define-multi-id tag + #:type-expand-once + (tagged tag [field type] ...) + #:match-expander + (λ/syntax-parse (_ pat ...) + #'(tagged tag [field pat] ...)) + #:call + (λ/syntax-parse (_ value ...) + #'(tagged tag [field value] ...))))] + +@chunk[ + (define-tagged tagged-s1) + (define-tagged tagged-s2 [f Fixnum] [g String]) + (define-tagged tagged-s3 [g String] [f Fixnum]) + (define-tagged tagged-s4 [f Fixnum] [g String]) + + (check-equal? (match (ann (tagged-s1) (tagged tagged-s1)) + [(tagged-s1) #t]) + #t) + + (check-equal? (match (ann (tagged-s2 99 "z") tagged-s2) + [(tagged-s2 f g) (cons g f)]) + '("z" . 99)) + + (let () + (check-equal? (match (ann (tagged-s2 99 "in-let") tagged-s2) + [(tagged-s2 f g) (cons g f)]) + '("in-let" . 99))) + + (define (test-match val) + (match val + [(tagged-s2 x y) (list 'found-s2 y x)] + [(tagged-s3 x y) (list 'found-s3 y x)] + [(tagged-s4 x y) (list 'found-s4 y x)])) + + (check-equal? + (test-match (ann (tagged-s2 2 "flob") + (tagged tagged-s2 [f Fixnum] [g String]))) + '(found-s2 "flob" 2)) + + (check-equal? + (test-match (ann (tagged-s3 "flob" 2) + (tagged tagged-s3 [g String] [f Fixnum]))) + '(found-s3 2 "flob")) + + ;; g and f are inverted in the “ann” + (check-equal? + (test-match (ann (tagged-s4 2 "flob") + (tagged tagged-s4 [g String] [f Fixnum]))) + '(found-s4 "flob" 2)) + + (define (test-match-verbose val) + (match val + [(tagged tagged-s2 g [f y]) (list 'found-s2 g y)] + [(tagged tagged-s3 [g y] f) (list 'found-s2 f y)] + [(tagged tagged-s4 [f y] g) (list 'found-s2 g y)])) + + (check-equal? + (test-match (ann (tagged-s2 3 "flob") + (tagged tagged-s2 [f Fixnum] [g String]))) + '(found-s2 "flob" 3)) + + ;; g and f are inverted in the “ann” + (check-equal? + (test-match (ann (tagged-s3 "flob" 3) + (tagged tagged-s3 [f Fixnum] [g String]))) + '(found-s3 3 "flob")) + + (check-equal? + (test-match (ann (tagged-s4 3 "flob") + (tagged tagged-s4 [f Fixnum] [g String]))) + '(found-s4 "flob" 3)) + + (check-not-equal? (tagged-s2 4 "flob") + (tagged-s3 "flob" 4)) + (check-not-equal? (tagged-s2 4 "flob") + (tagged-s4 4 "flob"))] + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require (for-syntax syntax/parse + racket/syntax + "../lib/low-untyped.rkt") + "../lib/low.rkt" + "../type-expander/multi-id.lp2.rkt" + "../type-expander/type-expander.lp2.rkt" + "structure.lp2.rkt") + (provide constructor + define-variant + tagged + define-tagged) + + + + + ) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + typed/rackunit + "../lib/low.rkt" + "../type-expander/type-expander.lp2.rkt") + + + + + + + (require (submod ".." doc))))] \ No newline at end of file diff --git a/graph/lib/doc.rkt b/graph/lib/doc.rkt new file mode 100644 index 00000000..9e30fbd0 --- /dev/null +++ b/graph/lib/doc.rkt @@ -0,0 +1,132 @@ +#lang racket + +;; Math +(require slideshow/pict) +(provide (all-from-out slideshow/pict)) +(require "doc/math.rkt") +(provide (all-from-out "doc/math.rkt")) +; @setup-math is returned in @doc-lib-setup. + + + + +;(require "low-untyped.rkt") +;(#lang reader "scribble-custom/lp2.rkt" #:lang typed/racket) + +;; http://lists.racket-lang.org/users/archive/2015-January/065752.html +;; http://bugs.racket-lang.org/query/?cmd=view%20audit-trail&database=default&pr=14068 +(require (for-label (only-meta-in 0 typed/racket))) +(provide (for-label (all-from-out typed/racket))) + +;(require scriblib/footnote) +;(provide (all-from-out scriblib/footnote)) + +(require (only-in scribble/base [margin-note note])) +(provide note) + +(require (for-syntax mzlib/etc)) +(define-syntax (doc-lib-setup stx) + ;(display (build-path (this-expression-source-directory) (this-expression-file-name))) + #'setup-math) ;; NOTE: setup-math must be returned, not just called! + +(provide doc-lib-setup) + +;(require (only-in scribble/manual code)) +;(define-syntax-rule (tc . args) +; (code #:lang "typed/racket" . args)) +;(provide tc) + +(require (only-in scribble/private/lp chunk CHUNK)) +(provide chunk CHUNK) + + + + + + +;; Copied from /usr/local/racket-6.2.900.6/share/pkgs/scribble-lib/scribble/private/lp.rkt + +(require (for-syntax racket/base syntax/boundmap) + scribble/scheme scribble/decode scribble/manual (except-in scribble/struct table)) + +(begin-for-syntax + ;; maps chunk identifiers to a counter, so we can distinguish multiple uses + ;; of the same name + (define chunk-numbers (make-free-identifier-mapping)) + (define (get-chunk-number id) + (free-identifier-mapping-get chunk-numbers id (lambda () #f))) + (define (inc-chunk-number id) + (free-identifier-mapping-put! chunk-numbers id (+ 1 (free-identifier-mapping-get chunk-numbers id)))) + (define (init-chunk-number id) + (free-identifier-mapping-put! chunk-numbers id 2))) + +(define-syntax-rule (make-chunk chunk-id racketblock) + (define-syntax (chunk-id stx) + (syntax-case stx () + [(_ name expr (... ...)) + ;; no need for more error checking, using chunk for the code will do that + (identifier? #'name) + (let* ([n (get-chunk-number (syntax-local-introduce #'name))] + [str (symbol->string (syntax-e #'name))] + [tag (format "~a:~a" str (or n 1))]) + + (when n + (inc-chunk-number (syntax-local-introduce #'name))) + + (syntax-local-lift-expression #'(quote-syntax (a-chunk name expr (... ...)))) + + (with-syntax ([tag tag] + [str str] + [((for-label-mod (... ...)) (... ...)) + (map (lambda (expr) + (syntax-case expr (require) + [(require mod (... ...)) + (let loop ([mods (syntax->list #'(mod (... ...)))]) + (cond + [(null? mods) null] + [else + (syntax-case (car mods) (for-syntax) + [(for-syntax x (... ...)) + (append (loop (syntax->list #'(x (... ...)))) + (loop (cdr mods)))] + [x + (cons #'x (loop (cdr mods)))])]))] + [else null])) + (syntax->list #'(expr (... ...))))] + + [(rest (... ...)) (if n + #`((subscript #,(format "~a" n))) + #`())]) + #`(begin + (require (for-label for-label-mod (... ...) (... ...))) + #,@(if n + #'() + #'((define-syntax name (make-element-id-transformer + (lambda (stx) #'(chunkref name)))) + (begin-for-syntax (init-chunk-number #'name)))) + ;(make-splice + ;(list (make-toc-element + ;#f + ;(list (elemtag '(chunk tag) + ; (bold (italic (racket name)) " ::="))) + ;(list (smaller (elemref '(chunk tag) #:underline? #f + ; str + ; rest (... ...))))) + (racket expr (... ...)))))]))) ;)) + +(make-chunk chunk2 racketblock) +(make-chunk CHUNK2 RACKETBLOCK) + +(define-syntax (chunkref stx) + (syntax-case stx () + [(_ id) + (identifier? #'id) + (with-syntax ([tag (format "~a:1" (syntax-e #'id))] + [str (format "~a" (syntax-e #'id))]) + #'(elemref '(chunk tag) #:underline? #f str))])) + +(provide chunk2 CHUNK2) + +(provide tc TC) +(define-syntax-rule (tc . rest) (chunk2 name . rest)) +(define-syntax-rule (TC . rest) (CHUNK2 name . rest)) diff --git a/graph/lib/doc/MathJax b/graph/lib/doc/MathJax new file mode 160000 index 00000000..ba9afeb5 --- /dev/null +++ b/graph/lib/doc/MathJax @@ -0,0 +1 @@ +Subproject commit ba9afeb5a743249acdea17540b48b14ebc95dbe4 diff --git a/graph/lib/doc/bracket b/graph/lib/doc/bracket new file mode 160000 index 00000000..bcf8a508 --- /dev/null +++ b/graph/lib/doc/bracket @@ -0,0 +1 @@ +Subproject commit bcf8a50895c19d9cd4850184a973deadc6fa6a09 diff --git a/graph/lib/doc/example.lp2.rkt b/graph/lib/doc/example.lp2.rkt new file mode 100644 index 00000000..9ac17225 --- /dev/null +++ b/graph/lib/doc/example.lp2.rkt @@ -0,0 +1,59 @@ +#lang scribble/lp2 +@(require "../doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Implementation of structures} + +@;Racket is distributed with implementations of many SRFIs, most of +@;which can be implemented as libraries. To import the bindings of SRFI +@;@math{n}, use +@; +@;@racketblock[ +@;(require @#,elem{@racketidfont{srfi/}@math{n}}) +@;] + +@section{A section} + +In section @secref{sec:foo} we present, blah blah. + +@subsection[#:tag "sec:foo"]{My subsection} + +@$${\frac{2x}{x^2}} +@(colorize (filled-ellipse 30 15) "blue") +@; Line comment + +Blah @math{n}, as described by M@._ Foo@.__ +@racketblock[ + (require @#,elem{@racketidfont{srfi/}@math{n}})] + +@CHUNK[ + (define (foo) + (syntax-e #`#,"foo"))] + +@(define to-insert 42) +@chunk[<*> + ;(displayln #,to-insert) ;; Should work. + (provide foo) + + + (module* test racket + (require (submod "..")) + (require rackunit) + (check-equal? (foo) "foo") + + (require (submod ".." doc)))] + +It would be nice to be able to alter existing chunks, by inserting stuff later, +for example: + +@chunk[ + (define-syntax-rule (double x) + (+ x x))] + +But we would actually want: + +@chunk[ + (define-syntax-rule (double x) -- should be greyed out + (let ((x-cache x)) + (+ x-cache x-cache))) -- everything except the changed bits should + -- be greyed out] \ No newline at end of file diff --git a/graph/lib/doc/math-scribble b/graph/lib/doc/math-scribble new file mode 120000 index 00000000..453f2811 --- /dev/null +++ b/graph/lib/doc/math-scribble @@ -0,0 +1 @@ +bracket/math-scribble \ No newline at end of file diff --git a/graph/lib/doc/math.rkt b/graph/lib/doc/math.rkt new file mode 100644 index 00000000..f1a2bd8d --- /dev/null +++ b/graph/lib/doc/math.rkt @@ -0,0 +1,36 @@ +#lang racket + +;; This file is derived from the one which can be found at: +;; https://github.com/soegaard/bracket/blob/master/docs/pr-math.rkt + +(require "math-scribble/math-scribble.rkt") + +(provide mathjax-source setup-math + (all-from-out "math-scribble/math-scribble.rkt")) + +(require scribble/html-properties + scribble/base + scribble/core) + +(define mathjax-source + "MathJax/MathJax.js?config=default" + ;"http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML" + ; "http://c328740.r40.cf1.rackcdn.com/mathjax/latest/MathJax.js?config=default" + ;"http://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-HTML" + ) + +(define setup-math + (compound-paragraph + (style #f (list)) + (list + (paragraph + (style + #f (list (alt-tag "script") + (attributes `((type . "text/javascript") + (src . ,mathjax-source ))))) + '()) + (paragraph + (style + #f (list (alt-tag "script") + (attributes '((type . "text/x-mathjax-config"))))) + "MathJax.Hub.Config({ tex2jax: {inlineMath: [['$','$']]} });")))) diff --git a/graph/lib/doc/template.lp2.rkt b/graph/lib/doc/template.lp2.rkt new file mode 100644 index 00000000..1c09d079 --- /dev/null +++ b/graph/lib/doc/template.lp2.rkt @@ -0,0 +1,70 @@ +#lang scribble/lp2 +@(require "../../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Life, the Universe and Everything.} + +@(table-of-contents) + +@section{Introduction} + +@chunk[ + (define foo 42)] + +Here is a macro: + +@CHUNK[ + (define-for-syntax mymacro-tmp + (syntax-rules () [(_ a b) (let ((b 1)) a)])) + (define-syntax (mymacro-stx stx) #`'#,(mymacro-tmp stx)) + (provide mymacro-stx) + (define-syntax mymacro mymacro-tmp)] + +We can use it like this: + +@chunk[ + (mymacro (+ x 3) x)] + +Which expands to (requires a bit of set-up boilerplate to have the output in +scribble, see +@url{http://lists.racket-lang.org/users/archive/2014-December/065175.html}): +@(begin + (require syntax/location scribble/eval) + (define here (quote-source-file)) + (define evaluator (make-base-eval #:lang 'typed/racket)) + (evaluator `(begin + (require (for-syntax racket/base)) + (dynamic-require '(file ,here) #f) + (current-namespace + (module->namespace '(file ,here)))))) + +@interaction[#:eval evaluator + (mymacro-stx (+ x 3) x)] + +@chunk[ + (check-equal? foo 42)] + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require (for-syntax syntax/parse + racket/syntax + "../../lib/low-untyped.rkt") + "../../lib/low-untyped.rkt") + (provide foo) + + + ) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + typed/rackunit) + + + + (require (submod ".." doc))))] \ No newline at end of file diff --git a/graph/lib/eval-get-values.rkt b/graph/lib/eval-get-values.rkt new file mode 100644 index 00000000..2069fe66 --- /dev/null +++ b/graph/lib/eval-get-values.rkt @@ -0,0 +1,11 @@ +#lang typed/racket + +(module m racket + (provide eval-get-values) + + (define (eval-get-values expr namespace) + (call-with-values (λ () (eval expr namespace)) list))) + +(require/typed 'm [eval-get-values (→ Any Namespace (Listof Any))]) + +(provide eval-get-values) diff --git a/graph/lib/lib.rkt b/graph/lib/lib.rkt new file mode 100644 index 00000000..e382012c --- /dev/null +++ b/graph/lib/lib.rkt @@ -0,0 +1,153 @@ +#lang typed/racket + +(require "low.rkt") +(provide (all-from-out "low.rkt")) + +;; Types +(provide AnyImmutable) +;; Functions +(provide ∘ eval-get-values generate-indices) +;; Macros +(provide mapp comment) + +(require "eval-get-values.rkt") + +(define ∘ compose) + +(require (for-syntax syntax/parse + racket/syntax)) + +;; raco pkg install alexis-util +(require alexis/util/threading) + +;; From alexis/util/threading +(provide ~> ~>> _ (rename-out [_ ♦])) + +(define-syntax (comment stx) + #'(values)) + +(define-type AnyImmutable (U Number + Boolean + True + False + String + Keyword + Symbol + Char + Void + ;Input-Port ;; Not quite mutable, but not really immutable either. + ;Output-Port ;; Not quite mutable, but not really immutable either. + ;Port ;; Not quite mutable, but not really immutable either. + #| I haven't checked the mutability of the ones 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 + |# + ; Undefined ;; We definitely don't want that one, it's not mutable but it's an error if present anywhere 99.9% of the time. + #| + 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. + ; -> ; Not 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))))))))])) +(: 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/graph/lib/low-untyped.rkt b/graph/lib/low-untyped.rkt new file mode 100644 index 00000000..f4c9ce0f --- /dev/null +++ b/graph/lib/low-untyped.rkt @@ -0,0 +1,16 @@ +#lang typed/racket/no-check + +;; When creating the html document with scribble/lp2, it does not see the macros defined in low.rkt when including it with sugar/include. +;; Using a raw include/reader works. + +;(require sugar/include) +;(include-without-lang-line "low.rkt") + +;; typed/racket/no-check does not require (for-syntax racket/base). TODO: file a bug report? +(require (for-syntax racket/base)) +(include/reader "low.rkt" (λ (source-name in) + (port-count-lines! in) + (do () + [(let-values ([(line column position) (port-next-location in)]) (> line 1))] + (read-line in)) + (read-syntax source-name in))) \ No newline at end of file diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt new file mode 100644 index 00000000..503d9c32 --- /dev/null +++ b/graph/lib/low.rkt @@ -0,0 +1,344 @@ +#lang typed/racket + +(provide degub) +(: degub (∀ (T) (→ T T))) +(define (degub x) (display "degub:") (displayln x) x) + +;; ==== low/require-provide.rkt ==== +(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)) + +;; ==== low/define-syntax-parse.rkt ==== +(require syntax/parse + syntax/parse/define) + +(provide define-syntax/parse + λ/syntax-parse) + +(begin-for-syntax + (require (for-syntax racket/base + racket/stxparam) + racket/stxparam) + + (provide stx) + + (define-syntax-parameter stx + (lambda (stx) + (raise-syntax-error (syntax-e stx) "Can only be used in define-syntax/parse")))) + +(define-simple-macro (define-syntax/parse (name . args) . body) + (define-syntax (name stx2) + (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-parse stx2 + [(_ . args) . body])))) + +(define-simple-macro (λ/syntax-parse args . body) + (λ (stx2) + ;(syntax-parameterize ([stx (make-rename-transformer #'stx2)]) + (syntax-parse stx2 + [args . body])));) + +;; If you include this as a file, you need to do: +;(begin-for-syntax (provide stx)) +;; It's not provided by (all-from-out) :-( + +;; ==== low/check-type-and-equal.rkt ==== +(require ;"define-syntax-parse.rkt" + (for-syntax syntax/parse + syntax/parse/experimental/template) + typed/rackunit) + +(provide check-equal:?) + +;; TODO: this won't expand types in the ann. + +(define-syntax/parse + (check-equal:? actual + (~optional (~seq (~datum :) type)) + expected) + (template (check-equal? (?? (ann actual type) actual) expected))) + +;; ==== low/typed-fixnum.rkt === + +(provide fxxor) + +;; 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)) + +(module+ test + (require typed/rackunit) + (check-equal? (fxxor2 13206 23715) 28469) + (check-equal? (fxxor 0) 0) + (check-equal? (fxxor 13206) 13206) + (check-equal? (fxxor 13206 23715 314576) 304101)) + +;; ==== Rest ==== +(provide nameof + first-value second-value third-value fourth-value fifth-value sixth-value seventh-value eighth-value ninth-value tenth-value + (rename-out [compose ∘]) + stx-list + stx-e + stx-pair + ;string-set! + ;string-copy! + ;string-fill! + with-output-file + in-tails + in-heads + in-split + in-split* + *in-split + my-in-syntax + indexof + Syntax-Listof + check-duplicate-identifiers) + +(require (for-syntax syntax/parse syntax/parse/experimental/template)) + +(define-syntax-rule (nameof x) (begin x 'x)) + +(module+ test + (require typed/rackunit) + (let ((y 3)) + (check-equal? (nameof y) 'y))) + +;(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)) + +(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)))) + +(define-syntax-rule (define-value-getter name v ... last-v) + (define-syntax-rule (name expr) + (call-with-values (λ () expr) (λ (v ... last-v . rest) last-v)))) + +(define-value-getter first-value v1) +(define-value-getter second-value v1 v2) +(define-value-getter third-value v1 v2 v3) +(define-value-getter fourth-value v1 v2 v3 v4) +(define-value-getter fifth-value v1 v2 v3 v4 v5) +(define-value-getter sixth-value v1 v2 v3 v4 v5 v6) +(define-value-getter seventh-value v1 v2 v3 v4 v5 v6 v7) +(define-value-getter eighth-value v1 v2 v3 v4 v5 v6 v7 v8) +(define-value-getter ninth-value v1 v2 v3 v4 v5 v6 v7 v8 v9) +(define-value-getter tenth-value v1 v2 v3 v4 v5 v6 v7 v8 v9 v10) + +(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)) + +(define-match-expander stx-list + (lambda (stx) + (syntax-case stx () + [(_ pat ...) + #'(? syntax? + (app syntax->list (list pat ...)))]))) + +(module+ test + (require typed/rackunit) + (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 b c) (list (syntax-e c) + (syntax-e b) + (syntax-e a))]) + '(3 2 1))) + +(define-match-expander stx-e + (lambda (stx) + (syntax-case stx () + [(_ pat) + #'(? syntax? + (app syntax-e pat))]))) + +(module+ test + (require typed/rackunit) + (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))) + +(define-match-expander stx-pair + (lambda (stx) + (syntax-case stx () + [(_ pat-car pat-cdr) + #'(? syntax? + (app syntax-e (cons pat-car pat-cdr)))]))) + +(module+ test + (require typed/rackunit) + (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))) + +(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)) + +#| +(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))))])) + +(: 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)))) + +;; Can't write the type of on-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))) + +(: 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)))))) + +;; 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) + (my-in-syntax #'((a . b) (c . d))) ; (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 e))) ; (ann `(,#'a ,#'b ,#'c ,#'d ,#'e) (Listof (Syntaxof (U 'a 'b 'c 'd)))) + (my-in-syntax #'())) ; (ann '() (Listof (Syntaxof Nothing))) + + +(: check-duplicate-identifiers (→ (Syntaxof (Listof (Syntaxof Symbol))) + Boolean)) +(define (check-duplicate-identifiers ids) + (if (check-duplicate-identifier (my-in-syntax ids)) #t #f)) + +(require syntax/parse/define) +(provide define-simple-macro) + +(require racket/match) +(provide (all-from-out racket/match) + (rename-out [match-lambda match-λ] + [match-lambda* match-λ*] + [match-lambda** match-λ**])) diff --git a/graph/lib/path.rkt b/graph/lib/path.rkt new file mode 100644 index 00000000..a5726e45 --- /dev/null +++ b/graph/lib/path.rkt @@ -0,0 +1,15 @@ +#lang typed/racket +;(require mzlib/etc) +;(this-expression-file-name) + +(provide define-to-this-file-name) + +(define-syntax (define-to-this-file-name stx) + (syntax-case stx () + [(_ name) + #`(begin (define name #,(syntax-source #'dummy)) + (define-for-syntax name #,(syntax-source #'dummy)))])) + +;(define-syntax (get-current-file stx) +; #`(format "Macro in ~a, Use in ~a" structure.rkt-path #,(syntax-source stx))) + diff --git a/graph/lib/syntax/quasitemplate.rkt b/graph/lib/syntax/quasitemplate.rkt new file mode 100644 index 00000000..753dbdc1 --- /dev/null +++ b/graph/lib/syntax/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/graph/lib/test-framework.rkt b/graph/lib/test-framework.rkt new file mode 100644 index 00000000..0a0eda22 --- /dev/null +++ b/graph/lib/test-framework.rkt @@ -0,0 +1,44 @@ +#lang typed/racket + +;; Using check-equal? on our variants 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) ;; typed/racket risks complaining that it can't do for-meta in all-from-out otherwise. + 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/graph/lib/untyped.rkt b/graph/lib/untyped.rkt new file mode 100644 index 00000000..a894c58f --- /dev/null +++ b/graph/lib/untyped.rkt @@ -0,0 +1,5 @@ +#lang typed/racket + +(require "low-untyped.rkt") +(require/provide "untyped/for-star-list-star.rkt" + "untyped/ids.rkt") \ No newline at end of file diff --git a/graph/lib/untyped/for-star-list-star.rkt b/graph/lib/untyped/for-star-list-star.rkt new file mode 100644 index 00000000..5bf781d6 --- /dev/null +++ b/graph/lib/untyped/for-star-list-star.rkt @@ -0,0 +1,46 @@ +#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)) + #'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/graph/lib/untyped/ids.rkt b/graph/lib/untyped/ids.rkt new file mode 100644 index 00000000..4f628484 --- /dev/null +++ b/graph/lib/untyped/ids.rkt @@ -0,0 +1,114 @@ +#lang racket + +(provide format-ids + hyphen-ids + format-temp-ids + #|t/gen-temp|#) + +(require racket/syntax) ;; Used to bind format-id in macroexpansion below. +(require racket/sequence) ;; Used to bind in-syntax in macroexpansion below. +;; Used to bind in-syntax on older versions in macroexpansion below: +;(require unstable/sequence) +(require (for-syntax racket/syntax + syntax/parse + racket/string + racket/sequence + ;unstable/sequence ;; in-syntax on older versions + #|syntax/parse/experimental/template|#) + syntax/strip-context) + +;; Actually, this could be just a regular function: +;; test (with list?, syntax? and combinations thereof) if we should iterate or +;; just put the value as-is. +(begin-for-syntax + (define-syntax-class var-expr + #:description + (string-append "#'identifier or #'(identifier ooo), where ooo is a" + " literal “...”, or #'(identifier ...), or an expression") + (pattern (~and whole ((~literal syntax) var:id)) + #:with code #'(in-value whole)) + (pattern (~and whole ((~literal syntax) (var:id (~literal ...)))) + #:with code #'(in-syntax whole)) + (pattern (~and whole ((~literal syntax) (vars:id ...))) + #:with (var . _) #`(vars ... #,(gensym 'empty)) + #:with code #'(in-syntax whole)) + (pattern expr:expr + #:with var (gensym) + #:with code #'(let ((s expr)) (if (string? s) (in-value s) s))))) + +;; TODO: infinite loop if we only have constants which ar handled with for-value +(define-syntax (format-ids stx) + (syntax-parse stx + [(_ lexical-context:expr format:expr v:var-expr ...) + (define/with-syntax (tmp ...) (generate-temporaries #'(v.var ...))) + #'(let ([lex-ctx lexical-context]) + (for/list ([tmp v.code] ...) + (format-id (if (procedure? lex-ctx) (lex-ctx tmp ...) lex-ctx) + format + tmp ...)))])) + +(define-syntax (hyphen-ids stx) + (syntax-parse stx + ;; TODO: allow single #'foo instead of (var expr), and use in-value + [(_ lexical-context:expr v:var-expr ...) + #`(format-ids lexical-context + #,(string-join (for/list ([x (in-syntax #'(v ...))]) "~a") + "-") + v ...)])) + +(define-syntax (format-temp-ids stx) + (syntax-parse stx + [(_ . rest) + ;; Introduce the binding in a fresh scope. + #'(format-ids (λ _ ((make-syntax-introducer) #'())) . rest)])) + +#| +(define-template-metafunction (t/gen-temp stx) + (syntax-parse stx + [(_ . id:id) + #:with (temp) (generate-temporaries #'(id)) + #'temp] + [(_ id:id ...) + (generate-temporaries #'(id ...))])) +|# + +(module* test racket + (require (submod "..") + rackunit + (for-syntax racket/syntax + (submod ".."))) + + (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)) + + (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)))) diff --git a/graph/main.rkt b/graph/main.rkt new file mode 100644 index 00000000..44dacdd3 --- /dev/null +++ b/graph/main.rkt @@ -0,0 +1,207 @@ +#lang typed/racket + +(require "type-expander/type-expander.lp2.rkt") +(require "type-expander/multi-id.lp2.rkt") +(require "graph/variant.lp2.rkt") + + +(define-type from (List (Pairof Number Boolean) + (Listof (U Number (Pairof Number String))))) +(define-type to (List (Pairof String Boolean) + (Listof (U String (Pairof String String))))) + +(: convert1 (→ from to)) +(define (convert1 v) + (match v [(list a b) (list (convert2 a) (convert3 b))])) + +(: convert2 (→ (Pairof Number Boolean) (Pairof String Boolean))) +(define (convert2 v) + (match v [(cons a b) (cons (convert4 a) (convert5 b))])) + +(: convert3 (→ (Listof (U Number (Pairof Number String))) + (Listof (U String (Pairof String String))))) +(define (convert3 v) + (match v [(? list?) (map convert6 v)])) + +(: convert4 (→ Number String)) +(define (convert4 v) + (match v [(? number?) (format "~a" v)])) + +(: convert5 (→ Boolean Boolean)) +(define (convert5 v) + (match v [(? boolean?) v])) + +(: convert6 (→ (U Number (Pairof Number String)) + (U String (Pairof String String)))) +(define (convert6 v) + (match v + [(? number?) (format "~a" v)] + [(? pair?) (cons (convert4 (car v)) (convert7 (cdr v)))])) + +(: convert7 (→ String String)) +(define (convert7 v) + (match v [(? string?) v])) + +(require typed/rackunit) +(check-equal? (convert1 '((123 . #t) (1 2 (3 . "b") 4 (5 . "x") 6))) + '(("123" . #t) ("1" "2" ("3" . "b") "4" ("5" . "x") "6"))) + + + + +#| +(define-type from (List (Pairof Number Boolean) (Listof Number))) +(define-type to (List (Pairof String Boolean) (Listof String))) + +(: convert (case→ (→ from to) + (→ (Pairof (Listof Number) Null) (Pairof (Listof String) Null)) + (→ (Pairof Number Boolean) (Pairof String Boolean)) + (→ (Listof Number) (Listof String)) + (→ Number String) + (→ Boolean Boolean))) +(define (convert v) + (cond + [(pair? v) (cons (convert (car v)) (convert (cdr v)))] + [(null? v) v] + [(number? v) (format "~a" v)] + [(boolean? v) v])) +|# + + + + + + + +;; Tests with incomplete / outer-incomplete type-expander. + +(define-type-expander (outer-incomplete stx) + (syntax-case stx () + [(_ n) + #;(raise-syntax-error + 'incomplete + (format "Type doesn't have an incomplete counterpart: ~a" + (syntax->datum #'n)) + #'n) + ;; Just for testing: + #''error])) + +(define-type C Boolean) + +(define-type C/incomplete (Pairof 'C Boolean)) + +(define-type-expander (incomplete stx) + (syntax-case stx () + [(_ n) + (cond [(free-identifier=? #'n #'C) #'C/incomplete] + [else #'(outer-incomplete n)])])) + +(let () + (define-type-expander (outer-incomplete stx) + (syntax-case stx () [(_ n) #'(incomplete n)])) + (let () + (define-type A Number) + (define-type B String) + + (define-type A/incomplete (Pairof 'A Number)) + (define-type B/incomplete (Pairof 'B String)) + + (define-type-expander (incomplete stx) + (syntax-case stx () + [(_ n) + (cond [(free-identifier=? #'n #'A) #'A/incomplete] + [(free-identifier=? #'n #'B) #'B/incomplete] + [else + #'(outer-incomplete n)])])) + + (define-type TA A) + (define-type TAI (incomplete A)) + (displayln (ann '(A . 1) TAI)) + + (define-type TC C) + (define-type TCI (incomplete C)) + (displayln (ann #t TC)) + (displayln (ann '(C . #t) TCI)) + + (let () + (define-type A Boolean) + (define-type TA A) + (define-type TAI (incomplete A)) + (displayln (ann 'error TAI)) + (void)))) + +(require (prefix-in tr: typed/racket)) + +;(define-type ma (tagged ma (fav String) (faa ma) (fab mb))) +;(define-type mb (tagged mb (fbv String) (fba ma))) + +;(define-type ma (List (U ma Number) (U ma Number)) #:omit-define-syntaxes) +;(define-multi-id ma +; #:match-expander (λ (stx) #'(list a b)) +; #:call (λ (stx) #'(list 1 (list 2 3)))) + +;(match (ann (ma) ma) +; [(ma) #t]) + + +#| +(module m typed/racket + (provide ma) + (require "type-expander/type-expander.lp2.rkt") + (require "graph/variant.lp2.rkt") + + ;(let () + ;(define-tagged ma (fav String)) + ;(define-tagged ma (fav String) (faa ma) (fab mb)) + (define-tagged ma (fav String) (faa ma) (fab Number)) + ;(define-tagged mb (fbv String) (fba ma)) + (define-type ma/incomplete ma) + ;(define-type mb/incomplete mb) + (void);) + ) + +(require 'm) +|# + +#| +(require "graph/graph.rkt") + +(define ma "boom") + +(graph g + [ma (fav String) + (faa ma) + (fab mb)] + [mb (fbv String) + (fba ma)]) + +(define mb "boom") +|# + +#| +(require typed/rackunit) + +;(require "graph/structure.lp2.rkt") +;(get ((make-struct-constructor a b c d) 1 "b" 'value-c 4) c) + +(require "type-expander/type-expander.lp2.rkt") +(: w0 `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d)) +(define w0 '(2 "abc" #,(x . z) #(1 "b" x) d)) + +(require (for-syntax racket/list)) +(define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + +(: x (→ (Repeat Number 5))) +(define (x) (list 1 2 3 4 5)) +(check-equal? (x) '(1 2 3 4 5)) + +(require "graph/structure.lp2.rkt") +(define-structure st2 [b String] [a Number]) + +(module* test typed/racket + (require (submod ".."))) + +|# diff --git a/graph/make/.gitignore b/graph/make/.gitignore new file mode 100644 index 00000000..0325c471 --- /dev/null +++ b/graph/make/.gitignore @@ -0,0 +1 @@ +/make diff --git a/graph/make/lib.rkt b/graph/make/lib.rkt new file mode 100644 index 00000000..489e8208 --- /dev/null +++ b/graph/make/lib.rkt @@ -0,0 +1,194 @@ +#lang typed/racket + +(provide make/proc + argv + string-prefix? + string-suffix? + find-files-by-extension + t-rule + rules + ;rule + implicit-rule + for/rules + path-string->string + path-string->path + path-append + regexp-case + dirname + underscore-extension + compile-zos + rkt->zo-dir + rkt->zo-file + make-collection + run + run!) + +(require/typed make [make/proc (→ (Listof + (Pairof (U Path-String (Listof Path-String)) + (Pairof (Listof Path-String) + (U Null + (List (-> Any)))))) + (U String (Vectorof String) (Listof String)) + Void)]) +;(require/typed make/collection [make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) Void)]) + +(require/typed srfi/13 + [string-suffix? (->* (String String) (Integer Integer Integer Integer) Boolean)] + [string-prefix? (->* (String String) (Integer Integer Integer Integer) Boolean)]) + +(define (find-files-by-extension [ext : String]) + (find-files (λ ([path : Path]) (string-suffix? ext (path->string path))))) + +;(: drop-extension (→ Path-String * String String)) +;(define (drop-extension path . exts) +; (map (λ () exts) + +(define-type t-rule (Pairof (U Path-String (Listof Path-String)) + (Pairof (Listof Path-String) + (U Null + (List (-> Any)))))) +(: rules (→ (U t-rule (Listof t-rule)) * (Listof t-rule))) +(define (rules . rs) + (apply append (map (λ ([x : (U t-rule (Listof t-rule))]) + (cond [(null? x) '()] ;; x = '() is an empty (Listof t-rule) + [(null? (cdr x)) x] ;; x = '([target dep maybe-proc]) is a (Listof t-rule) with just one element + [(null? (cadr x)) (list x)] ;; x = '[target () maybe-proc] is a t-rule with an empty list of dependencies + ;; Below, either x = '[target (dep₁ . ?) maybe-proc] or x = '([target dep maybe-proc] [target dep maybe-proc]) + [(null? (cdadr x)) (list x)] ;; x = '[target (dep₁ . ()) maybe-proc] + [(list? (cadadr x)) x] ;; x = '([target dep maybe-proc] [target (?) maybe-proc]) + [else (list x)])) ; x = '[target (dep₁ dep₂ . ()) maybe-proc] + rs))) + +#| +(define-syntax (rule stx) + (syntax-case stx () + [(_ (target ...) (depend ...) body0 . body) + #'(list (list target ...) + (list depend ...) + (λ () body0 . body))] + [(_ (target ...) (depend ...)) + #'(list (list target ...) + (list depend ...))])) +|# + +(define-syntax-rule (implicit-rule (arg ...) (target ...) (depend ...) body ...) + (λ ([arg : Path] ...) + (list (list target ...) + (list depend ...) + (λ () body ...)))) + +(define-syntax-rule (for/rules ([arg files] ...) (target ...) (depend ...) body ...) + (map (implicit-rule (arg ...) (target ...) (depend ...) body ...) files ...)) + +(: path-string->string (→ Path-String String)) +(define (path-string->string ps) + (if (string? ps) + ps + (path->string ps))) + +(: path-string->path (→ Path-String Path)) +(define (path-string->path ps) + (if (string? ps) + (string->path ps) + ps)) + +(: path-append (→ Path-String Path-String Path)) +(define (path-append a b) + (string->path (string-append (path-string->string a) + (path-string->string b)))) + +(define-syntax-rule (regexp-case input [pattern replacement] ...) + (let ([input-cache input]) ;; TODO: should also cache the patterns, but lazily. + (cond + [(regexp-match pattern input-cache) (regexp-replace pattern input-cache replacement)] + ... + [else input-cache]))) + +(: dirname (→ Path Path)) +(define (dirname p) + (let-values ([(base name must-be-dir?) (split-path p)]) + (case base + ['relative (build-path 'same)] ;; If the path is "..", then this is wrong. + ['#f (error (format "Can't get parent directory of ~a" p))] + [else base]))) + +(: underscore-extension (→ Path-String String * Path)) +(define (underscore-extension path . ext) + (if (null? ext) + (path-string->path path) + (let ([p (path-string->string path)] + [e (path-string->string (car ext))]) + (if (string-suffix? (car ext) p) + (let* ([pos (- (string-length p) (string-length e))] + [left (substring p 0 pos)]) + (string->path (string-append left (string-replace e "." "_")))) + (apply underscore-extension path (cdr ext)))))) + +;; TODO: do pattern-matching on paths, with (match) ? + +(define (argv) + (let ([argv (current-command-line-arguments)]) + (if (= (vector-length argv) 0) + #("zo") + argv))) + +;; make-collection from /usr/local/racket-6.2.900.6/share/pkgs/make/collection-unit.rkt +(require/typed compiler/compiler [compile-zos (->* (Any) (#:module? Any #:verbose? Any) (→ (Listof Path-String) (U Path-String #f 'auto) Void))]) +(require/typed dynext/file [append-zo-suffix (→ Path-String Path)]) + +(: cache (∀ (T) (→ (→ T) (→ T)))) +(define (cache producer) + (let ([cache : (U False (List T)) #f]) ;; Use (List T) instead of T, so that if the producer returns #f, we don't call it each time. + (λ () + (let ([c cache]) ;; since cache is mutated by set!, occurrence typing won't work on it, so we need to take a copy. + (if c + (car c) + (let ((producer-result (producer))) + (set! cache (list producer-result)) + producer-result)))))) + +(: rkt->zo-dir (→ Path-String Path)) +(define (rkt->zo-dir src-file) + (simplify-path (build-path src-file 'up "compiled") #f)) + +(: rkt->zo-file (→ Path-String Path)) +(define (rkt->zo-file src-file) + (build-path (rkt->zo-dir src-file) (append-zo-suffix (assert (file-name-from-path src-file))))) + +(: make-collection (→ Any (Listof Path-String) (U String (Vectorof String)) Void)) +(define (make-collection collection-name collection-files argv) + (printf "building collection ~a: ~a\n" collection-name collection-files) + (let* ([zo-compiler (cache (λ () (compile-zos #f)))] + [src-dir (current-directory)] + [rkts (sort collection-files + (lambda ([a : Path] [b : Path]) + (string-cistring a) (path->string b))))] + [zos (map (lambda ([rkt : Path-String]) + (rkt->zo-file rkt)) + rkts)] + [rkt->zo-list + (map (lambda ([rkt : Path-String] [zo : Path]) + `(,zo (,rkt) + ,(lambda () + (let ([dest (rkt->zo-dir rkt)]) + (unless (directory-exists? dest) (make-directory dest)) + ((zo-compiler) (list rkt) dest))))) + rkts zos)]) + (make/proc (append `(("zo" ,zos)) rkt->zo-list) argv))) + +(: run (→ (U Path-String (Pairof Path-String (Listof (U Path-String Bytes)))) [#:set-pwd? Any] (U Path-String Bytes) * Boolean)) +(define (run arg0 #:set-pwd? [set-pwd? #f] . args) + (if (list? arg0) + (apply run arg0) + (begin + (displayln (string-append (string-join (cons (path-string->string arg0) (map (λ (x) (format "~a" x)) args)) " "))) + (display "\033[1;34m") + (flush-output) + (let ((result (apply system* arg0 args))) + (display "\033[m") + (flush-output) + (unless result + (raise "Command failed.")) + result)))) + +(define-syntax-rule (run! . rest) (let () (run . rest) (values))) \ No newline at end of file diff --git a/graph/make/make.rkt b/graph/make/make.rkt new file mode 100644 index 00000000..c532eb22 --- /dev/null +++ b/graph/make/make.rkt @@ -0,0 +1,82 @@ +#lang typed/racket + +(require "lib.rkt") + +(displayln "Make started") +;(current-directory "..") + +; TODO: +;raco pkg install alexis-util +;And some other collections too. +; +;cat graph/structure.lp2.rkt | awk '{if (length > 80) print NR "\t" length "\t" $0}' | sed -e 's/^\([0-9]*\t[0-9]*\t.\{80\}\)\(.*\)$/\1\x1b[0;30;41m\2\x1b[m/' + +;; TODO: should directly exclude them in find-files-by-extension. +(define excluded-dirs (list "docs/" "bug/" "lib/doc/bracket/" "lib/doc/math-scribble/" "lib/doc/MathJax/")) +(define (exclude-dirs [files : (Listof Path)] [excluded-dirs : (Listof String) excluded-dirs]) + (filter-not (λ ([p : Path]) + (ormap (λ ([excluded-dir : String]) + (string-prefix? excluded-dir (path->string p))) + excluded-dirs)) + files)) + +(define scrbl-files (exclude-dirs (find-files-by-extension ".scrbl"))) +(define lp2-files (exclude-dirs (find-files-by-extension ".lp2.rkt"))) +(define rkt-files (exclude-dirs (find-files-by-extension ".rkt"))) +(define html-sources (append scrbl-files lp2-files)) +(define html-files (map (λ ([scrbl-or-lp2 : Path]) (build-path "docs/" (regexp-case (path->string scrbl-or-lp2) [#rx"\\.scrbl" ".html"] [#rx"\\.lp2\\.rkt" ".lp2.html"]))) + html-sources)) +(define mathjax-links (map (λ ([d : Path]) (build-path d "MathJax")) (remove-duplicates (map dirname html-files)))) + +(: scribble (→ Path (Listof Path) Any)) +(define (scribble file all-files) + (run `(,(or (find-executable-path "scribble") (error "Can't find executable 'scribble'")) + "--html" + "--dest" ,(build-path "docs/" (dirname file)) + "+m" + "--redirect-main" "http://docs.racket-lang.org/" + "--info-out" ,(build-path "docs/" (path-append file ".sxref")) + ,@(append-map (λ ([f : Path-String]) : (Listof Path-String) + (let ([sxref (build-path "docs/" (path-append f ".sxref"))]) + (if (file-exists? sxref) + (list "++info-in" sxref) + (list)))) + (remove file all-files)) + ,file))) + +;(make-collection "phc" rkt-files (argv)) +;(make-collection "phc" '("graph/all-fields.rkt") #("zo")) +;(require/typed compiler/cm [managed-compile-zo (->* (Path-String) ((→ Any Input-Port Syntax) #:security-guard Security-Guard) Void)]) +;(managed-compile-zo (build-path (current-directory) "graph/all-fields.rkt")) + +;; make-collection doesn't handle dependencies due to (require), so if a.rkt requires b.rkt, and b.rkt is changed, a.rkt won't be rebuilt. +;; this re-compiles each-time, even when nothing was changed. +;((compile-zos #f) rkt-files 'auto) + +;; This does not work, because it tries to create the directory /usr/local/racket-6.2.900.6/collects/syntax/parse/private/compiled/drracket/ +;(require/typed compiler/cm [managed-compile-zo (->* (Path-String) ((→ Any Input-Port Syntax) #:security-guard Security-Guard) Void)]) +;(for ([rkt rkt-files]) +; (managed-compile-zo (build-path (current-directory) rkt))) + +(run! `(,(or (find-executable-path "raco") (error "Can't find executable 'raco'")) + "make" + ,@rkt-files)) + +(make/proc + (rules (list "zo" (append html-files + mathjax-links)) + (for/rules ([scrbl-or-lp2 html-sources] + [html html-files]) + (html) + (scrbl-or-lp2) + (scribble scrbl-or-lp2 html-sources)) + (for/rules ([mathjax-link mathjax-links]) + (mathjax-link) + () + (make-file-or-directory-link (simplify-path (apply build-path `(same ,@(map (λ (x) 'up) (explode-path (dirname mathjax-link))) "lib" "doc" "MathJax")) #f) + mathjax-link))) + (argv)) + +(run! `(,(or (find-executable-path "raco") (error "Can't find executable 'raco'")) + "cover" + ,@(exclude-dirs rkt-files (list "make/")))) diff --git a/graph/type-expander/multi-id.lp2.rkt b/graph/type-expander/multi-id.lp2.rkt new file mode 100644 index 00000000..1a6c866e --- /dev/null +++ b/graph/type-expander/multi-id.lp2.rkt @@ -0,0 +1,182 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Easy declararation of new identifiers with + type-expander, match-expander, …} + +@section{@racket[multi-id]} + +TODO: maybe we should cache @tc[p-else] and @tc[p-get]. + +@chunk[ + #'(raise-syntax-error + 'self + (format "can't set ~a" (syntax->datum #'self)))] + +@chunk[ + (define-splicing-syntax-class kw-else + (pattern (~seq #:mutable-else p-else) + #:with p-just-set! #'#'(set! p-else . rest) + #:with p-just-call #'#'(p-else . rest) + #:with p-just-id #'#'p-else) + (pattern (~seq #:else p-else) + #:with p-just-set! + #:with p-just-call #'#'(p-else . rest) + #:with p-just-id #'#'p-else))] + +@chunk[ + (define-splicing-syntax-class kw-set!+call+id + (pattern (~seq (~optional (~seq #:set! p-user-set!:expr)) + (~optional (~or (~seq #:call p-user-call:expr) + (~seq #:call-id p-user-call-id:id))) + (~optional (~seq #:id p-user-id:expr))) + #:attr p-just-set! + (and (attribute p-user-set!) #'(p-user-set! stx)) + #:attr p-just-call + (cond [(attribute p-user-call) + #'(p-user-call stx)] + [(attribute p-user-call-id) + #'(syntax-case stx () + [(_ . rest) #'(p-user-call-id . rest)])] + [else #f]) + #:attr p-just-id + (and (attribute p-user-id) #'(p-user-id stx))))] + +Since we have an issue with the type-expander and recursive types (it goes in an +infinite loop), we temporarily provide a workaround with the +@tc[#:type-noexpand] and @tc[#:type-expand-once] keywords. + +@chunk[ + (require (only-in typed/racket [define-type tr:define-type])) + + (begin-for-syntax + + ) + (define-syntax/parse + (define-multi-id name:id + (~optional (~or (~seq #:type-expander p-type:expr) + (~seq #:type-noexpand p-type-noexpand:expr) + (~seq #:type-expand-once p-type-expand-once:expr))) + (~optional (~or (~seq #:match-expander p-match:expr) + (~seq #:match-expander-id p-match-id:id))) + (~optional (~seq #:custom-write p-write:expr)) + (~or (~seq #:set!-transformer p-set!:expr) + :kw-else + :kw-set!+call+id)) + (template + (begin + (?? (tr:define-type name p-type-noexpand #:omit-define-syntaxes)) + (?? (define-type name p-type-expand-once #:omit-define-syntaxes)) + (define-syntax name + (let () + (struct tmp () + (?? (?@ #:property prop:type-expander p-type)) + (?? (?@ #:property prop:match-expander p-match)) + (?? (?@ #:property prop:match-expander + (λ (stx) (syntax-case stx () + [(_ . rest) #'(p-match-id . rest)])))) + (?? (?@ #:property prop:custom-write p-write)) + #:property prop:set!-transformer + (?? p-set! + (λ (_ stx) + (syntax-case stx (set!) + [(set! self . rest) (?? p-set! )] + (?? [(_ . rest) p-just-call]) + (?? [_ p-just-id]))))) + (tmp))))))] + +@chunk[ + (define (p1 [x : Number]) (+ x 1)) + + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + + (define-multi-id foo + #:type-expander + (λ (stx) #'(List (Repeat Number 3) 'x)) + #:match-expander + (λ (stx) #'(vector _ _ _)) + #:custom-write + (λ (self port mode) (display "custom-write for foo" port)) + #:set!-transformer + (λ (_ stx) + (syntax-case stx (set!) + [(set! self . _) + (raise-syntax-error 'foo (format "can't set ~a" + (syntax->datum #'self)))] + [(_ . rest) #'(+ . rest)] + [_ #'p1]))) + + (check-equal? (ann (ann '((1 2 3) x) foo) + (List (List Number Number Number) 'x)) + '((1 2 3) x)) + + ;(set! foo 'bad) + + (let ([test-match (λ (val) (match val [(foo) #t] [_ #f]))]) + (check-equal? (test-match #(1 2 3)) #t) + (check-equal? (test-match '(1 x)) #f)) + + (check-equal? (foo 2 3) 5) + (check-equal? (map foo '(1 5 3 4 2)) '(2 6 4 5 3))] + +It would be nice to test the @tc[(set! foo 'bad)] case, but grabbing the +compile-time error is a challenge (one could use @tc[eval], but it's a bit heavy +to configure). + +Test with @tc[#:else]: + +@chunk[ + (define-multi-id bar + #:type-expander + (λ (stx) #'(List `,(Repeat 'x 2) Number)) + #:match-expander + (λ (stx) #'(cons _ _)) + #:custom-write + (λ (self port mode) (display "custom-write for foo" port)) + #:else p1) + + (check-equal? (ann (ann '((x x) 79) bar) + (List (List 'x 'x) Number)) + '((x x) 79)) + + ;(set! bar 'bad) + + (let ([test-match (λ (val) (match val [(bar) #t] [_ #f]))]) + (check-equal? (test-match '(a . b)) #t) + (check-equal? (test-match #(1 2 3)) #f)) + + (check-equal? (bar 6) 7) + (check-equal? (map bar '(1 5 3 4 2)) '(2 6 4 5 3))] + +@section{Conclusion} + +@chunk[<*> + (begin + (module main typed/racket + (require "type-expander.lp2.rkt" + "../lib/low.rkt") + (require (for-syntax + racket/syntax + syntax/parse + syntax/parse/experimental/template + (only-in "type-expander.lp2.rkt" prop:type-expander))) + (provide define-multi-id) + + ) + + (require 'main) + (provide (all-from-out 'main)) + + (module* test typed/racket + (require (submod "..") + "type-expander.lp2.rkt" + typed/rackunit + (for-syntax racket/list)) + + + + (require (submod ".." doc))))] \ No newline at end of file diff --git a/graph/type-expander/type-expander.lp2.rkt b/graph/type-expander/type-expander.lp2.rkt new file mode 100644 index 00000000..9510d8e1 --- /dev/null +++ b/graph/type-expander/type-expander.lp2.rkt @@ -0,0 +1,943 @@ +#lang scribble/lp2 +@(require "../lib/doc.rkt") +@doc-lib-setup + +@title[#:style manual-doc-style]{Extensible types} + +We want to have extensible types. Unlike @tc[require] and @tc[provide], which +come with @tc[define-require-syntax] and @tc[define-provide-syntax], and unlike +@tc[match], which comes with @tc[define-match-expander], @tc[typed/racket] +doesn't provide a way to define type expanders (yet). + +We re-define the forms @tc[:], @tc[define], @tc[lambda] etc. to equivalents that +expand type expanders defined via our macro @tc[define-type-expander]. Ideally, +this would be handled directly by @tc[typed/racket], which would call the +type-expander itself. + +@(table-of-contents) + +@section{@racket[prop:type-expander]} + +Match expanders are identified by the @tc[prop:type-expander] +@tech{structure type property}, which allows the same identifier to act as a +@tc[prop:rename-transformer], @tc[prop:match-expander] and +@tc[prop:type-expander] for example. + +@chunk[ + (define-values (prop:type-expander + has-prop:type-expander? + get-prop:type-expander-value) + (make-struct-type-property 'type-expander prop-guard))] + +The prop:type-expander property should either be the index of a field which will +contain the expander procedure, or directly an expander procedure. + +@chunk[ + (define (prop-guard val struct-type-info-list) + (cond + + [else + (raise-argument-error + 'prop:type-expander-guard + (string-append + "an exact non-negative integer designating a field index " + "within the structure that should contain a procedure of " + "arity 1, or a procedure of arity 1.") + val)]))] + +If the value is a field index, it should be within bounds. The +@tc[make-struct-field-accessor] function does that for us, and also returns +an accessor that can be passed directly an instance of the struct. + +@chunk[ + [(exact-nonnegative-integer? val) + (make-struct-field-accessor (cadddr struct-type-info-list) val)]] + +The expander procedure will take one argument: the piece of syntax corresponding +to the use of the expander. If the property's value is a procedure, we therefore +check that the it's arity includes 1. + +When the property value is a field index, we return a field accessor, that when +given the struct instance, will return the actual type expander procedure. +We therfore need to follow the same convention here, by wrapping val in a +single-parameter function. + +@chunk[ + [(procedure? val) + (if (arity-includes? (procedure-arity val) 1) + (λ (_) val) + (raise-argument-error 'prop:type-expander-guard + "procedure arity should be 1" + val))]] + +@subsection{type-expander struct} + +We make a simple struct that implements just @tc[prop:type-expander] and nothing +else. + +@chunk[ + (struct type-expander (expander-proc) + #:property prop:type-expander (struct-field-index expander-proc))] + +@section{@racket[expand-type]} + +@chunk[ + (define (apply-type-expander type-expander-stx stx) + (let ([type-expander (syntax-local-value type-expander-stx)]) + (((get-prop:type-expander-value type-expander) type-expander) stx)))] + +@CHUNK[ + (define (bind-type-vars type-vars stx) + (let ([def-ctx (syntax-local-make-definition-context)] + [err-expr #'(λ _ (raise-syntax-error + "Type name used out of context"))]) + (for ([var (syntax->list type-vars)]) + (syntax-local-bind-syntaxes (list var) err-expr def-ctx)) + (internal-definition-context-seal def-ctx) + (internal-definition-context-introduce def-ctx stx)))] + +@CHUNK[ + (define (expand-type stx) + (define-syntax-class type-expander + (pattern (~var expander + (static has-prop:type-expander? "a type expander")))) + (define-syntax-class fa (pattern (~or (~literal ∀) (~literal All)))) + (syntax-parse stx + [:type-expander + (expand-type (apply-type-expander #'expander #'expander))] + [(~and expander-call-stx (:type-expander . args)) + (expand-type (apply-type-expander #'expander #'expander-call-stx))] + ;; TODO: handle the pattern (∀ (TVar ... ooo) T) + [(∀:fa (TVar ...) T) + #`(∀ (TVar ...) #,(expand-type (bind-type-vars #'(TVar ...) #'T)))] + [((~literal Rec) R T) + #`(Rec R #,(expand-type (bind-type-vars #'(R) #'T)))] + [((~literal quote) T) (expand-quasiquote 'quote 1 #'T)] + [((~literal quasiquote) T) (expand-quasiquote 'quasiquote 1 #'T)] + [((~literal syntax) T) (expand-quasiquote 'syntax 1 #'T)] + [((~literal quasisyntax) T) (expand-quasiquote 'quasisyntax 1 #'T)] + [(T TArg ...) + #`(T #,@(stx-map expand-type #'(TArg ...)))] + [T #'T]))] + +@CHUNK[ + (define-syntax/parse (define-type-expander (name:id arg:id) . body) + #'(define-syntax name (type-expander (λ (arg) . body))))] + +@subsection{Tests for @racket[expand-type]} + +@CHUNK[ + (require (for-syntax typed/rackunit + syntax/parse)) + + (define-syntax (test-expander stx) + (syntax-parse stx + [(_ type expanded-type) + (check-equal? (syntax->datum (expand-type #'type)) + (syntax->datum #'expanded-type)) + #'(values)]))] + +Simple identity expander test, with a different case when used just as an +identifier. + +@CHUNK[ + (define-type-expander (id stx) + (syntax-case stx () + [(_ t) #'t] + [x #'(∀ (A) (→ A A))])) + + (test-expander (id Number) Number) + (test-expander id (∀ (A) (→ A A)))] + +@CHUNK[ + (define-type-expander (double stx) + (syntax-case stx () + [(_ t) #'(id (Pairof (id t) t))])) + + (test-expander (∀ (A) (→ A (id (double (id A))))) + (∀ (A) (→ A (Pairof A A))))] + +Shadowing and @tc[∀] variables: + +@CHUNK[ + (test-expander (∀ (id) (→ id)) + (∀ (id) (→ id))) + (test-expander (∀ (id2) (→ id)) + (∀ (id2) (→ (∀ (A) (→ A A)))))] + +@CHUNK[ + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + + (test-expander (Repeat Number 5) + (List Number Number Number Number Number))] + +@CHUNK[ + (: count-five-more (→ Number (Repeat Number 5))) + (define (count-five-more x) + (list (+ x 1) (+ x 2) (+ x 3) (+ x 4) (+ x 5))) + + (check-equal? (count-five-more 3) + '(4 5 6 7 8)) + (check-equal? (ann (count-five-more 15) (Repeat Number 5)) + '(16 17 18 19 20))] + +@section{Example type-expanders: quasiquote and quasisyntax} + +@CHUNK[ + (define (expand-quasiquote mode depth stx) + (define (wrap t) + (if (or (eq? mode 'syntax) (eq? mode 'quasisyntax)) + #`(Syntaxof #,t) + t)) + (define (wrap-quote t) + (if (or (eq? mode 'syntax) (eq? mode 'quasisyntax)) + #`(Syntaxof (quote #,t)) + #`(quote #,t))) + (define expand-quasiquote-rec (curry expand-quasiquote mode depth)) + (syntax-parse stx + [((~literal quote) T) + (wrap #`(List #,(wrap-quote #'quote) + #,(expand-quasiquote-rec #'T)))] + [((~literal quasiquote) T) + (wrap #`(List #,(wrap-quote #'quasiquote) + #,(if (eq? mode 'quasiquote) + (expand-quasiquote mode (+ depth 1) #'T) + (expand-quasiquote-rec #'T))))] + [((~literal unquote) T) + (if (eq? mode 'quasiquote) + (if (= depth 1) + (expand-type #'T) + (wrap #`(List #,(wrap-quote #'unquote) + #,(expand-quasiquote mode (- depth 1) #'T)))) + (wrap #`(List #,(wrap-quote #'unquote) + #,(expand-quasiquote-rec #'T))))] + [((~literal syntax) T) + (wrap #`(List #,(wrap-quote #'quote) + #,(expand-quasiquote-rec #'T)))] + [((~literal quasisyntax) T) + (wrap #`(List #,(wrap-quote #'quasisyntax) + #,(if (eq? mode 'quasisyntax) + (expand-quasiquote mode (+ depth 1) #'T) + (expand-quasiquote-rec #'T))))] + [((~literal unsyntax) T) + (if (eq? mode 'quasisyntax) + (if (= depth 1) + (expand-type #'T) + (wrap #`(List #,(wrap-quote #'unsyntax) + #,(expand-quasiquote mode (- depth 1) #'T)))) + (wrap #`(List #,(wrap-quote #'unsyntax) + #,(expand-quasiquote-rec #'T))))] + ;; TODO For lists, we should consider the cases where syntax-e gives + ;; a pair vs the cases where it gives a list. + [(T . U) + #:when (syntax? (cdr (syntax-e stx))) + (wrap #`(Pairof #,(expand-quasiquote-rec #'T) + #,(expand-quasiquote-rec #'U)))] + [() (wrap #'Null)] + [(T ...) + (wrap #`(List #,@(stx-map expand-quasiquote-rec #'(T ...))))] + [(T ... U . S) + (wrap #`(List* #,@(stx-map expand-quasiquote-rec #'(T ... U S))))] + [#(T ...) + (wrap #`(Vector #,@(stx-map expand-quasiquote-rec #'(T ...))))] + [#&T (wrap #`(Boxof #,(expand-quasiquote-rec #'T)))] + ; TODO: Prefab with #s(prefab-struct-key type ...) + [T:id (wrap #''T)] + [T #:when (string? (syntax-e #'T)) (wrap #'T)] + [T:number (wrap #'T)] + [T:keyword (wrap #''T)] + [T:char (wrap #'T)] + [#t (wrap #'True)] + [#t (wrap #'False)] + [_ (raise-syntax-error 'expand-quasiquote + "Unknown quasiquote contents" + stx)]))] + +@section{Overloading @racket[typed/racket] forms} + +Througout this section, we provide alternative definitions of the +@tc[typed/racket] forms @tc[:], @tc[lambda], @tc[define], @tc[struct], @tc[ann], +@tc[inst]… . We write these definitions with @tc[syntax-parse], using the syntax +classes defined in section @secref{syntax-classes}. + +Most of the time, we will use the experimental @tc[template] macro from +@tc[syntax/parse/experimental/template] which allows more concise code than the +ususal @code{#'()} and @code{#`()}. In order to expand types and bind type +variables in the result, we define two template metafunctions: + +@chunk[ + (define-template-metafunction (template-expand-type stx) + (syntax-parse stx + [(_ () t) (expand-type #'t)] + [(_ tvars t) (expand-type (bind-type-vars #'tvars #'t))]))] + +@subsection{@racket[:]} + +We provide a new definition for the @tc[:] operator, which calls the old one +after expanding the type argument. + +@CHUNK[<:> + (define-syntax/parse (new-: x:id t:expr) + #`(: x #,(expand-type #'t)))] + +@CHUNK[ + (: c0 `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d)) + (define c0 '(2 "abc" #,(x . z) #(1 "b" x) d))] + +@subsection[#:tag "syntax-classes"]{syntax classes} + +The syntax classes from @tc[typed-racket/base-env/annotate-classes] match +against the @tc[:] literal. Since we provide a new definition for it, the syntax +class doesn't match code using our definition of @tc[:]. We therefore can't use +the original implementations of @tc[:curried-formals] and @tc[lambda-formals], +and instead have to roll out our own versions. + +We take that as an opportunity to expand the types directly from the syntax +classes using @tc[#:with], instead of doing that inside the macros that use +them. + +@CHUNK[ + (define-syntax-class colon + (pattern (~literal new-:))) + + (define-splicing-syntax-class (new-maybe-kw-type-vars) + #:attributes (vars maybe) + (pattern kw+vars:lambda-type-vars + #:with vars #'kw+vars.type-vars + #:with maybe #'kw+vars) + (pattern (~seq) + #:with vars #'() + #:attr maybe #f)) + + (define-splicing-syntax-class (new-maybe-type-vars) + #:attributes (vars maybe) + (pattern vars:type-variables + #:with maybe #'vars) + (pattern (~seq) + #:with vars #'() + #:attr maybe #f)) + + (define-splicing-syntax-class (new-kw-formal tvars) + #:attributes ([expanded 1]) + (pattern (~seq kw:keyword id:id) + #:with (expanded ...) #'(kw id)) + (pattern (~seq kw:keyword [id:id + (~optional (~seq :colon type:expr)) + (~optional default:expr)]) + #:with tvars tvars + #:with (expanded ...) + (template (kw [id (?@ : (template-expand-type tvars type)) + (?? default)])))) + + (define-splicing-syntax-class (new-mand-formal tvars) + #:attributes ([expanded 1]) + (pattern id:id + #:with (expanded ...) #'(id)) + (pattern [id:id :colon type:expr] + #:with tvars tvars + #:with (expanded ...) + (template ([id : (template-expand-type tvars type)]))) + (pattern (~var kw (new-kw-formal tvars)) + #:with (expanded ...) #'(kw.expanded ...))) + + (define-splicing-syntax-class (new-opt-formal tvars) + #:attributes ([expanded 1]) + (pattern [id:id (~optional (~seq :colon type:expr)) default:expr] + #:with tvars tvars + #:with (expanded ...) + (template ([id (?@ : (template-expand-type tvars type)) + default]))) + (pattern (~var kw (new-kw-formal tvars)) + #:with (expanded ...) #'(kw.expanded ...))) + + (define-syntax-class (new-rest-arg tvars) + #:attributes ([expanded 0]) + (pattern rest:id + #:with expanded #'rest) + (pattern (rest:id + :colon type:expr + (~or (~and x* (~describe "*" (~or (~datum *) (~datum ...*)))) + (~seq (~datum ...) bound:expr))) + #:with tvars tvars + #:with expanded + (template (rest : (template-expand-type tvars type) + (?? x* (?@ (... ...) (template-expand-type + tvars bound))))))) + + (define-syntax-class (new-lambda-formals tvars) + (pattern (~or ((~var mand (new-mand-formal tvars)) ... + (~var opt (new-opt-formal tvars)) ... + . (~var rest (new-rest-arg tvars))) + ((~var mand (new-mand-formal tvars)) ... + (~var opt (new-opt-formal tvars)) ...)) + ;; TODO: once template supports ?? in tail position, use it. + #:with expanded #`(mand.expanded ... + ... + opt.expanded ... + ... + . #,(if (attribute rest) + #'rest.expanded + #'())))) + + (define-syntax-class (new-curried-formals tvars) + (pattern (f:id . (~var args (new-lambda-formals tvars))) + #:with expanded #'(f . args.expanded)) + (pattern ((~var lhs (new-curried-formals tvars)) + . (~var args (new-lambda-formals tvars))) + #:with expanded #'(lhs.expanded . args.expanded))) + + (define-splicing-syntax-class (new-optionally-annotated-name tvars) + (pattern (~seq name:id (~optional (~seq :colon type:expr))) + #:with tvars tvars + #:with expanded + (template (name + (?? (?@ : (template-expand-type tvars type))))))) + + (define-syntax-class (new-name-or-parenthesised-annotated-name tvars) + (pattern name:id + #:with expanded #'name) + (pattern [id:id :colon type:expr] + #:with tvars tvars + #:with expanded + (template [id : (template-expand-type tvars type)])))] + +@subsection{@racket[define-type]} + +@chunk[ + (define-syntax (new-define-type stx) + (syntax-parse stx + [(_ (~or name:id (name:id TVar ...)) type . rest) + (template + (define-type (?? (name TVar ...) name) + (template-expand-type (?? (TVar ...) ()) type) + . rest))]))] + +@chunk[ + (let () + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + + (define-type R5 (Repeat Number 5)) + (check-equal? (ann '(1 2 3 4 5) R5) '(1 2 3 4 5)))] + +@subsection{@racket[define]} + +@chunk[ + (define-syntax (new-define stx) + (syntax-parse stx + [(_ tvars:new-maybe-kw-type-vars + (~or v:id + (~var formals (new-curried-formals #'tvars.vars))) + (~optional (~seq :colon type)) + e ...) + (template + (define (?@ . tvars) (?? v formals.expanded) + (?? (?@ : (template-expand-type tvars.vars type))) + e ...))]))] + +@CHUNK[ + (define d0 + : `(2 "abc" #,,(Pairof (U 'x 'y) (U 'y 'z)) #(1 "b" x) d) + '(2 "abc" #,(x . z) #(1 "b" x) d)) + (check-equal? (ann d0 (List 2 + "abc" + (List 'unsyntax (Pairof (U 'x 'y) (U 'y 'z))) + (Vector 1 "b" 'x) 'd)) + '(2 "abc" (unsyntax (x . z)) #(1 "b" x) d)) + + (: d1 (→ Number (→ Number Number))) + (define ((d1 [x : Number]) [y : Number]) : Number (+ x y)) + (check-equal? (ann ((d1 2) 3) Number) 5) + + (: d2 (→ Number (→ Number Number))) + (define ((d2 [x : Number]) [y : Number]) (+ x y)) + (check-equal? (ann ((d2 3) 4) Number) 7) + + (define #:∀ (T) ((d3 [x : T]) [y : T]) : (Pairof T T) (cons x y)) + (check-equal? (ann ((d3 'x) 'y) (Pairof Symbol Symbol)) '(x . y))] + +@subsection{@racket[lambda]} + +@CHUNK[ + (define-syntax (new-lambda stx) + (syntax-parse stx + [(_ tvars:new-maybe-kw-type-vars + (~var args (new-lambda-formals #'tvars.vars)) + (~optional (~seq :colon ret-type)) + e ...) + (template (lambda (?@ . tvars) args.expanded + (?? (?@ : (template-expand-type tvars.vars ret-type))) + e ...))]))] + +@CHUNK[ + (check-equal? ((ann (lambda ([x : Number]) : Number (* x 2)) + (→ Number Number)) + 3) + 6) + (check-equal? ((ann (λ ([x : Number]) : Number (* x 2)) + (→ Number Number)) + 3) + 6) + (check-equal? ((λ x x) 1 2 3) '(1 2 3)) + (check-equal? ((λ #:∀ (A) [x : A ...*] : (Listof A) x) 1 2 3) '(1 2 3))] + +@subsection{@racket[struct]} + +@chunk[ + (define-syntax (new-struct stx) + (syntax-parse stx + [(_ tvars:new-maybe-type-vars + (~and name+parent (~or name:id [name:id parent:id])) + ([field:id :colon type:expr] ...) + . rest) + (template (struct (?? tvars.maybe) name+parent + ([field : (template-expand-type tvars.vars type)] ...) + . rest))]))] + +@chunk[ + (struct s0 ()) + (struct s1 ([x : Number])) + (struct s2 ([x : Number] [y : Number])) + (struct s3 ([x : Number] [y : Number]) #:transparent) + (struct s4 () #:transparent) + (struct (A B) s5 ([x : A] [y : B]) #:transparent) + (struct (A B) s6 () #:transparent) + + (check (λ (a b) (not (equal? a b))) (s0) (s0)) + (check-equal? (s1-x (s1 123)) 123) + (check-equal? (s2-x (s2 2 3)) 2) + (check-equal? (s2-y (s2 2 3)) 3) + (check-equal? (s3-x (s3 4 5)) 4) + (check-equal? (s3-y (s3 4 5)) 5) + (check-equal? (s4) (s4)) + (check-equal? (s5-x (s5 6 7)) 6) + (check-equal? (s5-y (s5 6 7)) 7) + (check-equal? (s5 6 7) (s5 6 7)) + (check-equal? (s6) (s6))] + +@subsection{@racket[ann]} + +@chunk[ + (define-syntax/parse (new-ann value:expr (~optional :colon) type:expr) + (template (ann value (template-expand-type () type))))] + +@chunk[ + (let () + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + (check-equal? (ann (ann '(1 2 3) + (Repeat Number 3)) + (List Number Number Number)) + '(1 2 3)))] + +@subsection{@racket[inst]} + +@chunk[ + (define-syntax/parse (new-inst v + (~optional :colon) t ... + (~optional (~seq last (~datum ...) b:id))) + (template (inst v (template-expand-type () t) ... + (?? (?@ (template-expand-type () last) + (... ...) b)))))] + +@chunk[ + (let () + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + + (: f (∀ (A B C D) (→ (Pairof A B) (Pairof C D) (List A C B D)))) + (define (f x y) (list (car x) (car y) (cdr x) (cdr y))) + + (check-equal? ((inst f + (Repeat Number 3) + (Repeat String 2) + (Repeat 'x 1) + (Repeat undefined-type 0)) + '((1 2 3) . ("a" "b")) + '((x) . ())) + '((1 2 3) (x) ("a" "b") ())))] + +@subsection{@racket[let]} + +@chunk[ + (define-syntax/parse + (new-let + (~optional (~seq loop:id (~optional (~seq :colon return-type:expr)))) + tvars:new-maybe-kw-type-vars + ([(~var name (new-optionally-annotated-name #'tvars.vars)) + e:expr] ...) + . rest) + (template + (let (?? (?@ loop (?? (?@ : (template-expand-type tvars.vars + return-type))))) + (?@ . tvars) + ([(?@ . name.expanded) e] ...) + . rest)))] + +@chunk[ + (check-equal? (let loop-id ([x 1]) + (if (= x 2) + x + (loop-id (+ x 1)))) + 2) + (check-equal? (let () 'x) 'x) + (check-equal? (ann (let #:∀ (T) ([a : T 3] + [b : (Pairof T T) '(5 . 7)]) + (cons a b)) + (Pairof Number (Pairof Number Number))) + '(3 5 . 7))] + +@subsection{@racket[let*]} + +@chunk[ + (define-syntax/parse + (new-let* + ([(~var name (new-optionally-annotated-name #'())) + e:expr] ...) + . rest) + (template + (let* ([(?@ . name.expanded) e] ...) + . rest)))] + +@chunk[ + (let () + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + + (check-equal? (let* ([x* : (Repeat Number 3) '(1 2 3)] + [y* : (Repeat Number 3) x*]) + y*) + '(1 2 3)))] + +@subsection{@racket[let-values]} + +@chunk[ + (define-syntax/parse + (new-let-values + ([((~var name (new-name-or-parenthesised-annotated-name #'())) ...) + e:expr] ...) + . rest) + (template + (let-values ([(name.expanded ...) e] ...) + . rest)))] + +@chunk[ + (let () + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + + (check-equal? (ann (let-values + ([([x : (Repeat Number 3)]) + (list 1 2 3)]) + (cdr x)) + (List Number Number)) + '(2 3)) + + (check-equal? (ann (let-values + ([([x : (Repeat Number 3)] [y : Number]) + (values (list 1 2 3) 4)]) + (cons y x)) + (Pairof Number (List Number Number Number))) + '(4 . (1 2 3))) + + (check-equal? (ann (let-values + ([(x y) + (values (list 1 2 3) 4)]) + (cons y x)) + (Pairof Number (List Number Number Number))) + '(4 . (1 2 3))))] + +@subsection{@racket[make-predicate]} + +@chunk[ + (define-syntax/parse (new-make-predicate type:expr) + (template (make-predicate (template-expand-type () type))))] + +@chunk[ + (let () + (define-type-expander (Repeat stx) + (syntax-case stx () + [(_ t n) #`(List #,@(map (λ (x) #'t) + (range (syntax->datum #'n))))])) + (check-equal? ((make-predicate (Repeat Number 3)) '(1 2 3)) #t) + (check-equal? ((make-predicate (Repeat Number 3)) '(1 "b" 3)) #f))] + +@subsection[#:tag "other-forms"]{Other @racket[typed/racket] forms} + +The other @tc[typed/racket] forms below do not have an alternative definition +yet. + +@chunk[ + (define-syntax (missing-forms stx) + (syntax-parse stx + [(_ name ...) + (define/with-syntax (tmp ...) (generate-temporaries #'(name ...))) + #'(begin + (begin + (define-syntax (tmp stx) + (raise-syntax-error + 'name + (format "~a not implemented yet for type-expander" 'name))) + (provide (rename-out [tmp name]))) + ...)])) + + (missing-forms + ;; TODO: add all-defined-out in prims.rkt + ;; top-interaction.rkt + :type + :print-type + :query-type/args + :query-type/result + ;; case-lambda.rkt + case-lambda + case-lambda: + pcase-lambda: + ;; (submod "prims-contract.rkt" forms) + require/opaque-type + require-typed-struct-legacy + require-typed-struct + require/typed-legacy + require/typed + require/typed/provide + require-typed-struct/provide + cast + ;make-predicate + define-predicate + ;; prims.rkt + define-type-alias + define-new-subtype + define-typed-struct + define-typed-struct/exec + ;ann + ;inst + ;: + define-struct: + define-struct + ;struct + struct: + λ: + ;lamdba + ;λ + ;define + ;let + ;let* + letrec + ;let-values + letrec-values + let/cc + let/ec + let: + let*: + letrec: + let-values: + letrec-values: + let/cc: + let/ec: + for + for/list + for/vector + for/hash + for/hasheq + for/hasheqv + for/and + for/or + for/sum + for/product + for/lists + for/first + for/last + for/fold + for* + for*/list + for*/lists + for*/vector + for*/hash + for*/hasheq + for*/hasheqv + for*/and + for*/or + for*/sum + for*/product + for*/first + for*/last + for*/fold + for/set + for*/set + do + do: + with-handlers + define-struct/exec: + define-struct/exec)] + +@section{Future work} + +We have not implemented alternative type-expanding definitions for all the +@tc[typed/racket] forms, as noted in @secref{other-forms}. + +Integrating the type-expander directly into typed/racket would avoid the need to +provide such definitions, and allow using type-expanders in vanilla +@tc[typed/racket], instead of having to @tc[require] this library. However, the +code wrapping the @tc[typed/racket] forms could be re-used by other libraries +that alter the way @tc[typed/racket] works, so implementing the remaining forms +could still be useful. + +Also, we would need to provide a @tc[syntax-local-type-introduce] function, +similar to the @tc[syntax-local-match-introduce] function provided by @tc[match] +for example. + +@section{Conclusion} + +When an identifier is @tc[require]d from another module, it is not the same as +the one visible within the defining module. This is a problem for @tc[:], +because we match against it in our syntax classes, using @tc[(~literal :)], but +when it is written in another module, for example @tc[(define foo : Number 42)], +it is not the same identifier as the one used by original definition of @tc[:], +and therefore the @tc[(~literal :)] won't match. I suspect that issue to be due +to contract wrappers added by @tc[typed/racket]. + +To get around that problem, we define @tc[:] in a separate module, and +@tc[require] it in the module containing the syntax classes: + +@chunk[ + (module colon typed/racket + (require (for-syntax racket + syntax/parse) + "../lib/low.rkt") + (require (for-syntax (submod ".." expander))) + + (provide new-:) + + <:>)] + +Since our @tc[new-:] macro needs to call the @tc[type-expander], and the other +forms too, we can't define @tc[type-expander] in the same module as these forms, +it needs to be either in the same module as @tc[new-:], or in a separate module. +Additionally, expand-type needs to be required @tc[for-syntax] by the forms, but +needs to be @tc[provide]d too, so it is much easier if it is defined in a +separate module (that should be used only @tc[for-syntax], so it will be written +in @tc[racket], not @tc[typed/racket]). + +@chunk[ + (module expander racket + (require racket) + (require syntax/parse) + (require syntax/stx) + + (require (for-template typed/racket)) + + (provide prop:type-expander + type-expander + apply-type-expander + bind-type-vars + expand-type) + + + + + + + + + )] + +We can finally define the overloaded forms, as well as the extra +@tc[]. + +@chunk[ + (module main typed/racket + (require (for-syntax racket + racket/syntax + syntax/parse + syntax/parse/experimental/template) + "../lib/low.rkt") + + (require (submod ".." expander)) + (require (for-syntax (submod ".." expander))) + (require (for-syntax typed-racket/base-env/annotate-classes)) + (require (submod ".." colon)) + + (provide prop:type-expander + expand-type + define-type-expander + (rename-out [new-: :] + [new-define-type define-type] + [new-define define] + [new-lambda lambda] + [new-lambda λ] + [new-struct struct] + [new-ann ann] + [new-inst inst] + [new-let let] + [new-let* let*] + [new-let-values let-values] + [new-make-predicate make-predicate])) + + + + (begin-for-syntax + + ) + + + + + + + + + + + + )] + +And, last but not least, we will add a @tc[test] module. + +@chunk[ + (module* test typed/racket + (require typed/rackunit) + (require (submod "..")) + (require (for-syntax (submod ".." expander))) + (require (for-syntax racket/list)) + + + + + + + + + + + + + + + + ;; Make the code coverage take the docs into account. + (require (submod ".." doc)))] + +We can now assemble the modules in this order: + +@chunk[<*> + (begin + + + + + (require 'main) + (provide (all-from-out 'main)) + + )]