Squashed commits

.gitignore

@@ -0,0 +1,9 @@
+*~
+\#*
+.\#*
+.DS_Store
+compiled/
+/*.css
+/*.html
+/*.js
+all-tags.log

.travis.yml

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

LICENSE-more.md

@@ -0,0 +1,28 @@
+phc-adt
+
+Parts of this this software were initially written as part of a project
+at Cortus, S.A.S. which can be reached at 97 Rue de Freyr, 34000
+Montpellier, France. I got their permission to redistribute the code in
+the Public Domain.
+
+
+
+This package is in distributed under the Creative Commons CC0 license
+https://creativecommons.org/publicdomain/zero/1.0/, as specified by
+the LICENSE.txt file.
+
+
+
+The CC0 license is equivalent to a dedication to the Public Domain
+in most countries, but is also effective in countries which do not
+recognize explicit dedications to the Public Domain.
+
+
+
+In order to avoid any potential licensing issues, this package is explicitly
+distributed under the Creative Commons CC0 license
+https://creativecommons.org/publicdomain/zero/1.0/, or under the GNU Lesser
+General Public License (LGPL) https://opensource.org/licenses/LGPL-3.0, or
+under the Apache License Version 2.0
+https://opensource.org/licenses/Apache-2.0, or under the MIT license
+https://opensource.org/licenses/MIT, at your option.

LICENSE.txt

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

README.md

@@ -0,0 +1,137 @@
+[![Build Status,](https://img.shields.io/travis/jsmaniac/phc-adt/master.svg)](https://travis-ci.org/jsmaniac/phc-adt)
+[![Coverage Status,](https://img.shields.io/codecov/c/github/jsmaniac/phc-adt/master.svg)](https://codecov.io/gh/jsmaniac/phc-adt)
+[![Build Stats,](https://img.shields.io/badge/build-stats-blue.svg)](http://jsmaniac.github.io/travis-stats/#jsmaniac/phc-adt)
+[![Online Documentation,](https://img.shields.io/badge/docs-online-blue.svg)](http://docs.racket-lang.org/phc-adt/)
+[![Maintained as of 2017,](https://img.shields.io/maintenance/yes/2017.svg)](https://github.com/jsmaniac/phc-adt/issues)
+[![License: CC0 v1.0.](https://img.shields.io/badge/license-CC0-blue.svg)](https://creativecommons.org/publicdomain/zero/1.0/)
+
+phc-adt
+=======
+
+This library provides Algebraic Datatypes (structures and variants), with the
+features described below. It is designed to work hand-in-hand with our graph
+library (https://github.com/jsmaniac/phc), but can also be used on its own.
+
+Structures
+----------
+
+We define structures as an extension of Racket's syntax. Structures are
+anonymous products of values, where each value is annotated by a field
+name. The syntax used for constructing an instance of a structure is:
+
+(structure [field₁ : value₁] … [fieldₙ : valueₙ])
+
+The type of a structure is described using a similar syntax:
+
+(structure [field₁ : type₁] … [fieldₙ : typeₙ])
+
+Accessing the field `f` of an instance `i` is done using the dot operator:
+      
+    i.f
+
+The main difference with Racket's built-in `struct` is that the type does not
+need to be pre-declared to create instances of a structure, making them
+effectively anonymous. Racket also requires knowing the name of the struct
+type in order to access a field of an instance, using `(s-f i)` where `s` is
+the struct's name, `f` is the field name and `i` is the instance. When very
+similar structures are used, specifying the structure's name each time becomes
+cumbersome.
+      
+Unions
+------
+
+Typed/Racket has built-in untagged union types, which can be constructed using
+the following notation:
+
+    (U type₁ … typeₙ)
+
+These cannot be used as-is inside node types for our graph library
+(https://github.com/jsmaniac/phc), because there is no way at run-time to
+distinguish between the various cases of the union in the general case. For
+example, `(U (→ Integer) (→ String))` denotes the type of an union of thunks,
+one returning an `Integer` and the other a `String`, and it is not
+possible to know to which case an instance belongs without calling the thunks,
+which could have undesired side-effects.
+
+The graph library's implementation relies on being able to rewrite arbitrary
+data structures, changing the type of some parts in the process. We therefore
+allow only a limited form of unions, namely those where all cases but one are
+pairs whose first element is a symbol. The first element of the pair can then
+be used to distinguish between the cases. The remaining case is used as a
+fall-back when the symbol comparison for all others have failed, and should
+not overlap with the other cases.
+
+Variants
+--------
+
+We define variants (tagged unions) as an alternative to Racket's untagged
+unions. In our implementation, variants are anonymous unions of
+constructors. Each constructor is a tuple of values annotated with a
+tag. Variants are usually not anonymous in other languages: the same
+constructor cannot belong to two different variants. In our implementation,
+this is not the case: two different variants can contain the same exact
+constructor. The reason for this feature is that the input and output types of
+graph transformations are very similar, and are likely to contain
+nearly-identical variants.  Name collisions would be frequent if a constructor
+name was bound to a single variant. We use the following syntax to denote a
+variant type:
+
+    (V constructor₁ … constructorₙ)
+
+Constructors are the product of a tag name and a payload, which is itself a
+product of zero or more types. Constructors types are declared as follows:
+
+    (constructor tag payload₁ … payloadₙ)
+
+Instances of a constructor can be created using the following syntax:
+
+    (constructor tag v₁ … vₙ)
+
+All constructors within a variant should have a distinct tag, but the same tag
+name can be used in the several variants, with an identical or different
+payload.
+
+To improve encapsulation, we further define *private* constructors. These have
+a unique tag which is uncomparable to all other tags, even those using the
+same string of characters for the name. We also define *uninterned*
+constructors, which are strict subtypes of the regular constructor with the
+same name (i.e. using the same string of characters for the name). Another way
+to see these is that a *private* constructor protects both its creation
+mechanism and its matching mechanism, whereas the *uninterned* constructors
+protect only the creation mechanism, but no special permission is needed to
+match on an *uninterned* constructor.
+
+When using Racket's `match` form, an instance of a variant only matches with
+its tag (or an uninterned subtype) and the same number of fields.
+
+---
+
+Nodes
+-----
+
+Below follows a short description of graph nodes, which are provided by a
+separate library (https://github.com/jsmaniac/phc-graph, code is currently
+being refactored and migrated from https://github.com/jsmaniac/phc).
+
+Graph nodes behave like tagged structures in most aspects. They are similar to
+a constructor containing a structure as its single field. An *incomplete* node
+can only be created within a *mapping* of the same graph, using a notation
+similar to the one used for structures:
+      
+ (node-name [field₁ : value₁] … [fieldₙ : valueₙ])
+
+The type of a node can be expressed similarly:
+
+(node-name [field₁ : type₁] [fieldₙ : typeₙ])
+
+It is not possible to access an *incomplete* node's fields. However, once the
+graph is fully constructed, the field `f` of the *promise* node `p` can be
+accessed using the same dot operator:
+      
+    p.f
+
+On the other hand, it is not possible to directly create a promise node
+without using a graph constructor.
+
+**TODO:** nodes are actually rather similar to uninterned constructors
+containing a single value, which is a structure.

phc-adt-doc/info.rkt

@@ -0,0 +1,25 @@
+#lang info
+(define collection 'multi)
+(define deps '("base"))
+(define build-deps '("scribble-lib"
+                     "hyper-literate"
+                     "phc-adt-lib"
+                     "racket-doc"
+                     "typed-racket-doc"
+                     "typed-racket-lib"
+                     "scribble-enhanced"
+		     "scribble-math"
+                     "type-expander"
+                     "xlist"
+                     "alexis-util"
+                     "extensible-parser-specifications"
+                     "multi-id"
+                     "phc-toolkit"
+                     "remember"
+                     "threading"
+                     "trivial"
+                     "typed-struct-props"
+                     "datatype"))
+(define pkg-desc "Algebraic Datatypes tailored for writing compilers (documentation only)")
+(define version "1.1")
+(define pkg-authors '("Georges Dupéron"))

phc-adt-doc/phc-adt/.gitignore

@@ -0,0 +1 @@
+/doc/

phc-adt-doc/phc-adt/info.rkt

@@ -0,0 +1,4 @@
+#lang info
+(define scribblings
+  '(("scribblings/phc-adt.scrbl" (multi-page) ("Data Structures"))
+    ("scribblings/phc-adt-implementation.scrbl" (multi-page) ("Data Structures"))))

phc-adt-doc/phc-adt/scribblings/phc-adt-choices.scrbl

@@ -0,0 +1,124 @@
+#lang hyper-literate typed/racket
+@(require scribble-enhanced/doc)
+@doc-lib-setup
+
+@title[#:style manual-doc-style
+       #:tag "choices"
+       #:tag-prefix "phc-adt/choices"]{Somewhat outdated
+ overview of the implementation choices for structures, graphs and passes}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/choices"))
+
+@section[#:tag "type-system|structures"]{Structures}
+
+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. The first
+ problem is that we cannot have subtyping (although knowing all the structs
+ used in the program means we can just filter them and use a
+ @racket[(U S1 S2 …)]. The second problem is that in order to declare the
+ structs, we would need to be in a define-like environment (therefore making
+ anonymous structure types problematic). The second problem can be solved in
+ the same way as the first: if all the structs are known in advance, we can
+ pre-declare them in a shared file.}
+
+@chunk[<example-simple-structure>
+       (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[<example-simple-structure-occurrence>
+       (: 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 is only concerned with
+fields @tc[a] and @tc[c], so tests don't need to provide a value for @tc[b].
+
+@chunk[<example-pass-which-extends-input>
+       (: 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[<example-pass-which-extends-input>
+       (pass-calc-d '((a . 1) (b . no-field) (c . #t)))]
+
+But when called with a proper value for @tc[b], we get back the original
+string as expected, and the type is correct:
+
+@chunk[<example-pass-which-extends-input>
+       (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 (each being a subtype
+containing a common subset of fields), then it should be easy to mark it as a
+@tc[case→] function. It is 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 for achieving this is to wrap the to-be-created value inside a
+@tc[Promise]. Occurrence typing works on those:
+
+@chunk[<test-promise-occurence-typing>
+       (: 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[<*>
+       <example-simple-structure>
+       <example-simple-structure-occurrence>
+         
+       <example-pass-which-extends-input>
+         
+       <test-promise-occurence-typing>]

phc-adt-doc/phc-adt/scribblings/phc-adt-constructor.scrbl

@@ -0,0 +1,311 @@
+#lang scribble/manual
+
+@(require racket/require
+          (for-label (except-in (subtract-in typed/racket/base type-expander)
+                                values)
+                     type-expander
+                     phc-adt
+                     xlist
+                     (lib "phc-adt/tagged.hl.rkt")
+                     (lib "phc-adt/structure.hl.rkt")
+                     (lib "phc-adt/constructor.hl.rkt")
+                     (lib "phc-adt/variant.hl.rkt")
+                     (lib "phc-adt/tagged-supertype.hl.rkt"))
+          scribble-enhanced/doc
+          scribble-math
+          (subtract-in scribble/struct scribble-enhanced/doc)
+          scribble/decode)
+@doc-lib-setup
+
+@title{Constructors}
+
+@deftech{Constructors} are implemented as tagged structures, using a
+single special field: @racket[values]. The @racket[constructor] identifier and
+its derivatives therefore call @racket[tagged], using that single field. The
+identifiers described within this section provide some syntactic sugar,
+allowing constructors to contain more than one value. These values are wrapped
+in a (possibly improper) list which is stored within the tagged structure's
+@racket[values] field.
+
+
+@defform*[#:kind "type-expander"
+          [(constructor tag-name maybe-∀ τᵢ ...)
+           (constructor tag-name maybe-∀ τᵢ ... . dotted-τ-rest)
+           (constructor tag-name maybe-∀ τᵢ ... #:rest τ-rest)]
+          #:grammar
+          [(tag-name Identifier)
+           (maybe-∀ (code:line)
+                    (code:line #:∀ (tvarⱼ ...)))
+           (τᵢ xlist-type-or-repeated-type)
+           (τ-rest xlist-type-or-repeated-type)
+           (dotted-τ-rest #,"like τ-rest, but must not be a syntax pair")]]{
+
+ Expands to the type for a constructor with the given tag name and type of
+ contents. The @racket[(τᵢ ...)], @racket[(τᵢ ... . dotted-τ-rest)] or
+ @racket[(τᵢ ... #:rest τ-rest)] sequence is passed unmodified to
+ @racket[xlist]. Therefore, depending on the syntax used, the expanded type is
+ equivalent to one of the following types:
+
+ @racketblock[
+ (tagged tag-name maybe-∀ [values (xlist τᵢ ...)])
+ (tagged tag-name maybe-∀ [values (xlist τᵢ ... . dotted-τ-rest)])
+ (tagged tag-name maybe-∀ [values (xlist τᵢ ... #:rest τ-rest)])]
+
+ The elements may appear in any order, as long as the tag name appears before
+ any element type, and as long as the element types form a contiguous
+ sequence.}
+
+@defform*[#:kind "syntax"
+          #:link-target? #f
+          #:literals (* : ! ::)
+          [(constructor maybe-∀ tag-name *)
+           (constructor maybe-∀ tag-name : typeᵢ ...)
+           (constructor maybe-∀ tag-name ! . xlist-types)
+           (constructor maybe-∀ tag-name :: . xlist-types)]
+          #:grammar
+          [(maybe-∀ (code:line)
+                    (code:line #:∀ (tvarⱼ ...)))
+           (tag-name Identifier)
+           (xlist-types (τᵢ ...)
+                        (τᵢ ... . dotted-τ-rest)
+                        (τᵢ ... #:rest τ-rest))
+           (τᵢ xlist-type-or-repeated-type)
+           (typeᵢ Type)]]{
+ Expands to a builder function for a constructor with the given tag name and
+ type of contents.
+
+ The first syntax, using @racket[*] and no types, produces a polymorphic
+ builder function which accepts any number of arguments, infers their types,
+ and uses the whole list of arguments as the constructor's value.
+
+ In the following three cases, when @racket[#:∀ (tvarⱼ ...)] is specified, a
+ polymorphic builder with the @racket[tvarⱼ] type variables is produced.
+
+ The second syntax, using @racket[:] followed by a sequence of regular types,
+ produces a builder function with one argument per type. The builder function
+ aggregates all its arguments in a list, and uses that list as the
+ constructor's value.
+
+ The second syntax, using @racket[!] followed by a sequence of types valid for
+ @racket[xlist], produces a builder function which accepts a variable number of
+ arguments. The builder function @racket[cast]s the whole list of arguments to
+ the type @racket[(xlist . xlist-types)], which must therefore be a suitable
+ argument to @racket[make-predicate]. The cast list is used as the
+ constructor's value.
+
+ The third syntax, using @racket[::] followed by a sequence of types valid for
+ @racket[xlist], produces a builder function which accepts a single value of
+ type @racket[(xlist . xlist-typed)], and uses that value as the constructor's
+ value.
+
+ Usually, the value stored within a constructor will be a list (i.e. a tuple
+ in other languages), but it is possible to store a single value using
+ @racket[xlist]'s rest syntax:
+
+ @racketblock[
+ ((constructor #:∀ (A) tag-name :: . A) 123)
+ ((constructor tag-name :: . Number) 123)
+ ((constructor tag-name :: #:rest (Vector Number String)) #(123 "abc"))]
+
+ The elements may appear in any order, as long as the tag name appears before
+ any element type, and as long as the element types form a contiguous
+ sequence.}
+
+@defform*[#:kind "syntax"
+          #:link-target? #f
+          #:literals (:)
+          [(constructor maybe-∀ tag-name value-maybe-typeᵢ)
+           (constructor maybe-∀ tag-name value-maybe-typeᵢ . dotted-rest)
+           (constructor maybe-∀ tag-name value-maybe-typeᵢ #:rest rest)]
+          #:grammar
+          [(maybe-∀ (code:line)
+                    (code:line #:∀ (tvarⱼ ...)))
+           (tag-name Identifier)
+           (value-maybe-typeᵢ valueᵢ
+                              [valueᵢ : typeᵢ]
+                              [: typeᵢ valueᵢ])
+           (rest value-maybe-typeᵢ)
+           (dotted-rest #,"like rest, but must not be a syntax pair")]]{
+
+ Expands to an instance of a constructor containing the given values, grouped
+ inside a list.
+
+ When a @racket[typeᵢ] is specified, it is used to annotate the value, and is
+ used as the type for that element in the resulting constructor type.
+
+ When @racket[#:∀ (tvarⱼ ...)] is specified, the type of values annotated with
+ @racket[tvarⱼ] is inferred, and an instance of a polymorphic constructor is
+ produced. A @racket[tvarⱼ] can be used within a more complex type, in which
+ case only that part of the type is inferred.
+
+ The elements may appear in any order, as long as the tag name appears before
+ any value, and as long as the values form a contiguous sequence, including the
+ @racket[#:rest rest] which must appear immediately after the sequence of
+ values, if specified. The @racket[dotted-rest], on the other hand, can be
+ separated from the other values, so
+ @racket[(constructor foo 1 [2 : A] 3 #:∀ (A) . 4)] is a valid (but awkward)
+ use of @racket[constructor].
+
+ The type of the @racket[dotted-rest] can still be specified using
+ @racket[typed/racket]'s reader abbreviation for @racket[ann], namely
+ @racket[#{dotted-rest :: type}].}
+
+@defform*[#:kind "match expander"
+          #:link-target? #f
+          #:literals (* : ! ::)
+          [(constructor tag-name . xlist-pats)]
+          #:grammar
+          [(tag-name Identifier)
+           (xlist-pats (patᵢ ...)
+                       (patᵢ ... . dotted-pat-rest)
+                       (patᵢ ... #:rest pat-rest))
+           (patᵢ XList-Match-Pattern)]]{
+                                        
+ Expands to a match pattern which checks whether the value is a constructor
+ with the given tag name, and then matches the constructor's value against the
+ match pattern @racket[(xlist . xlist-pats)]. The @racket[xlist] match expander
+ in turn matches each element of a (possibly improper) list against the given
+ patterns, and supports various means of specifying fixed-length, bounded and
+ unbounded repetitions like "must appear between three and five times". See the
+ documentation for the @racket[xlist] match expander for more details.}
+
+@defform[#:kind "syntax"
+         #:literals (* : ! ::)
+         (constructor? tag-name . xlist-types)
+         #:grammar
+         [(tag-name Identifier)
+          (xlist-types (τᵢ ...)
+                       (τᵢ ... . dotted-τ-rest)
+                       (τᵢ ... #:rest τ-rest))
+          (τᵢ xlist-type-or-repeated-type)
+          (τ-rest xlist-type-or-repeated-type)
+          (dotted-τ-rest #,"like τ-rest, but must not be a syntax pair")]]{
+ Expands to a predicate which returns true if and only if the following
+ conditions are met:
+ @itemlist[
+ @item{The value is a constructor with the given tag name (i.e. a tagged
+   structure with the given tag name and a single field named @racket[values],
+   so nodes and untagged structures with a single field named @racket[values]
+   are accepted too)}
+ @item{The constructor's value (i.e. the contents of its @racket[values]
+   field) is accepted by @racket[(make-predicate (xList . xlist-types))]}]}
+
+@defform[(define-constructor name maybe-tag maybe-pred? maybe-∀ . type-spec)
+         #:grammar
+         [(name Identifier)
+          (maybe-∀ (code:line)
+                   (code:line #:∀ (tvarⱼ ...)))
+          (maybe-tag (code:line)
+                          (code:line #:tag tag-name))
+          (tag-name Identifier)
+          (maybe-pred? (code:line)
+                            (code:line #:? predicate-name?))
+          (predicate-name? Identifier)
+          (types-spec (: typeᵢ ...)
+                      (! . xlist-types)
+                      (:: . xlist-types))
+          (xlist-types (τᵢ ...)
+                       (τᵢ ... . dotted-τ-rest)
+                       (τᵢ ... #:rest τ-rest))
+          (τᵢ xlist-type-or-repeated-type)
+          (τ-rest xlist-type-or-repeated-type)
+          (dotted-τ-rest #,"like τ-rest, but must not be a syntax pair")
+          (typeᵢ Type)]]{
+ Defines @racket[name] as a shorthand for the type expander, match expander,
+ builder function and predicate for a constructor with given
+ @racket[tag-name] and content types.
+
+ When @racket[#:tag tag-name] is omitted, it defaults to @racket[name].
+
+ The predicate is bound to @racket[predicate-name?]; When
+ @racket[#:? predicate-name?] is omitted, it defaults to @racket[_name?], which
+ is an identifier with the same lexical context as @racket[name], with a
+ @racket["?"] appended at the end.
+
+ The @racket[_name] and @racket[_predicate?] identifiers behave as follows:
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:kind "type expander"
+                 #:link-target? #f
+                 _name]{
+  Expands to the same type as @racket[(constructor tag-name typeᵢ ...)] or
+  @racket[(constructor tag-name . xlist-types)] would.}))))
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:link-target? #f _name]{
+  Expands to the same builder function as
+  @racket[(constructor tag-name types-spec)] would. The use of @racket[:],
+  @racket[!] or @racket[::] before the sequence of types therefore specifies
+  whether the builder function accepts a simple fixed number of arguments, a
+  variable number of arguments (performing a cast), or a single argument used as
+  the whole value for the constructor.}))))
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defform[#:kind "match expander"
+               #:link-target? #f
+               (_name patᵢ ...)]{
+                                 
+  When using the @racket[: typeᵢ ...] form of @racket[define-constructor], the
+  defined match expander expects one pattern @racket[patᵢ] per type. The
+  resulting match pattern verifies that the value is a constructor with the
+  given @racket[tag-name] containing a list with the correct number of elements,
+  and matches each element against the corresponding @racket[patᵢ].
+
+  When using the @racket[(! . xlist-types)] or @racket[(:: . xlist-types)]
+  forms of @racket[define-constructor], the defined match expander expects one
+  pattern per (possibly repeated) xlist type. The resulting match pattern
+  verifies that the value is a constructor with the given @racket[tag-name]
+  containing a value accepted by
+  @racket[(make-predicate (xlist . xlist-types))]. It then uses the
+  @racket[split-xlist] match expander, which splits the list into one sublist
+  per repeated xlist type (and a single item for each non-repeated xlist type),
+  and matches each sublist or single item against the corresponding
+  @racket[patᵢ]. See the documentation for @racket[split-xlist] for more details
+  about this process. The resulting match pattern is therefore equivalent to:
+
+  @racketblock[(and (tagged? tag-name values)
+                    (? (make-predicate (xlist . xlist-types)))
+                    (split-xlist [patᵢ ...] . xlist-types))]}))))
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:link-target? #f _predicate?]{
+  Expands to the same predicate as
+  
+  @racketblock[(constructor? tag-name (xlist τᵢ … . τ-rest))]
+
+  would, where all occurrences of @racket[tvarⱼ] type variables are replaced
+  with @racket[Any].}))))
+
+ The elements of the grammar for @racket[define-tagged] may appear in any
+ order, as long as the tag name appears before any field descriptor, and as
+ long as the field descriptors form a contiguous sequence.}
+
+@defidform[#:kind "type"
+           ConstructorTop]{ The supertype of all @tech{constructors},
+ including @tech{tagged structures}, @tech{untagged structures} and @tech{
+  nodes} which only contain a single @racket[values] field.}
+
+@defproc[(ConstructorTop? [v Any]) Boolean]{
+ A predicate for @racket[ConstructorTop]. It accepts all @tech{constructors},
+ including @tech{tagged structures}, @tech{untagged structures} and @tech{
+  nodes} which contain a single @racket[values] field, and rejects any other
+ value.}
+
+@defproc[(constructor-values [v ConstructorTop]) T]{
+ Returns the value stored within the constructor.}

phc-adt-doc/phc-adt/scribblings/phc-adt-implementation.scrbl

@@ -0,0 +1,21 @@
+#lang scribble/manual
+
+@title{Algebraic Data Types for compilers: Implementation}
+@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
+
+This library is implemented using literate programming. The implementation
+details are presented in the following sections. The user documentation is in
+the @other-doc['(lib "phc-adt/scribblings/phc-adt.scrbl")] document.
+
+@(table-of-contents)
+
+@include-section[(submod (lib "phc-adt/adt.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/tagged-structure-low-level.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/node-low-level.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/ctx.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/tagged.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/tagged-supertype.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/structure.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/constructor.hl.rkt") doc)]
+@include-section[(submod (lib "phc-adt/variant.hl.rkt") doc)]
+@include-section[(submod "phc-adt-choices.scrbl" doc)]

phc-adt-doc/phc-adt/scribblings/phc-adt-structure.scrbl

@@ -0,0 +1,190 @@
+#lang scribble/manual
+
+@(require racket/require
+          (for-label (subtract-in typed/racket/base type-expander)
+                     type-expander
+                     phc-adt
+                     (lib "phc-adt/tagged.hl.rkt")
+                     (lib "phc-adt/structure.hl.rkt") 
+                     (lib "phc-adt/constructor.hl.rkt")
+                     (lib "phc-adt/variant.hl.rkt")
+                     (lib "phc-adt/tagged-supertype.hl.rkt"))
+          scribble-enhanced/doc
+          scribble-math)
+@doc-lib-setup
+
+@title{Untagged structures}
+
+@deftech{Untagged structures} are implemented as tagged structures, using a
+special tag name: @racket[untagged]. The @racket[structure] identifier and its
+derivatives therefore simply call @racket[tagged], filling in the tag name
+with @racket[untagged].
+
+@defform[#:kind "type expander"
+         #:literals (:)
+         (structure fields-maybe-types)
+         #:grammar
+         [(fields-maybe-types (code:line just-fieldᵢ ...)
+                              (code:line maybe-∀ field+type-descriptorᵢ ...))
+          (maybe-∀ (code:line)
+                   (code:line #:∀ (tvarⱼ ...)))
+          (just-fieldᵢ fieldᵢ
+                       [fieldᵢ])
+          (field+type-descriptor [fieldᵢ typeᵢ]
+                                 [fieldᵢ : typeᵢ])
+          (fieldᵢ Identifier)
+          (typeᵢ Type)
+          (tvarⱼ Identifier)]]{
+ Expands to the same type as @racket[(tagged untagged fields-maybe-types)]
+ would.
+
+ The elements may appear in any order, as long as the field descriptors form a
+ contiguous sequence.}
+
+@defform*[#:kind "syntax"
+          #:link-target? #f
+          #:literals (:)
+          ((structure maybe-instance maybe-∀ fields-maybe-types)
+           (structure maybe-builder  maybe-∀ fields+values-maybe-types))
+          #:grammar
+          [(maybe-instance (code:line)
+                           #:instance)
+           (maybe-builder (code:line)
+                          #:builder)
+           (tag-name Identifier)
+           (maybe-∀ (code:line)
+                    (code:line #:∀ (tvarⱼ ...)))
+           (fields-maybe-types (code:line just-fieldᵢ ...)
+                               (code:line [fieldᵢ : typeᵢ] ...))
+           (just-fieldᵢ fieldᵢ
+                        [fieldᵢ])
+           (field+value-maybe-type (code:line [fieldᵢ valueᵢ] ...)
+                                   (code:line field+value+typeᵢ ...))
+           (field+value+typeᵢ [fieldᵢ : typeᵢ valueᵢ]
+                              [fieldᵢ valueᵢ : typeᵢ])
+           (fieldᵢ Identifier)
+           (typeᵢ Type)
+           (valueᵢ Expression)]]{
+
+ The first syntax expands to the same instance as
+ @racket[(tagged untagged maybe-instance maybe-∀ fields-maybe-types)]
+ would.
+
+ The second syntax expands to the same builder function as
+ @racket[(tagged untagged maybe-builder maybe-∀ fields+values-maybe-types)]
+ would.
+ 
+ The elements may appear in any order, as long as the field descriptors form a
+ contiguous sequence.}
+
+@defform[#:kind "match expander"
+         #:link-target? #f
+         #:literals (:)
+         (structure maybe-no-implicit field-maybe-patsᵢ ...)
+         #:grammar
+         [(maybe-no-implicit (code:line)
+                             (code:line #:no-implicit-bind))
+          (field-maybe-patsᵢ fieldᵢ
+                             [fieldᵢ patᵢⱼ ...])
+          (fieldᵢ Identifier)
+          (patᵢⱼ #,"match pattern")]]{
+ Expands to the same match pattern as
+ @racket[(tagged untagged maybe-no-implicit field-maybe-patsᵢ ...)] would.
+ 
+ The elements may appear in any order, as long as the
+ @racket[field-maybe-patsᵢ] form a contiguous sequence.}
+
+@defform*[#:kind "syntax"
+          #:literals (:)
+          [(structure? fieldᵢ ...)
+           (structure? [fieldᵢ : typeᵢ] ...)
+           (structure? [fieldᵢ predᵢ] ...)]
+          #:contracts ([tag-name Identifier]
+                       [fieldᵢ Identifier]
+                       [typeᵢ Type/Make-Predicate]
+                       [predᵢ (ExpressionOf (→ Any Any : typeᵢ))])]{
+
+ The first syntax expands to the same predicate as
+ @racket[(tagged untagged fieldᵢ ...)] would.
+
+ The second syntax expands to the same predicate as
+ @racket[(tagged untagged [fieldᵢ : typeᵢ] ...)] would.
+
+ The third syntax expands to the same predicate as
+ @racket[(tagged untagged [fieldᵢ predᵢ] ...)] would.
+ 
+ The elements may appear in any order, as long as the field descriptors form a
+ contiguous sequence.}
+
+@defform[#:kind "syntax"
+         #:literals (:)
+         (define-structure maybe-predicate? name fields-maybe-types)
+         #:grammar
+         [(maybe-predicate? (code:line)
+                            (code:line #:? predicate-name?))
+          (tag-name Identifier)
+          (fields-maybe-types (code:line just-fieldᵢ ...)
+                              (code:line maybe-∀ field+type-descriptorᵢ ...))
+          (maybe-∀ (code:line)
+                   (code:line #:∀ (tvarⱼ ...)))
+          (just-fieldᵢ fieldᵢ
+                       [fieldᵢ])
+          (field+type-descriptor [fieldᵢ typeᵢ]
+                                 [fieldᵢ : typeᵢ])
+          (fieldᵢ Identifier)
+          (typeᵢ Type)
+          (tvarⱼ Identifier)]]{
+
+ Defines @racket[name] and @racket[predicate?] in the same way as
+ @racket[
+ (define-tagged #:tag untagged maybe-predicate? name fields-maybe-types)] would.
+
+ The elements of the grammar for @racket[define-structure] may appear in any
+ order, as long as the field descriptors form a contiguous sequence.}
+
+@defform[#:kind "type expander"
+         #:literals (:)
+         (structure-supertype field+typeᵢ ...)
+         #:grammar
+         [(field+type [fieldᵢ typeᵢ]
+                      [fieldᵢ : typeᵢ])]]{
+ Expands to the same union type as
+ @racket[(tagged-supertype untagged field+typeᵢ ...)] would.}
+
+@defform[#:kind "match expander"
+         #:link-target? #f
+         #:literals (:)
+         (structure-supertype maybe-no-implicit field-maybe-patsᵢ ...)
+         #:grammar
+         [(maybe-no-implicit (code:line)
+                             (code:line #:no-implicit-bind))
+          (field-maybe-patsᵢ fieldᵢ
+                             [fieldᵢ patᵢⱼ ...])
+          (fieldᵢ Identifier)
+          (patᵢⱼ #,"match pattern")]]{
+ Expands to the same match pattern as
+ @racket[(tagged-supertype untagged maybe-no-implicit field-maybe-patsᵢ ...)]
+ would.
+
+The elements may appear in any order, as long as the tag name appears before
+ any field descriptor, and as long as the field descriptors form a contiguous
+ sequence.}
+
+@defform[(structure-supertype* …)]{
+ Currently not implemented. Will be equivalent to nesting
+ @racket[structure-supertype].}
+
+@defidform[#:kind "type"
+           StructureTop]{
+                         
+ The supertype of all @tech{untagged structures}, including @tech{tagged
+  structures}, @tech{constructors} and @tech{nodes} using the tag name
+ @racket[untagged]. It does not include tagged structures, constructors or
+ nodes with other tag names than @racket[untagged].}
+
+@defproc[(StructureTop? [v Any]) Boolean]{
+                                          
+ A predicate for @racket[StructureTop]. It accepts all @tech{untagged
+  structures}, including @tech{tagged structures}, @tech{constructors} and
+ @tech{nodes} using the tag name @racket[untagged], and rejects any other
+ value.}

phc-adt-doc/phc-adt/scribblings/phc-adt-tagged.scrbl

@@ -0,0 +1,327 @@
+#lang scribble/manual
+
+@(require racket/require
+          (for-label (subtract-in typed/racket/base type-expander)
+                     type-expander
+                     phc-adt
+                     racket/shared
+                     (lib "phc-adt/tagged.hl.rkt")
+                     (lib "phc-adt/structure.hl.rkt")
+                     (lib "phc-adt/constructor.hl.rkt")
+                     (lib "phc-adt/variant.hl.rkt")
+                     (lib "phc-adt/tagged-supertype.hl.rkt"))
+          scribble-enhanced/doc
+          scribble-math
+          (subtract-in scribble/struct scribble-enhanced/doc)
+          scribble/decode)
+@doc-lib-setup
+
+@title{Tagged structures}
+
+@deftech{Tagged structures} behave like Racket's plain @racket[struct]s, but
+do not need to be declared before they are used. They are similar to
+@tech[#:doc '(lib "scribblings/guide/guide.scrbl")]{prefab} structs in that
+aspect, but prefab structs lack field names, i.e. they behave more like
+vectors tagged with the prefab struct's name.
+
+A tagged structure is identified by its tag name, and its set of field names.
+The type of a tagged structure can be expressed without having declared the
+tagged structure in advance. It is also possible to create instances of tagged
+structures without declaring them beforehand, and this applies to match
+patterns for tagged structures too. Fields can be accessed without knowing the
+structure's tag name, using @racket[(uniform-get instance field-name)].
+
+These features make tagged structures particularly suited for writing
+compilers and other programs which transform large and complex data structures
+in small steps. This library is designed to work hand in hand with the
+@elem[#:style 'tt "phc-graph"] library (not available yet, but will be soon),
+which adds to tagged structures some support for safe cyclic data structures,
+and easy manipulation of those via higher-order operations. The regular tagged
+structures should normally not be used to form cyclic data structures@note{It
+ is possible in theory to build cyclic data structures using @racket[shared],
+ for example, but this use case is not supported by this library, and is
+ unlikely to play well with Typed/Racket in any case.}. Thus, the graph library
+uses @deftech{nodes} instead, which can contain cycles, as long as the cycles
+are safely created via the graph library. Nodes also have a tag name and a set
+of fields, and each node type is a subtype of the corresponding tagged
+structure with the same name and fields.
+
+@defform[#:kind "type expander"
+         #:literals (:)
+         (tagged tag-name fields-maybe-types)
+         #:grammar
+         [(tag-name Identifier)
+          (fields-maybe-types (code:line just-fieldᵢ ...)
+                              (code:line maybe-∀ field+type-descriptorᵢ ...))
+          (maybe-∀ (code:line)
+                   (code:line #:∀ (tvarⱼ ...)))
+          (just-fieldᵢ fieldᵢ
+                       [fieldᵢ])
+          (field+type-descriptor [fieldᵢ typeᵢ]
+                                 [fieldᵢ : typeᵢ])
+          (fieldᵢ Identifier)
+          (typeᵢ Type)
+          (tvarⱼ Identifier)]]{
+                               
+ Expands to the type for a tagged structure with the given tag name and
+ fields. If the types for the fields are not given, then the tagged structure
+ is polymorphic, with one type variable per field.
+
+ If @racket[#:∀ (tvarⱼ ...)] is specified, a polymorphic tagged structure is
+ polymorphic, with the given type variables.
+
+ The elements may appear in any order, as long as the tag name appears before
+ any field descriptor, and as long as the field descriptors form a contiguous
+ sequence.}
+
+@defform*[#:kind "syntax"
+          #:link-target? #f
+          #:literals (:)
+          ((tagged maybe-instance maybe-∀ tag-name fields-maybe-types)
+           (tagged maybe-builder  maybe-∀ tag-name fields+values-maybe-types))
+          #:grammar
+          [(maybe-instance (code:line)
+                           #:instance)
+           (maybe-builder (code:line)
+                          #:builder)
+           (tag-name Identifier)
+           (maybe-∀ (code:line)
+                    (code:line #:∀ (tvarⱼ ...)))
+           (fields-maybe-types (code:line just-fieldᵢ ...)
+                               (code:line [fieldᵢ : typeᵢ] ...))
+           (just-fieldᵢ fieldᵢ
+                        [fieldᵢ])
+           (field+value-maybe-type (code:line [fieldᵢ valueᵢ] ...)
+                                   (code:line field+value+typeᵢ ...))
+           (field+value+typeᵢ [fieldᵢ : typeᵢ valueᵢ]
+                              [fieldᵢ valueᵢ : typeᵢ])
+           (fieldᵢ Identifier)
+           (typeᵢ Type)
+           (valueᵢ Expression)]]{
+ When using the @racket[fields-maybe-types] syntax, this form expands to a
+ lambda function which can be used to build an instance of the tagged
+ structure, by passing as many values as there are fields.
+ 
+ When using the @racket[fields+values-maybe-types] syntax, this form directly
+ returns an instance of the tagged structure, with the given values.
+ 
+ It is mandatory to disambiguate with either @racket[#:instance] or
+ @racket[#:builder] when using @racket[tagged] with an empty list of fields
+ (i.e. a structure with no fields) as it cannot be guessed from the syntax
+ otherwise, so it is best to always include one or the other when writing a
+ macro which expands to uses of @racket[tagged].
+
+ When types are specified, they are used to annotate the values when producing
+ an instance, otherwise they are used as the argument types for the builder
+ function.
+
+ When @racket[#:∀ (tvarⱼ ...)] is specified for a builder, a polymorphic
+ builder is produced, with the given @racket[tvarⱼ ...] type variables.
+
+ When @racket[#:∀ (tvarⱼ ...)] is specified for an instance, the type of
+ values annotated with @racket[tvarⱼ] is inferred, and an instance of a
+ polymorphic tagged structure is produced. A @racket[tvarⱼ] can be used within
+ a more complex type, in which case only that part of the type is inferred.
+ 
+ The elements may appear in any order, as long as the tag name appears before
+ any field descriptor, and as long as the field descriptors form a contiguous
+ sequence.}
+
+@defform[#:kind "match expander"
+         #:link-target? #f
+         #:literals (:)
+         (tagged tag-name maybe-no-implicit field-maybe-patsᵢ ...)
+         #:grammar
+         [(tag-name Identifier)
+          (maybe-no-implicit (code:line)
+                             (code:line #:no-implicit-bind))
+          (field-maybe-patsᵢ fieldᵢ
+                             [fieldᵢ patᵢⱼ ...])
+          (fieldᵢ Identifier)
+          (patᵢⱼ #,"match pattern")]]{
+ Expands to a match pattern for a tagged structure with the given name and
+ fields. The value of each @racket[fieldᵢ] is matched against all of the
+ corresponding @racket[patᵢⱼ ...]. When there are not @racket[patᵢⱼ] for a
+ @racket[fieldᵢ], the brackets around the field name may be omitted.
+
+ Unless @racket[#:no-implicit-bind] is specified, every @racket[fieldᵢ] is
+ bound by the match pattern to the field's value.
+
+ The elements may appear in any order, as long as the tag name appears before
+ any @racket[field-maybe-patsᵢ], and as long as the @racket[field-maybe-patsᵢ]
+ form a contiguous sequence.}
+
+@defform*[#:kind "syntax"
+          #:literals (:)
+          [(tagged? tag-name fieldᵢ ...)
+           (tagged? tag-name [fieldᵢ : typeᵢ] ...)
+           (tagged? tag-name [fieldᵢ predᵢ] ...)]
+          #:contracts ([tag-name Identifier]
+                       [fieldᵢ Identifier]
+                       [typeᵢ Type/Make-Predicate]
+                       [predᵢ (ExpressionOf (→ Any Any : typeᵢ))])]{
+ Expands to a predicate for tagged structures with the given @racket[tag] and
+ @racket[field]s. If types are specified, each @racket[typeᵢ] is passed to
+ @racket[make-predicate], and the resulting predicate is checked against the
+ value of the corresponding @racket[fieldᵢ].
+
+ Each @racket[typeᵢ] must therefore be a valid type for which
+ @racket[make-predicate] can generate a predicate (@racket[make-predicate]
+ cannot create a predicate for some types, like function types, or any type
+ which translates to a
+ @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{chaperone}
+ contract.
+
+ The last form allows the use of arbitrary predicates @racket[predᵢ] which are
+ checked against the value of the corresponding @racket[fieldᵢ]. When the type
+ of a given @racket[predᵢ] includes a filter asserting that it returns true if
+ and only if the value is of type @racket[typeᵢ], then the predicate produced by
+ @racket[tagged-predicate!] will also have that filter on the corresponding
+ field. By default, any function of type @racket[(→ Any Any)] will
+ implicitly have the @racket[Any] filter, which does not bring any extra
+ information.
+
+ The elements may appear in any order, as long as the tag name appears before
+ any field descriptor, and as long as the field descriptors form a contiguous
+ sequence.}
+
+@defform[#:kind "syntax"
+         #:literals (:)
+         (define-tagged name maybe-tag-name maybe-predicate? fields-maybe-types)
+         #:grammar
+         [(name Identifier)
+          (maybe-tag-name (code:line)
+                          (code:line #:tag tag-name))
+          (tag-name Identifier)
+          (maybe-predicate? (code:line)
+                            (code:line #:? predicate-name?))
+          (predicate-name? Identifier)
+          (fields-maybe-types (code:line just-fieldᵢ ...)
+                              (code:line maybe-∀ field+type-descriptorᵢ ...))
+          (maybe-∀ (code:line)
+                   (code:line #:∀ (tvarⱼ ...)))
+          (just-fieldᵢ fieldᵢ
+                       [fieldᵢ])
+          (field+type-descriptor [fieldᵢ typeᵢ]
+                                 [fieldᵢ : typeᵢ])
+          (fieldᵢ Identifier)
+          (typeᵢ Type)
+          (tvarⱼ Identifier)]]{
+                               
+ Defines @racket[name] as a shorthand for the type expander, match expander,
+ builder function and predicate for a tagged structure with the given
+ @racket[tag-name] and fields.
+
+ When @racket[#:tag tag-name] is omitted, it defaults to @racket[name].
+
+ The predicate is bound to @racket[predicate-name?]; When
+ @racket[#:? predicate-name?] is omitted, it defaults to @racket[_name?], which
+ is an identifier with the same lexical context as @racket[name], with a
+ @racket["?"] appended at the end.
+
+ The @racket[_name] and @racket[_predicate?] identifiers behave as follows:
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:kind "type expander"
+                 #:link-target? #f
+                 _name]{
+  Expands to the same type as @racket[(tagged tag-name fields-maybe-types)]
+  would.}))))
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:link-target? #f _name]{
+  Expands to the same builder function as
+  @racket[(tagged #:builder tag-name fields-maybe-types)] would.}))))
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defform[#:kind "match expander"
+               #:link-target? #f
+               (_name patᵢ ...)]{
+  Expands to the same match pattern as
+  @racket[(tagged tag-name [fieldᵢ patᵢ] ...)] would.}))))
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:link-target? #f _predicate?]{
+  Expands to the same predicate as @racket[(tagged? just-fieldᵢ)] would. Note
+  that it does not attempt to check the field values, as doing so would mean
+  that all of the @racket[typeᵢ], if specified, would have to be suitable
+  arguments for @racket[make-predicate].}))))
+
+ The elements of the grammar for @racket[define-tagged] may appear in any
+ order, as long as the tag name appears before any field descriptor, and as
+ long as the field descriptors form a contiguous sequence.}
+
+@defform[#:kind "type expander"
+         #:literals (:)
+         (tagged-supertype tag-name field+typeᵢ ...)
+         #:grammar
+         [(tag-name Identifier)
+          (field+type [fieldᵢ typeᵢ]
+                      [fieldᵢ : typeᵢ])]]{
+ Expands to the union type of all tagged structures with the given name and a
+ superset of the given fields, where each given @racket[fieldᵢ] must have the
+ corresponding type @racket[typeᵢ], and the other fields have the type
+ @racket[Any].}
+
+@defform[#:kind "match expander"
+         #:link-target? #f
+         #:literals (:)
+         (tagged-supertype tag-name maybe-no-implicit field-maybe-patsᵢ ...)
+         #:grammar
+         [(tag-name Identifier)
+          (maybe-no-implicit (code:line)
+                             (code:line #:no-implicit-bind))
+          (field-maybe-patsᵢ fieldᵢ
+                             [fieldᵢ patᵢⱼ ...])
+          (fieldᵢ Identifier)
+          (patᵢⱼ #,"match pattern")]]{
+ Expands to a match pattern accepting any tagged structures with the given
+ name and a superset of the given fields, where each given @racket[fieldᵢ] must
+ match all the corresponding @racket[patᵢⱼ], and the other fields are matched
+ against @racket[_] (i.e. they can contain any value).
+
+ Unless @racket[#:no-implicit-bind] is specified, every @racket[fieldᵢ] is
+ bound by the match pattern to the field's value, but the other extra fields
+ are not bound to any variable.
+ 
+ The elements may appear in any order, as long as the tag name appears before
+ any field descriptor, and as long as the field descriptors form a contiguous
+ sequence.}
+
+@defform[(tagged-supertype* …)]{
+ Currently not implemented. Will be equivalent to nesting
+ @racket[tagged-supertype].}
+
+@defidform[#:kind "type"
+           TaggedTop]{
+                      
+ The supertype of all @tech{tagged structures}, including @tech{untagged
+  structures}, @tech{nodes} and @tech{constructors}.}
+
+@defproc[(TaggedTop? [v Any]) Boolean]{
+ A predicate for @racket[TaggedTop]. It accepts all @tech{tagged structures},
+ including @tech{untagged structures}, @tech{nodes} and @tech{constructors},
+ and rejects any other value.}
+
+@defform[(uniform-get v f)
+         #:grammar
+         ([v Expression]
+          [f Identifier])]{
+ Returns the value contained within the @racket[f] field of the tagged structure
+ instance @racket[v].}

phc-adt-doc/phc-adt/scribblings/phc-adt-variant.scrbl

@@ -0,0 +1,142 @@
+#lang scribble/manual
+
+@(require racket/require
+          (for-label (subtract-in typed/racket/base type-expander)
+                     type-expander
+                     phc-adt
+                     (lib "phc-adt/tagged.hl.rkt")
+                     (lib "phc-adt/structure.hl.rkt")
+                     (lib "phc-adt/constructor.hl.rkt")
+                     (lib "phc-adt/variant.hl.rkt")
+                     (lib "phc-adt/tagged-supertype.hl.rkt"))
+          scribble-enhanced/doc
+          scribble-math
+          (subtract-in scribble/struct scribble-enhanced/doc)
+          scribble/decode)
+@doc-lib-setup
+
+@title{Variants}
+
+@deftech{Variants} behave like @racketmodname[typed/racket]'s union types
+(expressed via @racket[U]). They benefit however of special support by the
+graph library (not published yet), which needs to rewrite data structures
+in-depth during the construction of the graph, and cannot handle arbitrary data
+structures.
+
+@defform[#:kind "type-expander"
+         #:literals (constructor tagged)
+         (variant maybe-check-overlap
+                  constructor-or-taggedᵢ ...
+                  maybe-one-other-type)
+         #:grammar
+         [(maybe-check-overlap (code:line)
+                               (code:line #:check-overlap))
+          (constructor-or-tagged (tagged      tag-nameᵢ . tagged-args)
+                                 (structure             . structure-args)
+                                 (constructor tag-nameᵢ . constructor-args))
+          (constructor tag-name maybe-∀ τᵢ ... #:rest τ-rest)
+          (tag-nameᵢ Identifier)
+          (maybe-one-other-type (code:line)
+                                (code:line Type))]]{
+ The current implementation does not completely match this documentation, but
+ the implementation should shortly be updated.
+
+ Expands to the union type of all the given @tech{tagged structures}, @tech{
+  untagged structures} and @tech{constructors}.
+
+ When another type which is not a tagged structure or similar is specified,
+ it is included in the union. Only one such type is allowed.
+
+ The types passed to @racket[variant] should not overlap. When the keyword
+ @racket[#:check-overlap] is specified, @racket[variant] uses a hack to throw
+ an error when two types overlap. The error message can however be unclear and
+ misleading, so this feature is disabled by default.
+
+ The elements of the grammar for @racket[define-tagged] may appear in any
+ order, as long as the @racket[constructor-or-taggedᵢ ... maybe-one-other-type]
+ form a contiguous sequence (the @racket[maybe-one-other-type] may occur at any
+ position within the sequence, but must be included at most once).}
+
+@defidform[#:kind "type-expander"
+           V]{
+ An alias for the @racket[variant] type expander.
+}
+
+@defform[#:kind "syntax"
+         #:literals (constructor tagged)
+         (variant? maybe-check-overlap
+                   constructor-or-taggedᵢ ...
+                   maybe-one-other-type)
+         #:grammar
+         [(maybe-check-overlap (code:line)
+                               (code:line #:check-overlap))
+          (constructor-or-tagged (tagged      tag-nameᵢ . tagged-args)
+                                 (structure             . structure-args)
+                                 (constructor tag-nameᵢ . constructor-args))
+          (constructor tag-name maybe-∀ τᵢ ... #:rest τ-rest)
+          (tag-nameᵢ Identifier)
+          (maybe-one-other-type (code:line)
+                                (code:line Type))]]{
+ The current implementation does not completely match this documentation, but
+ the implementation should shortly be updated.
+
+ Expands to a predicate for the type:
+ 
+ @racketblock[(variant maybe-check-overlap
+                       constructor-or-taggedᵢ ...
+                       maybe-one-other-type)]
+
+ The elements of the grammar for @racket[variant] may appear in any order, as
+ long as the @racket[constructor-or-taggedᵢ ... maybe-one-other-type] form a
+ contiguous sequence (the @racket[maybe-one-other-type] may occur at any
+ position within the sequence, but must be included at most once).}
+
+@defform[#:kind "syntax"
+         #:literals (:)
+         (define-variant name maybe-predicate? maybe-check-overlap cases)
+         #:grammar
+         [(name Identifier)
+          (maybe-predicate? (code:line)
+                            (code:line #:? predicate-name?))
+          (predicate-name? Identifier)
+          (maybe-check-overlap (code:line)
+                               (code:line #:check-overlap))
+          (cases (code:line constructor-or-taggedᵢ ... maybe-one-other-type))
+          (constructor-or-tagged (tagged      tag-nameᵢ . tagged-args)
+                                 (structure             . structure-args)
+                                 (constructor tag-nameᵢ . constructor-args))
+          (constructor tag-name maybe-∀ τᵢ ... #:rest τ-rest)
+          (tag-nameᵢ Identifier)
+          (maybe-one-other-type (code:line)
+                                (code:line Type))]]{
+ The current implementation does not completely match this documentation, but
+ the implementation should shortly be updated.
+
+ Defines @racket[name] as a shorthand for the type expander and predicate for
+ a variant with the given cases.
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:kind "type expander"
+                 #:link-target? #f
+                 _name]{
+  Expands to the same type as @racket[(variant maybe-check-overlap cases)]
+  would.}))))
+
+ @(make-blockquote
+   "leftindent"
+   (flow-paragraphs
+    (decode-flow
+     (splice-run
+      @defidform[#:link-target? #f _predicate?]{
+                                                
+  Expands to the same predicate as @racket[(variant? maybe-check-overlap cases)]
+  would.}))))
+
+ The elements of the grammar for @racket[define-variant] may appear in any
+ order, as long as the @racket[constructor-or-taggedᵢ ... maybe-one-other-type]
+ form a contiguous sequence (the @racket[maybe-one-other-type] may occur at any
+ position within the sequence, but must be included at most once).}

phc-adt-doc/phc-adt/scribblings/phc-adt.scrbl

@@ -0,0 +1,87 @@
+#lang scribble/manual
+
+@(require racket/require
+          (for-label typed/racket/base
+                     phc-adt
+                     (lib "phc-adt/tagged.hl.rkt")
+                     (lib "phc-adt/structure.hl.rkt")
+                     (lib "phc-adt/constructor.hl.rkt")
+                     (lib "phc-adt/variant.hl.rkt")
+                     (lib "phc-adt/tagged-supertype.hl.rkt")
+                     (lib "phc-adt/adt-init.rkt"))
+          scribble-enhanced/doc
+          scribble-math
+          (subtract-in scribble/struct scribble-enhanced/doc)
+          scribble/decode)
+@doc-lib-setup
+
+@title{Algebraic Data Types for compilers}
+
+@defmodule[phc-adt
+           #:use-sources
+           [(lib "phc-adt/tagged.hl.rkt")
+            (lib "phc-adt/structure.hl.rkt")
+            (lib "phc-adt/constructor.hl.rkt")
+            (lib "phc-adt/variant.hl.rkt")
+            (lib "phc-adt/tagged-supertype.hl.rkt")
+            (lib "phc-adt/adt-init.rkt")]]
+
+This library is implmented using literate programming. The
+implementation details are presented in 
+@other-doc['(lib "phc-adt/scribblings/phc-adt-implementation.scrbl")].
+
+This library defines @tech{tagged structures}, @tech{untagged structures},
+@tech{constructors} and @tech{variants}. While uses of Racket's
+@racket[struct] need the struct to be declared before they are used, the
+structures implemented by this library can be used anonymously, without
+declaring them in advance. All uses of a tagged structure with the same tag
+name and set of fields are equivalent, even if they are declared in separate
+files. It is also possible to access a field on a tagged structure instance
+without specifying the tagged structure's tag name. This is used in a separate
+library (not published yet) to implement the dotted notation commonly used in
+object-oriented languages for field accesses, @racket[instance.field].
+
+This library works by saving across compilations the list of all tagged
+structures used across the program. The tag name and list of field names for
+each tagged structure is written to a file. That file is, by default, located
+in the same directory as the source file, and it is called
+@filepath{adt-pre-declarations.rkt}, but this can be changed using the optional
+argument to @racket[adt-init]. These "remembered" tagged structure definitions
+are used to pre-declare the @racket[struct]s corresponding to each tagged
+structure, so that all the code using the same
+@filepath{adt-pre-declarations.rkt} file sees the same structure definitions.
+
+@defform*[[(adt-init)
+           (adt-init pre-declarations-file)]
+          #:contracts
+          [(pre-declarations-file string?)]]{
+ The @racket[(adt-init)] macro has to be called in a
+ @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{module context},
+ after the @racket[(require phc-adt)] but before using any of the identifiers
+ provided by this library.
+
+ The @racket[pre-declarations-file] (which defaults to @filepath{
+  adt-pre-declarations.rkt}) should be the string representation of a path,
+ relative to the directory containing the file which uses @racket[adt-init].
+ 
+ The @racket[adt-init] macro creates the @racket[pre-declarations-file] if it
+ does not exist, and @racket[require]s it. The @racket[pre-declarations-file]
+ contains a list of remembered tagged structures (specifically, the tag name
+ followed by a list of field names). It uses the @hash-lang[]
+ @racketmodname[phc-adt/declarations] which pre-declares the @racket[struct]s
+ corresponding to each remembered tagged structure.
+
+ It then makes all the identifiers defined by this library available (the
+ identifiers cannot otherwise be used before calling @racket[adt-init]).}
+
+@defmodulelang[phc-adt/declarations #:no-declare]{
+ This @hash-lang[] is used by the @racket[_pre-declarations-file] (see
+ @racket[adt-init]), and is not intended to be used in other situations.}
+
+
+@(table-of-contents)
+
+@include-section{phc-adt-tagged.scrbl}
+@include-section{phc-adt-structure.scrbl}
+@include-section{phc-adt-constructor.scrbl}
+@include-section{phc-adt-variant.scrbl}

phc-adt-lib/info.rkt

@@ -0,0 +1,25 @@
+#lang info
+(define collection 'multi)
+(define deps '("base"
+               "typed-racket-lib"
+               "hyper-literate"
+               "multi-id"
+               "phc-toolkit"
+               "remember"
+               "type-expander"
+               "extensible-parser-specifications"
+               "alexis-util"
+               "typed-struct-props"
+               "match-string"
+               "xlist"
+               "compatibility-lib"
+               "generic-bind"
+               "datatype"))
+(define build-deps '("at-exp-lib"
+                     "sandbox-lib"
+                     "scribble-enhanced"
+                     "scribble-lib"
+                     "scribble-math"))
+(define pkg-desc "Algebraic Datatypes tailored for writing compilers (tests are in phc-adt-test)")
+(define version "1.1")
+(define pkg-authors '("Georges Dupéron"))

phc-adt-lib/phc-adt/adt-init.rkt

@@ -0,0 +1,51 @@
+#lang at-exp typed/racket
+(provide adt-init)
+(require remember
+         "ctx.hl.rkt"
+         phc-toolkit
+         (for-syntax (only-in '#%kernel [#%app #%plain-app])
+                     syntax/parse
+                     syntax/parse/experimental/template
+                     phc-toolkit/untyped
+                     racket/port
+                     mzlib/etc))
+
+(define-for-syntax ((the-trampoline srcdir pre-declarations-filename) stx2)
+  (syntax-case stx2 ()
+    [(_ self2)
+     #`(adt-init-2 self2
+                   #,srcdir
+                   #,pre-declarations-filename)]))
+
+(define-syntax adt-init
+  (syntax-parser
+    [(self (~optional pre-declarations-filename
+                      #:defaults ([pre-declarations-filename
+                                   #'"adt-pre-declarations.rkt"])))
+     #'(begin (define-syntaxes (trampoline)
+                (#%plain-app the-trampoline
+                             (this-expression-source-directory self)
+                             'pre-declarations-filename))
+              (begin-for-syntax (set-adt-context #'self))
+              (trampoline self))]))
+
+(define-syntax/parse (adt-init-2 ctx pre-declarations-dir pre-declarations-file)
+  (define pre-declarations-path
+    (build-path (syntax-e #'pre-declarations-dir)
+                (syntax-e #'pre-declarations-file)))
+  (define pre-declarations-path-string
+    (path->string pre-declarations-path))
+
+  ;; Initialize the pre-declarations file if it is empty:
+  (init-file pre-declarations-path
+             "#lang s-exp phc-adt/declarations\n")
+
+  (remember-output-file-parameter pre-declarations-path-string)
+  ;(set-adt-context #'ctx)
+  #`(require #,(datum->syntax #'ctx (syntax-e #'pre-declarations-file))))
+
+(define-for-syntax (init-file path string-contents)
+  (unless (file-exists? path)
+    (with-handlers ([exn:fail:filesystem (λ (exn) (void))])
+      (with-output-file [port path] #:exists 'error
+        (display string-contents port)))))

phc-adt-lib/phc-adt/adt-second-step.rkt

@@ -0,0 +1,3 @@
+#lang typed/racket
+(require "adt.hl.rkt")
+(provide (all-from-out "adt.hl.rkt"))

phc-adt-lib/phc-adt/adt.hl.rkt

@@ -0,0 +1,253 @@
+#lang hyper-literate typed/racket/base
+@(require scribble-enhanced/doc
+          scribble-math
+          racket/sandbox
+          scribble/example
+          (for-label typed/racket/base
+                     phc-toolkit
+                     phc-toolkit/untyped-only
+                     datatype
+                     "ctx.hl.rkt"
+                     "tagged.hl.rkt"
+                     "tagged-supertype.hl.rkt"
+                     "structure.hl.rkt"
+                     "constructor.hl.rkt"
+                     "variant.hl.rkt"
+                     "adt-init.rkt"))
+@doc-lib-setup
+
+@title[#:style (with-html5 manual-doc-style)
+       #:tag "adt"
+       #:tag-prefix "phc-adt/adt"]{Algebraic Data Types}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/adt"))
+
+@(table-of-contents)
+
+@section{A note on polysemy}
+
+The name ``constructor'' usually designates two things:
+@itemlist[
+ @item{A tagged value, like the ones created or accessed using the
+  @racket[constructor] macro defined in
+  @secref["constructor" #:tag-prefixes '("phc-adt/constructor")]}
+ @item{A constructor function or macro for some kind of data structure, which
+  is the function or macro used to create instances of that data structure.}]
+
+Since this could lead to ambiguities, we clarify by saying ``constructor'' in
+the former case, and ``builder'' or ``builder function'' in the latter case.
+
+@section[#:tag "ADT|introduction"]{Introduction}
+
+We define variants (tagged unions), with the following constraints:
+
+@; TODO: put a short usage example here
+
+@itemlist[
+ @item{A constructor is described by a tag name, followed by zero or more
+  values. Likewise, a tagged structure is described by a tag name, followed by
+  zero or more field names, each field name being mapped to a value.}
+ @item{Two different variants can contain the same constructor or tagged
+  structure, and it is not possible to create an instance of that constructor or
+  tagged structure that would belong to one variant but not the other.}
+ @item{Constructors and tagged structures are "anonymous": it is not necessary
+  to declare a constructor or tagged structure before creating instances of it,
+  expressing its type, or using it as a match pattern.}
+ @item{Constructors types and tagged structures types are "interned": two
+  constructors with the same tag name have the same type, even if they are used
+  in different files. The same applies to two tagged structures with the same
+  tag name and field names: even if they are used in different files, they have
+  the same type.}]
+
+The @racketmodname[datatype] package by Andrew Kent also
+implements Algebraic Data Types. The main differences are that unlike our
+library, data structures have to be declared before they are used (they are
+not "anonymous"), and a given constructor name cannot be shared by multiple
+unions, as can be seen in the example below where the second
+@tc[define-datatype] throws an error:
+
+@(define tr-evaluator
+   (parameterize ([sandbox-output 'string]
+                  [sandbox-error-output 'string])
+     (make-evaluator 'typed/racket)))
+@examples[#:eval tr-evaluator
+          (require datatype)
+          
+          (define-datatype Expr
+            [Var (Symbol)]
+            [Lambda (Symbol Expr)]
+            [App (Expr Expr)])
+          
+          ;; define-datatype: variant type #<syntax:11:3 Var> already bound
+          ;; in: Simple-Expr
+          (eval:error
+           (define-datatype Simple-Expr
+             [Var (Symbol)]
+             [Lambda (Symbol Expr)]))]
+
+@section{Remembered data types and pre-declarations}
+
+This library works by remembering all the constructors and all the tagged
+structures across compilations. More precisely, each constructor's tag name is
+written to a file named @filepath{adt-pre-declarations.rkt} in the same
+directory as the user code. The tag name and list of fields of each tagged
+structure is also written in the same file.
+
+The generated @racket{adt-pre-declarations.rkt} file declares a
+@racket[struct] for each tagged structure and constructor, so that all user
+files which @racket[require] the same @racket{adt-pre-declarations.rkt} will
+share the same @racket[struct] definitions.
+
+User files which make use of the @racketmodname[phc-adt] should include a call
+to @racket[adt-init] before using anything else. The @racket[adt-init] macro
+@racket[require]s the @filepath{adt-pre-declarations.rkt} file, and records
+the lexical context of that @racket[require], so that the other macros
+implemented by this library can fetch the pre-declared @racket[struct] types
+from the correct lexical scope. The @filepath{ctx.hl.rkt} file takes care of
+recording that lexical scope, while @filepath{adt-init.rkt} performs the
+initialisation sequence (creating the @filepath{adt-pre-declarations.rkt} file
+if it does not exist, loading the pre-declared @racket[struct] types from
+@filepath{adt-pre-declarations.rkt}, and using a utility from
+@filepath{ctx.hl.rkt} to record the lexical context).
+
+@chunk[<require-modules>
+       (require "ctx.hl.rkt")]
+
+@section{The initialisation process}
+
+The initialisation process can be somewhat complex: the directives
+@racket[(remember-output-file "adt-pre-declarations.rkt")],
+@racket[(set-adt-context)] and @racket[(require "adt-pre-declarations.rkt")]
+have to be inserted in the right order, and the file
+@filepath{adt-pre-declarations.rkt} has to be initialised with the appropriate
+contents when it does not exist. The @racket[adt-init] macro defined in
+@filepath{"adt-init.rkt"} takes care of these steps.
+
+@chunk[<require-modules>
+       (require "adt-init.rkt")]
+
+The generated @filepath{adt-pre-declarations.rkt} file will call the
+@racket[pre-declare-all-tagged-structure-structs] macro defined in
+@filepath{tagged-structure-low-level.hl.rkt}.
+
+@section{Tagged structures, untagged structures, constructors, and variants}
+
+We first define a low-level interface for tagged structures in the
+@filepath{tagged-structure-low-level.hl.rkt} file. This low-level interface
+includes for-syntax functions for expressing the type of tagged structures,
+creating builder functions for them, as well as match patterns. It also includes
+means to access the value of a given field on any tagged structure which
+contains that field. The @filepath{tagged.hl.rkt} file provides syntactic sugar
+for this low-level interface, and defines the @racket[tagged] identifier, which
+acts as a type expander, match expander and macro. The macro can be used to
+create builder functions which return instances of tagged structures, or to
+directly create such instances.
+
+@chunk[<require-modules>
+       (require "tagged.hl.rkt")]
+
+The @filepath{"tagged-supertype.hl.rkt"} file defines a few operations
+implementing some form of "static duck typing": As a type expander,
+@racket[(tagged-supertype fieldᵢ …)] expands to the union type of all tagged
+structures containing a superset of the given set of fields. As a match
+expander, @racket[(tagged-supertype [fieldᵢ patᵢⱼ …] …)] expands to a match
+pattern which accepts any tagged structure with a superset of the given set of
+fields, as long as the value of each @racket[fieldᵢ] matches against all of the
+corresponding @racket[patᵢⱼ …].
+
+@chunk[<require-modules>
+       (require "tagged-supertype.hl.rkt")]
+
+We then define untagged structures, which are tagged structures with the
+@racket[untagged] tag name. Untagged structures can be used conveniently when
+the tag name is not important and the goal is simply to map a set of field names
+to values. The @filepath{structure.hl.rkt} file defines the @tc[structure]
+type expander, match expander and macro. The @tc[structure] identifier acts as
+a simple wrapper around @racket[tagged] which supplies @racket[untagged] as the
+tag name.
+
+@chunk[<require-modules>
+       (require "structure.hl.rkt")]
+
+Constructors are defined as tagged structures containing a single field, called
+@racket[values]. The @racket[constructor] macro, defined in
+@filepath{"constructor.hl.rkt"} accepts a rich syntax for creating constructor
+instances containing multiple values, associated with the tag name. The values
+are aggregated in a list, which is stored within the @racket[values] field of
+the tagged structure used to implement the constructor. The @racket[constructor]
+identifier is therefore nothing more than syntactic sugar for @racket[tagged].
+It relies on the @racketmodname[xlist] library, which provides a rich syntax for
+expressing the complex list types, as well as the corresponding match pattern.
+
+@chunk[<require-modules>
+       (require "constructor.hl.rkt")]
+
+For convenience, we write a @tc[variant] form, which is a thin wrapper against
+the union type of several constructors and tagged structures,
+@tc[(U constructor-or-tagged …)].
+
+@chunk[<require-modules>
+       (require "variant.hl.rkt")]
+
+Finally, we directly include the row polymorphism features from
+@filepath{tagged-structure-low-level.hl.rkt}:
+
+@chunk[<require-modules>
+       (require "tagged-structure-low-level.hl.rkt")]
+
+@;{Finally, we define a @tc[uniform-get] form, which can
+operate on @tc[tagged] structures. We also wrap the plain 
+@tc[structure] form so that it instead returns a tagged
+structure, using a common tag for all plain structures. This
+allows us to rely on the invariant that @tc[uniform-get]
+always operates on data with the same shape (a constructor
+whose single value is a promise for a structure)@note{This
+ avoids the risk of combinatorial explosion for the input
+ type of @racket[uniform-get], when accessing a deeply nested
+ field: allowing
+ @racket[(U structure
+            (constructor structure)
+            (constructor (Promise structure)))]
+ would result in a type of size @${n⁴}, with @${n} the depth
+ of the accessed field.}}
+
+@chunk[<*>
+       (begin <require-modules>)
+       (provide adt-init
+                tagged
+                tagged?
+                define-tagged
+                TaggedTop
+                TaggedTop?
+                tagged-supertype
+                tagged-supertype*
+                
+                structure
+                structure?
+                define-structure
+                StructureTop
+                StructureTop?
+                structure-supertype
+                
+                constructor
+                constructor?
+                define-constructor
+                ConstructorTop
+                ConstructorTop?
+                
+                variant
+                define-variant
+
+                constructor-values
+                uniform-get
+
+                split
+                #;(for-syntax split/type)
+                merge
+                #;(for-syntax merge/type)
+                with+
+                with!
+                with!!
+                #;(for-syntax tagged-struct-id?))]

phc-adt-lib/phc-adt/check-no-overlap.rkt

@@ -0,0 +1,24 @@
+#lang typed/racket
+(struct (A) st ([x : A]))
+(require phc-toolkit
+         racket/format)
+
+(struct variant-no-overlap ())
+(define-syntax/parse (check-no-overlap τ₁ τ₂)
+  #`(let ()
+      (λ ([x : (U (∩ τ₁ τ₂) variant-no-overlap)])
+        (cond
+          [(variant-no-overlap? x) #t]
+          [(typecheck-fail τ₁
+                           #,(format "The types ~a and ~a seem to overlap"
+                                     (syntax->datum #'τ₁)
+                                     (syntax->datum #'τ₂)))]))
+      (void)))
+
+
+(check-no-overlap (st Number) (st String))
+(check-no-overlap (st Negative-Integer) (st Byte))
+(check-not-tc
+ #:message-regexp
+ #rx"The types \\(st Nonpositive-Integer\\) and \\(st Byte\\) seem to overlap"
+ (check-no-overlap (st Nonpositive-Integer) (st Byte)))

phc-adt-lib/phc-adt/constructor.hl.rkt

@@ -0,0 +1,673 @@
+#lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require
+@(require racket/require
+          scribble-math
+          scribble-enhanced/doc
+          (subtract-in scribble/core scribble-enhanced/doc)
+          xlist/scribble-enhanced
+          (for-label (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                     (lib "phc-adt/node-low-level.hl.rkt")
+                     (lib "phc-adt/tagged.hl.rkt")
+                     xlist
+                     racket/list
+                     (subtract-in racket/set type-expander)
+                     syntax/parse
+                     syntax/parse/experimental/template
+                     (subtract-in racket/syntax phc-toolkit)
+                     phc-toolkit/untyped-only
+                     (except-in (subtract-in typed/racket/base type-expander)
+                                values)
+                     (except-in phc-toolkit ?)
+                     multi-id
+                     type-expander
+                     type-expander/expander))
+@doc-lib-setup
+
+@(unless-preexpanding
+  (require (for-label (submod ".."))))
+
+@title[#:style (with-html5 manual-doc-style)
+       #:tag "constructor"
+       #:tag-prefix "phc-adt/constructor"]{User API for constructors}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/constructor"))
+
+@(table-of-contents)
+
+@section{Introduction}
+
+This file defines @tc[constructor], a form which allows tagging values, so that
+two otherwise identical values can be distinguished by the constructors used to
+wrap them. Coupled with the variants defined by this library, it implements a
+slight variation on the constructors and variants commonly found in other
+languages. The @tc[constructor] form is effectively a wrapper around @tc[tagged]
+structures, which stores all values within a single field named @tc[values].
+
+The constructors defined in this library are "interned", meaning that two
+constructors in different files will be the same if they use same tag name. In
+other words, the tag of a constructor works in the same way as a symbol in
+Racket: unless otherwise specified, the same string of characters will always
+produce the same symbol, even across modules. The same goes for constructors:
+the same constructor name will always refer to the same type.
+
+@section{The polyvalent identifier @racket[constructor]:
+ type, match, builder and instance}
+
+We define the @tc[constructor] macro which acts as a type, a match expander, and
+a constructor function (which can be called to create a tagged value, i.e. a
+constructor instance). It can also be directly given a value to directly produce
+a tagged value, i.e. a constructor instance.
+
+@chunk[<constructor>
+       (define-multi-id constructor
+         #:type-expander  (make-rest-transformer <type-expander>)
+         #:match-expander (make-rest-transformer <match-expander>)
+         #:call           (make-rest-transformer <call-expander>))]
+
+The @tc[constructor?] macro returns a predicate for the
+given constructor name, or checks if a value is an instance
+of the given constructor name. This form is implemented in 
+@racket[<predicate>] below.
+
+@chunk[<constructor?>
+       (define-syntax constructor? (make-rest-transformer <predicate>))]
+
+@section{Type-expander}
+
+@chunk[#:save-as constructor-type-types-mixin <constructor-type-types-mixin>
+       (define-eh-alternative-mixin types-mixin
+         (pattern
+          (~maybe/empty (~after name-order-point <name-after-field-error>
+                                τᵢ:type … {~lift-rest τ-rest}))))]
+
+
+@chunk[#:save-as name-after-field-error <name-after-field-error>
+       "The name must appear before any value or type"]
+
+@chunk[#:save-as name-id-mixin <name-id-mixin>
+       (define-eh-alternative-mixin name-id-mixin
+         (pattern
+          (~once (~order-point name-order-point name:id))))]
+
+@chunk[#:save-as ∀-mixin <∀-mixin>
+       (define-eh-alternative-mixin ∀-mixin
+         (pattern {~optional (~seq #:∀ ({~named-seq tvarᵢ :id …})
+                                   (~global-or tvars?)
+                                   #;(~global-or [no-types? #f])
+                                   #;<∀-fail-no-types>)}))]
+
+@; TODO: this depends on the order in which mixins are included, because
+@; no-types? may be declared by a mixin included later on.
+@chunk[#:save-as ∀-fail-no-types <∀-fail-no-types>
+       #|
+       {~post-fail (string-append "Expected [field:id type:expr] … or"
+       " [field:id : type:expr] … because #:∀ is"
+       " used")
+       #:when (attribute no-types?)}
+       |#]
+
+The type-expander for @tc[constructor] expects:
+
+@(require scribble/decode)
+
+@itemlist[
+ @item{The constructor's tag name, as defined for the tagged call expander in
+       @(make-link-element
+         #f
+         (racket <name-id-mixin>)
+         `(elem (prefixable "(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+                            "phc-adt/tagged"
+                            "chunk:<name-id-mixin>:1:1"))):
+
+  @(name-id-mixin)}
+ @item{An optional list of type variables, as defined for the tagged call
+  expander in
+  @(make-link-element
+         #f
+         (racket <∀-mixin>)
+         `(elem (prefixable "(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+                            "phc-adt/tagged"
+                            "chunk:<∀-mixin>:1:1"))):
+
+  @(∀-mixin)}
+ @item{An optional list of types:
+
+  @(constructor-type-types-mixin)}]
+
+The three elements can appear in any order, with one constraint: the name must
+appear before the first type. Not only does it make more sense semantically,
+but it also avoids ambiguities when some of the types are plain type
+identifiers.
+
+@(name-after-field-error)
+
+@chunk[<constructor-type-args-mixin>
+       (define-eh-alternative-mixin constructor-type-seq-args-mixin
+         #:define-syntax-class constructor-type-seq-args-syntax-class
+         (pattern {~mixin name-id-mixin})
+         (pattern {~mixin types-mixin})
+         (pattern {~mixin ∀-mixin}))]
+
+The type expander handles two cases: when type variables are present, it uses
+the low-level function @racket[tagged-∀-type!], otherwise it uses the low-level
+function @racket[tagged-type!]. The constructor contains a (possibly improper)
+list of values. The type of that list is expressed using the syntax of the
+@racketmodname[xlist] library.
+
+@chunk[<type-expander>
+       (λ/syntax-parse :constructor-type-seq-args-syntax-class
+         (if (attribute tvars?)
+             (tagged-∀-type! #'((tvarᵢ …) name [values (xlist τᵢ … . τ-rest)]))
+             (tagged-type! #'(name [values (xlist τᵢ … . τ-rest)]))))]
+
+@section{Match-expander}
+
+@CHUNK[<match-expander>
+       (syntax-parser
+         [(name:id . pats)
+          (tagged-match! #'(name [values (xlist . pats)]))])]
+
+The match expander simply matches the given patterns against the constructor's
+single field, @racket[values]. The patterns will usually match one value each,
+but the @racket[xlist] pattern expander allows a more flexible syntax than the
+regular @racket[list] match pattern.
+
+@section{Predicate}
+
+The @racket[constructor?] macro expands to a predicate and accepts the same
+syntax as for the type expander, without polymorphic variables. Additionally the
+resulting type as expanded by @racket[xlist] must be a suitable argument to
+@racket[make-predicate].
+
+@CHUNK[<predicate>
+       (λ/syntax-parse (name:id . types)
+         (tagged-predicate! #'(name [values (xList . types)])))]
+
+@section{Instance creation}
+
+The @racket[constructor] macro can return a builder function or an instance. It
+accepts the following syntaxes:
+
+@chunk[#:save-as value-maybe-type <value-maybe-type>
+       (define-syntax-class value-maybe-type
+         (pattern [vᵢ :colon τᵢ:type] #:with aᵢ #'τᵢ #:with (tvarₖ …) #'())
+         (pattern [:colon τᵢ:type vᵢ] #:with aᵢ #'τᵢ #:with (tvarₖ …) #'())
+         (pattern vᵢ:literal-value
+                  #:with τᵢ #'vᵢ.type
+                  #:with aᵢ #'vᵢ.type
+                  #:with (tvarₖ …) #'())
+         (pattern (~and vᵢ (~not #:rest))
+                  #:with τᵢ (gensym 'τ)
+                  #:attr aᵢ #f
+                  #:with (tvarₖ …) #'(τᵢ)))]
+
+@CHUNK[#:save-as literal-value <literal-value>
+       (define-syntax-class literal-value
+         (pattern n:number             #:with type #'n)
+         (pattern s:str                #:with type #'s)
+         (pattern b:boolean            #:with type #'b)
+         (pattern c:char               #:with type #'Char)
+         (pattern ((~literal quote) v) #:with type (replace-chars #'v))
+         (pattern v
+                  #:when (vector? (syntax-e #'v))
+                  #:with type (replace-chars #'v)))]
+
+@chunk[#:save-as replace-chars <replace-chars>
+       ;https://github.com/racket/typed-racket/issues/434
+       (define (replace-chars t)
+         (cond [(syntax? t)  (datum->syntax t
+                                            (replace-chars (syntax-e t))
+                                            t
+                                            t)]
+               [(pair? t)    (list 'Pairof
+                                   (replace-chars (car t))
+                                   (replace-chars (cdr t)))]
+               [(char? t)    'Char]
+               [(vector? t)  (cons 'Vector (map replace-chars
+                                                (vector->list t)))]
+               [(null? t)    'Null]
+               [(number? t)  t]
+               [(string? t)  t]
+               [(boolean? t) t]
+               (code:comment "Hope for the best.")
+               (code:comment "We really should use a ∀ tvar instead.")
+               [else         (list 'quote t)]))]
+               
+@chunk[#:save-as infer-pat <infer-pat>
+       (~after name-order-point <name-after-field-error>
+               {~literal *})]
+
+@CHUNK[#:save-as call-expander-infer-case <call-expander-cases>
+       [(~no-order {~mixin ∀-mixin} {~mixin name-id-mixin} {~once <infer-pat>})
+        #`(… (λ #:∀ (A ...) [l : A ... A]
+               (#,(tagged-builder! #'(… (name [values (List A ... A)])))
+                l)))]]
+
+@chunk[#:save-as colon-pat <colon-pat>
+       (~after name-order-point <name-after-field-error>
+               :colon τᵢ …
+               {~lift-rest {~and τ-rest ()}})]
+
+@CHUNK[#:save-as call-expander-:-case <call-expander-cases>
+       [(~no-order {~mixin ∀-mixin} {~mixin name-id-mixin} {~once <colon-pat>})
+        (define-temp-ids "~a/arg" (τᵢ …))
+        #`(λ #,@(when-attr tvars? #'(#:∀ (tvarᵢ …))) ([τᵢ/arg : τᵢ] …)
+            (#,(tagged-builder! #'(name [values (List τᵢ …)]))
+             (list τᵢ/arg …)))]]
+
+@chunk[#:save-as !-pat <!-pat>
+       (~after name-order-point <name-after-field-error>
+               {~datum !} τᵢ … {~lift-rest τ-rest})]
+
+@CHUNK[#:save-as call-expander-!-case <call-expander-cases>
+       [(~no-order {~mixin ∀-mixin} {~mixin name-id-mixin} {~once <!-pat>})
+        #`(λ [l : Any *]
+            (#,(tagged-builder! #'(name [values (xList τᵢ … . τ-rest)]))
+             (cast l (xlist τᵢ … . τ-rest))))]]
+
+@chunk[#:save-as dcolon-pat <dcolon-pat>
+       (~after name-order-point <name-after-field-error>
+               {~datum ::} τᵢ … {~lift-rest τ-rest})]
+
+@CHUNK[#:save-as call-expander-::-case <call-expander-cases>
+       [(~no-order {~mixin ∀-mixin} {~mixin name-id-mixin} {~once <dcolon-pat>})
+        (if (attribute tvars?)
+            (tagged-builder!   #'(name
+                                  [values (xlist τᵢ … . τ-rest)]))
+            (tagged-∀-builder! #'((tvarᵢ …)
+                                  name
+                                  [values (xList τᵢ … . τ-rest)])))]]
+
+@CHUNK[#:save-as call-expander-values-case <call-expander-cases>
+       [(~no-order {~mixin ∀-mixin}
+                   {~mixin name-id-mixin}
+                   (~maybe/empty
+                    (~after name-order-point <name-after-field-error>
+                            :value-maybe-type …
+                            <call-expander-rest>)))
+        (define-temp-ids "~a/arg" (τᵢ …))
+        (quasitemplate
+         (#,(tagged-∀-builder! #'((tvarᵢ … tvarₖ … … tvar-rest …)
+                                  name
+                                  [values (xlist τᵢ … #:rest x-τ-rest)]))
+          (list* {?? (ann vᵢ aᵢ) vᵢ}
+                 …
+                 {?? (ann v-rest a-rest) v-rest})))]]
+
+@CHUNK[#:save-as call-expander-rest <call-expander-rest>
+       (~either <call-expander-rest-keyword>
+                <call-expander-empty-rest>
+                <call-expander-dotted-rest>)]
+
+@(define comment1 "pattern for the value, infers type for literals")
+@(define-for-syntax comment1 "pattern for the value, infers type for literals")
+@chunk[#:save-as call-expander-rest-keyword <call-expander-rest-keyword>
+       (~as-rest #:rest
+                 (code:comment #,comment1)
+                 (~either (~and v-rest:literal-value
+                                {~with a-rest #'v-rest.type})
+                          (~and v-rest
+                                {~attr a-rest #f}))
+                 (~either (~and {~seq}
+                                {~with x-τ-rest      (gensym 'x-τ-rest)}
+                                {~with (tvar-rest …) #'(x-τ-rest)})
+                          (~and (~seq :colon x-τ-rest)
+                                {~with (tvar-rest …) #'()})))]
+
+@CHUNK[#:save-as call-expander-empty-rest <call-expander-empty-rest>
+       (~seq
+        (~lift-rest
+         (~and ()
+               {~with v-rest        #'null}
+               {~with a-rest        #'Null}
+               {~with x-τ-rest      #'Null}
+               {~with (tvar-rest …) #'()})))]
+
+@CHUNK[#:save-as call-expander-dotted-rest <call-expander-dotted-rest>
+       (~seq
+        (~lift-rest
+         (~either (~and v-rest:type-label
+                        (~with x-τ-rest      #'v-rest.type)
+                        {~with a-rest        #'v-rest.type}
+                        (~with (tvar-rest …) #'()))
+                  (~and v-rest:literal-value
+                        (~with x-τ-rest      #'v-rest.type)
+                        {~with a-rest        #'v-rest.type}
+                        (~with (tvar-rest …) #'()))
+                  (~and v-rest
+                        (~with x-τ-rest      (gensym 'x-τ-rest))
+                        {~attr a-rest        #f}
+                        (~with (tvar-rest …) #'(x-τ-rest))))))]
+
+@CHUNK[#:save-as type-label-syntax-class <type-label-syntax-class>
+       (define-syntax-class type-label
+         #:attributes (type raw-type)
+         (pattern v
+                  #:attr raw-type (syntax-property #'v-rest 'type-label)
+                  #:when (attribute raw-type)
+                  #:attr type     (datum->syntax #'v-rest
+                                                 (attribute raw-type)
+                                                 #'v-rest)))]
+
+@itemlist[
+ @item{@racket[(constructor name *)], which returns a polymorphic builder
+  function that infers the type of its arguments. All arguments are aggregated
+  into a list with the inferred type for each element, and that list is used as
+  the constructor's value.
+
+  @(infer-pat)
+  
+  @(call-expander-infer-case)}
+ @item{@racket[(constructor : τᵢ …)], which returns a builder function. This
+  does not support the extended @racket[xlist] syntax, as Typed/Racket's
+  function types are not expressive enough to support it.
+
+  @(colon-pat)
+  
+  @(call-expander-:-case)}
+ @item{@racket[(constructor ! . _xlist-type)], which returns a builder function
+  expecting the values as a rest argument, and casts the list at runtime. The
+  @racket[_xlist-type] must be a valid sequence of types for the type form of
+  @racket[xlist], and the result must be a suitable argument to
+  @racket[make-predicate].
+
+  @(!-pat)
+  
+  @(call-expander-!-case)}
+ @item{@racket[(constructor :: . _xlist-type)], which returns a builder function
+  expecting the whole list of values as a single argument, and returns the
+  constructor instance containing that list. The @racket[_xlist-type] must be a
+  valid sequence of types for the type form of @racket[xlist].
+
+  @(dcolon-pat)
+
+  @(call-expander-::-case)}
+ @item{@racket[(constructor _value-maybe-typeᵢ … . rest)], which returns an
+  instance containing a (possibly improper) list with the given values and
+  @racket[rest] as the tail of the list. If @racket[rest] is @racket[()], then
+  the result is a proper list.
+  
+  @;@(constructor-value-mixin)
+  @(call-expander-values-case)
+  
+  Each @racket[_value-maybe-typeᵢ] may be one of:
+  @itemlist[
+ @item{@racket[[valᵢ : τᵢ]]}
+ @item{@racket[[: τᵢ valᵢ]]}
+ @item{@racket[valᵢ]}]
+
+  @(value-maybe-type)
+
+  Literals are specially recognised so that their type is preserved with as much
+  precision as possible:
+
+  @(literal-value)
+
+  As noted in Typed/Racket bug
+  @hyperlink["https://github.com/racket/typed-racket/issues/434"]{#434}, literal
+  characters are not currently recognised as belonging to their own singleton
+  type. We therefore rewrite the type for quoted data to turn literal characters
+  into the @racket[Char] type:
+
+  @(replace-chars)
+
+  Optionally, a rest element may be specified using the following syntax:
+  @(call-expander-rest)
+
+  @(call-expander-rest-keyword)
+  @(call-expander-empty-rest)
+  @(call-expander-dotted-rest)
+
+  The last case depends on the @racket[type-label?] syntax class to recognise
+  uses of the @elem[#:style 'tt "#{val : type}"] type annotation syntax from
+  @racketmodname[typed/racket]. Typed/Racket enables that reader extension,
+  which embeds the type into the value as a syntax property for later use by the
+  type checker
+
+  @(type-label-syntax-class)}]
+
+All four forms accept a @racket[#:∀ (tvarᵢ …)] specification, and the fourth
+injects a @racket[tvarᵢ] type variable for values for which no type is given.
+
+@CHUNK[<call-expander>
+       (syntax-parser
+         <call-expander-cases>)]
+
+@section{Defining shorthands for constructors with @racket[define-constructor]}
+
+The @racket[define-constructor] macro binds an identifier to a type-expander,
+match-expander and call-expander for the constructor with the same name. It
+also defines a predicate for that constructor type.
+
+@;; Copied over from tagged.hl.rkt without any change.
+
+@chunk[#:save-as tag-kw-mixin <tag-kw-mixin>
+       (define-eh-alternative-mixin tag-kw-mixin
+         (pattern {~optional {~seq #:tag explicit-tag <default-tag-name>}}))]
+
+@chunk[#:save-as tag-kw-mixin-default <default-tag-name>
+       {~post-check
+        {~bind [tag-name (or (attribute explicit-tag)
+                             #'name)]}}]
+
+@chunk[#:save-as predicate?-mixin <predicate?-mixin>
+       (define-eh-alternative-mixin predicate?-mixin
+         (pattern {~optional {~seq #:? predicate? <default-name?>}}))]
+
+@chunk[#:save-as predicate?-mixin-default <default-name?>
+       {~post-check
+        {~bind [name? (or (attribute predicate?)
+                          (format-id/record #'name "~a?" #'name))]}}]
+
+Like @tc[define-tagged], the @tc[constructor] macro expects:
+
+@itemlist[
+ @item{The tagged structure's tag name, as defined for the call expander in
+  @racket[<name-id-mixin>]}
+ @item{An optional list of type variables, as defined for the call expander in
+  @racket[<∀-mixin>]}
+ @item{Optionally, the tag name to be used, specified with
+  @racket[#:tag tag-name] as for @racket[define-tagged] in
+  @secref["Defining_shorthands_with_define-tagged"
+          #:tag-prefixes '("phc-adt/tagged")]:
+
+  @(tag-kw-mixin)
+
+  The tag name defaults to @racket[_name], i.e. the identifier currently being
+  defined.
+
+  @(tag-kw-mixin-default)}
+ @item{Optionally, a name for the predicate, specified with
+  @racket[#:? predicate-name?] as for @racket[define-tagged] in
+  @secref["Defining_shorthands_with_define-tagged"
+          #:tag-prefixes '("phc-adt/tagged")]:
+  
+  @(predicate?-mixin)
+
+  The predicate name defaults to @racket[_name?], where @racket[_name] is the
+  identifier currently being defined.
+
+  @(predicate?-mixin-default)}]
+
+Unlike @tc[define-tagged], which also expects a list of field names possibly
+annotated with a type, the @tc[constructor] macro instead expects a
+description of the list of values it contains. Three syntaxes are accepted:
+
+@itemlist[
+ @item{@(colon-pat)}
+ @item{@(!-pat)}
+ @item{@(dcolon-pat)}]
+
+These syntaxes control how the call expander for the defined @racket[_name]
+works, and have the same meaning as in the call expander for
+@racket[constructor] (@racket[xlist], @racket[cast] and single-argument
+@racket[xlist]).
+ 
+@chunk[<define-constructor>
+       (define-syntax define-constructor
+         (syntax-parser-with-arrows
+          [(_ . (~no-order {~mixin name-id-mixin}
+                           {~mixin ∀-mixin}
+                           {~mixin tag-kw-mixin}
+                           {~mixin predicate?-mixin}
+                           (~once
+                            (~and (~seq type-decls …)
+                                  (~either <colon-pat>
+                                           <!-pat>
+                                           <dcolon-pat>)))))
+           #:with tvarᵢ→Any (stx-map (const #'Any) #'(tvarᵢ …))
+           <normalize-type/define>
+           (quasisyntax/top-loc stx
+             (begin
+               <multi-id/define>
+               <predicate/define>))]))]
+
+@chunk[<multi-id/define>
+       (define-multi-id name
+         #:type-expander  (make-id+call-transformer <type-expander/define>)
+         #:match-expander (make-rest-transformer    <match-expander/define>)
+         #:else                                     <call-expander/define>)]
+
+@; exact copy-paste from the type expander: TODO: factor it out.
+@CHUNK[<type-expander/define> 
+       #'(constructor tag-name
+                      #,@(when-attr tvars? #'(#:∀ (tvarᵢ …)))
+                      τᵢ … . τ-rest)]
+
+@CHUNK[<call-expander/define>
+       #'(constructor tag-name
+                      #,@(when-attr tvars? #'(#:∀ (tvarᵢ …)))
+                      type-decls …)]
+
+In order to attach patterns to the @racket[xlist] type, pre-process the types
+using @racket[normalize-xlist-type].
+
+@chunk[<normalize-type/define>
+       #:with <with-normalize> (normalize-xlist-type #'(τᵢ … . τ-rest) stx)]
+
+Once normalized, the types for the @racket[xlist] are all of the form
+@racket[τᵢ ^ {repeat …}], except for the rest type, which is always present
+including when it is @racket[Null], and is specified using
+@racket[#:rest rest-type].
+
+@chunk[<with-normalize>
+       ({~seq normalized-τᵢ {~literal ^} (normalized-repeat …)} …
+        #:rest normalized-rest)]
+
+We then define an argument for the pattern expander corresponding to each type
+within the normalized sequence:
+
+@chunk[<normalize-type/define>
+       (define-temp-ids "~a/pat" (normalized-τᵢ …))]
+
+The match expander expects these patterns and a rest pattern:
+
+@CHUNK[<match-expander/define>
+       (syntax-parser
+         [({~var normalized-τᵢ/pat} … . {~either <match-rest-signature/define>})
+          #'#,(tagged-match! #'(name [values <match-xlist/define>]))])]
+
+The rest pattern can be specified either using a dotted notation if it is a
+single term, using @racket[#:rest pat-rest], or can be omitted in which case
+it defaults to matching @racket[null]. The following syntaxes are therefore
+accepted:
+
+@chunk[<match-rest-signature/define>
+       (#:rest pat-rest)
+       (~and () {~bind [pat-rest #'(? null?)]})
+       pat-rest:not-stx-pair]
+
+The match expander produces an @racket[xlist] pattern using the given patterns
+and the optional rest pattern. The given patterns are repeated as within the
+type specification.
+
+@chunk[<match-xlist/define>
+       (and (? (make-predicate (xlist τᵢ … . τ-rest)))
+            (split-xlist (list normalized-τᵢ/pat … pat-rest)
+                         τᵢ … . τ-rest))]
+
+@CHUNK[<predicate/define>
+       (define name? 
+         #,(if (attribute tvars?)
+               (tagged-predicate!
+                #'(tag-name [values ((xlist τᵢ … . τ-rest) tvarᵢ→Any)]))
+               (tagged-predicate!
+                #'(tag-name [values (xlist τᵢ … . τ-rest)]))))]
+
+@; TODO: add a #:predicate-type option.
+
+@section{Miscellanea}
+
+@chunk[<constructor-values>
+       (define-syntax constructor-values
+         (make-id+call-transformer-delayed
+          (λ () #'(λ-tagged-get-field values))))]
+
+@CHUNK[<ConstructorTop?>
+       (define-syntax ConstructorTop?
+         (make-id+call-transformer-delayed
+          (λ ()
+            #`(struct-predicate
+               #,(check-remembered-common!
+                  #'(always-remembered values))))))]
+
+@CHUNK[<ConstructorTop>
+       (define-type-expander (ConstructorTop stx)
+         (syntax-case stx ()
+           [id
+            (identifier? #'id)
+            #'((check-remembered-common!
+                #'(always-remembered values))
+               Any)]))]
+
+@section{Putting it all together}
+
+@chunk[<*>
+       (require phc-toolkit
+                "tagged.hl.rkt"
+                "tagged-structure-low-level.hl.rkt"
+                (only-in match-string [append match-append])
+                type-expander
+                xlist
+                multi-id
+                (for-syntax racket/base
+                            syntax/parse
+                            syntax/parse/experimental/template
+                            racket/contract
+                            racket/syntax
+                            racket/string
+                            racket/function
+                            racket/list
+                            type-expander/expander
+                            phc-toolkit/untyped
+                            extensible-parser-specifications))
+
+       (provide constructor-values
+                constructor
+                constructor?
+                ConstructorTop
+                ConstructorTop?
+                define-constructor
+                (for-syntax constructor-type-seq-args-syntax-class))
+
+       (begin-for-syntax
+         (define-syntax-class not-stx-pair
+           (pattern {~not (_ . _)}))
+         <type-label-syntax-class>
+         <name-id-mixin>
+         <∀-mixin>
+         <constructor-type-types-mixin>
+         <constructor-type-args-mixin>
+         <tag-kw-mixin>
+         <predicate?-mixin>
+         <replace-chars>
+         <literal-value>
+         <value-maybe-type>)
+       
+       <constructor>
+       <constructor?>
+       <ConstructorTop>
+       <ConstructorTop?>
+       <define-constructor>
+       <constructor-values>]

phc-adt-lib/phc-adt/ctx.hl.rkt

@@ -0,0 +1,137 @@
+#lang hyper-literate typed/racket/base #:no-require-lang
+@(require scribble-enhanced/doc
+          racket/require
+          hyper-literate
+          (for-label racket/format
+                     racket/list
+                     (subtract-in racket/contract typed/racket/base)
+                     phc-toolkit
+                     phc-toolkit/untyped-only
+                     remember
+                     (subtract-in typed/racket/base type-expander)
+                     type-expander))
+@doc-lib-setup
+
+@title[#:style manual-doc-style
+       #:tag "ctx"
+       #:tag-prefix "phc-adt/ctx"
+       ]{Implementation of ADTs: syntax scopes}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/ctx"))
+
+
+Due to TR bug #399, structs declared by a macro do not work
+if the macro itself is declared in a separate module. This
+seems to be due to the extra scope added as pieces of syntax
+cross the module boundary. There is unfortunately no
+equivalent to @racket[syntax-local-introduce] that could be
+used to flip this module scope.
+
+We therefore require the user to call 
+@racket[(set-adt-context)] at the beginning of the file.
+This macro stores the scopes present where it was called in
+a mutable for-syntax variable:
+
+@chunk[<adt-context>
+       (define-for-syntax mutable-adt-context (box #f))]
+
+These scopes are later used as the context for struct
+identifiers:
+
+@chunk[<ctx-introduce>
+       (define-for-syntax (ctx-introduce id)
+         (unless (unbox mutable-adt-context)
+           (raise-syntax-error 'adt
+                               (~a "(adt-init) must be called in the"
+                                   " file (or REPL). ") id))
+         (struct-identifier-fresh-introducer
+          (replace-context (syntax-local-introduce
+                            (unbox mutable-adt-context))
+                           id)))]
+
+The @racket[(set-adt-context)] macro should be called at
+the beginning of the file or typed in the REPL before using
+structures. It simply stores the syntax used to call it in 
+@racket[mutable-adt-context].
+
+@chunk[<adt-context>
+       (define-for-syntax (set-adt-context ctx)
+         (set-box! mutable-adt-context ctx))
+
+       (define-syntax (set-adt-context-macro stx)
+         (syntax-case stx ()
+           [(_ ctx)
+            (begin (set-box! mutable-adt-context #'ctx)
+                   #'(void))]))]
+
+For debugging purposes, we provide a macro and a for-syntax
+function which show the current ADT context (i.e. the list of
+scopes).
+
+@chunk[<adt-context>
+       (define-for-syntax (debug-show-adt-context)
+         (displayln
+          (hash-ref (syntax-debug-info (unbox mutable-adt-context))
+                    'context)))
+       (define-syntax (debug-show-adt-context-macro stx)
+         (debug-show-adt-context)
+         #'(define dummy (void)))]
+
+The @tc[struct] identifiers are introduced in a fresh scope
+@note{Due to TR bug #399, this feature is temporarily
+ disabled, until the bug is fixed.}, so that they do not
+conflict with any other user value.
+
+@chunk[<fresh-introducer>
+       (define-for-syntax struct-identifier-fresh-introducer
+         (λ (x) x) #;(make-syntax-introducer))]
+
+We provide two ways of checking whether @racket[set-adt-context] was called:
+@racket[(adt-context?)] returns a boolean, while @racket[(check-adt-context)]
+raises an error when @racket[set-adt-context] has not been called.
+
+@chunk[<adt-context?>
+       (define-for-syntax (adt-context?)
+         (true? (unbox mutable-adt-context)))]
+
+@chunk[<check-adt-context>
+       (define-for-syntax (check-adt-context)
+         (unless (adt-context?)
+           (raise-syntax-error 'phc-adt
+                               (string-append
+                                "adt-init must be called before"
+                                " using the features in phc-adt"))))]
+
+@section{Putting it all together}
+
+@chunk[<*>
+       (begin
+         (require (for-syntax racket/base
+                              racket/syntax
+                              racket/set
+                              racket/list
+                              racket/format
+                              phc-toolkit/untyped
+                              syntax/strip-context)
+                  racket/require-syntax
+                  type-expander
+                  phc-toolkit
+                  remember))
+
+       (provide (for-syntax set-adt-context)
+                set-adt-context-macro
+                debug-show-adt-context-macro)
+
+       (begin-for-syntax
+         (provide debug-show-adt-context
+                  adt-context?
+                  check-adt-context
+                  ctx-introduce))
+       
+       <adt-context>
+       <fresh-introducer>
+       <ctx-introduce>
+       <adt-context?>
+       <check-adt-context>]

phc-adt-lib/phc-adt/declarations.rkt

@@ -0,0 +1,14 @@
+#lang racket
+
+(require (prefix-in tr: typed/racket)
+         remember
+         (submod "tagged-structure-low-level.hl.rkt" pre-declare)
+         "ctx.hl.rkt")
+(provide remembered!
+         (rename-out [new-#%module-begin #%module-begin]))
+
+(define-syntax-rule (new-#%module-begin . body)
+  (tr:#%module-begin
+   (tr:begin . body)
+   (set-adt-context-macro here)
+   (pre-declare-all-tagged-structure-structs)))

phc-adt-lib/phc-adt/main.rkt

@@ -0,0 +1,3 @@
+#lang typed/racket
+(require "adt.hl.rkt")
+(provide (all-from-out "adt.hl.rkt"))

phc-adt-lib/phc-adt/node-low-level.hl.rkt

@@ -0,0 +1,413 @@
+#lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require
+@(require scribble-enhanced/doc
+          racket/require
+          hyper-literate
+          (for-label racket/format
+                     racket/promise
+                     racket/list
+                     type-expander
+                     (except-in (subtract-in typed/racket/base type-expander)
+                                values)
+                     (only-in racket/base values)
+                     (subtract-in racket/contract typed/racket/base)
+                     phc-toolkit
+                     phc-toolkit/untyped-only
+                     remember))
+@(unless-preexpanding
+  (require (for-label (submod ".."))))
+@doc-lib-setup
+
+@title[#:style manual-doc-style
+       #:tag "node-low-level"
+       #:tag-prefix "phc-adt/node-low-level"
+       ]{Implementation of nodes: printing and equality}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/node-low-level"))
+
+This section discusses the implementation of @tc[prop:custom-write] and
+@tc[prop:equal+hash] for nodes.
+
+@(table-of-contents)
+
+@section{Printing nodes}
+
+To avoid printing large and confusing swathes of data when a node is displayed,
+we only print its constituents up to a certain depth. The
+@tech[#:doc '(lib "scribblings/guide/guide.scrbl")]{parameter}
+@tc[write-node-depth] controls the depth for printing nested nodes.
+
+@CHUNK[<write-node-depth>
+       (define write-node-depth (make-parameter 1))]
+
+The @tc[make-node-writer] macro expands to a procedure which prints a node with
+the given name and fields. If the @racket[write-node-depth] is @racket[0], then
+the contents of the node are elided, and only its name is printed, so that the
+resulting printed representation is @racket["(node name …)"] with an actual
+ellipsis character.
+
+@CHUNK[<node-custom-write>
+       (define-syntax/parse (make-node-writer pid name fieldᵢ …)
+         #'(λ (self out mode)
+             (if (> (write-node-depth) 0)
+                 (parameterize ([write-node-depth (sub1 (write-node-depth))])
+                   (fprintf out
+                            "(node ~a ~a)"
+                            'name
+                            (string-join (list <format-field> …) " ")))
+                 (fprintf out "(node ~a …)" 'name))))]
+
+Each field is formatted as @tc[[fieldᵢ valueᵢ]]. Copy-pasting the whole printed
+form will not form a valid expression which would be @tc[equal?] to the
+original. This limitation is deliberate: a node will often refer to many other
+nodes, and a stand-alone representation of such a node would result in a very
+large printed form. Instead, the user should call the @tc[serialize-graph]
+macro, which will produce a complete, canonical @note{The representation is
+ canonical so long as unordered sets or hash tables are not used as part of the
+ node's contents. In that case, the printed form is canonical modulo the order
+ of elements within the set or hash table. Once executed, it will nevertheless
+ produce a node which is @racket[equal?] to the original.} and self-contained
+representation of the node.
+
+@chunk[<format-field>
+       (format "[~a ~a]" 'fieldᵢ (force ((struct-accessor pid fieldᵢ) self)))]
+
+@section{Comparing and hashing nodes}
+
+Nodes are represented like tagged structures, but contain an extra @tc[raw]
+field. The @tc[raw] field contains a low-level representation of the node, which
+is used to implement node equality. The low-level representation uses the
+@tc[raw-node] Racket @racket[struct]. It contains two fields, @tc[database] and
+@tc[index]. The first is the database of nodes, as created by the graph
+construction macro. It contains one vector of nodes per node type. The second is
+a logical pointer into that database, consisting of the node's type's name,
+represented as a symbol, and an offset within the corresponding vector,
+represented as an @tc[Index].
+
+@chunk[<raw-node>
+       (struct/props (D I) raw-node ([database : D] [index : I]) #:transparent
+                     <raw-node-equality>)]
+
+A regular with-promises node can have several in-memory representations which
+are not pointer-equal. This is due to the fact that the contents of node fields
+are wrapped with promises, and accessing the node via two distinct paths will
+yield two copies, each with fresh promises. We therefore use the @tc[raw-node]
+as a proxy for pointer equality: we know for sure that two nodes are exactly the
+same if the @tc[database] and @tc[index] is the same for both nodes.
+
+@chunk[<raw-node-equality>
+       #:property prop:equal+hash
+       (list (λ (a b r)
+               (and (raw-node? a)
+                    (raw-node? b)
+                    (eq? (raw-node-database a) (raw-node-database b))
+                    (equal? (raw-node-index a) (raw-node-index b))))
+             (λ (a r)
+               (fxxor (eq-hash-code (raw-node-database a))
+                      (r (raw-node-index a))))
+             (λ (a r)
+               (fxxor (eq-hash-code (raw-node-database a))
+                      (r (raw-node-index a)))))]
+
+The following function can then be used to test if two nodes are the same, based
+on the contents of their @tc[raw] field:
+
+@chunk[<same-node?>
+       (define (same-node? a b)
+         (and ((struct-predicate node-id) a)
+              ((struct-predicate node-id) b)
+              (equal? ((struct-accessor node-id raw) a)
+                      ((struct-accessor node-id raw) b))))]
+
+To detect cycles within the graph while implementing node equality, we use a
+global hash table tracking which nodes have already been visited.
+
+@chunk[<seen-hash-table>
+       (define seen-nodes
+         : (Parameterof (U #f (HashTable (raw-node Any Any) Any)))
+         (make-parameter #f))]
+
+The current implementation uses a mutable hash table. It is only initialised
+when @tc[equal?] starts comparing two nodes, so that references to nodes are not
+kept once @tc[equal?] finished running. However, in theory, an immutable hash
+table could be threaded through all the recursive calls to @tc[equal?].
+Unfortunately, the recursive equality function supplied by Racket when
+implementing @tc[prop:equal+hash] does not accept an extra parameter to thread
+state throughout the recursion. It would therefore be necessary to re-implement
+the algorithm used by Racket's @tc[equal?] as described by
+@cite[adams2008scheme-equality] tailored to the comparison of data structures
+with high-level logical cycles. To be correct, such a re-implementation would
+however need to access the @tc[prop:equal+hash] property of other structs, but
+Racket provides no public predicate or accessor for that property. Therefore,
+although it would, in theory, be possible to implement node equality without
+mutable state, Racket's library does not offer the primitives needed to build
+it. We therefore settle on using a global, mutable hash table, which will exist
+only during the execution of @tc[equal?].
+
+@chunk[<node-equal+hash>
+       (define-syntax/parse
+           (make-node-comparer common-id node-id name fieldᵢ …)
+         (define-temp-ids "~a/τ" (fieldᵢ …))
+         #'(let ()
+             <same-node?>
+             <find-in-table>
+             <node-hash>
+             (list <node-equal?>
+                   <node-equal-hash-code>
+                   <node-equal-secondary-hash-code>)))]
+
+@subsection{Hashing nodes}
+
+@tc[equal-hash-code] and @tc[equal-secondary-hash-code] are implemented via
+a single function @tc[node-hash], the only difference being the function used to
+recursively compute the hash of sub-elements.
+
+@chunk[<node-equal-hash-code>
+       (λ (a rec-equal-hash-code)
+         (node-hash a rec-equal-hash-code))]
+
+@chunk[<node-equal-secondary-hash-code>
+       (λ (a rec-equal-secondary-hash-code)
+         (node-hash a rec-equal-secondary-hash-code))]
+
+It would be desirable to implement hashing in the following way: if the current
+node is already present in a hash table of seen nodes, but is not @tc[eq?] to
+that copy, then the racket hash function is called on the already-seen node.
+Otherwise, if the node has never been seen, or if it is @tc[eq?] to the seen
+node, the hash code is computed.
+
+The problem with this approach is that it introduces an intermediate recursive
+call to Racket's hashing function. When Racket's hashing function is applied to
+a structure with the @tc[prop:equal+hash] property, it does @emph{not}
+return the result of the struct's hash implementation unmodified.
+
+For example, the code below implements a struct @tc[s] with no fields, which
+computes its hash code by recursively calling Racket's hashing function on other
+(unique) instances of @tc[s], and returns the constant @tc[1] at a certain
+depth. The custom hashing function does not alter in any way the result returned
+by Racket's hashing function, however we can see that the hash for the same
+instance of @tc[s] depends on the number of recursive calls to Racket's hashing
+function @tc[r]. This simple experiment seems to suggest that Racket adds
+@tc[50] at each step, but this is not something that can be relied upon.
+
+@(require scribble/eval)
+@defs+int[
+ {(define recursion-depth (make-parameter #f))
+  (struct s (x) #:transparent
+    #:property prop:equal+hash
+    (list (λ (a b r) (error "Not implemented"))
+          (λ (a r)
+            (if (= 0 (recursion-depth))
+                1
+                (parameterize ([recursion-depth (sub1 (recursion-depth))])
+                  (r (s (gensym))))))
+          (λ (a r) (error "Not implemented"))))
+  (define s-instance (s 'x))}
+ (parameterize ([recursion-depth 0])
+   (equal-hash-code s-instance))
+ (parameterize ([recursion-depth 1])
+   (equal-hash-code s-instance))
+ (parameterize ([recursion-depth 2])
+   (equal-hash-code s-instance))]
+
+Since the order of traversal of the nodes is not fixed in the presence of sets
+and hash tables, we need to make sure that the recursion depth at which a node's
+hash is computed is constant. We achieve this by @emph{always} calling Racket's
+hash function on the already-seen node from the hash table, even if was inserted
+just now. To distinguish between the current node and the already-seen node from
+the hash table, we remove the contents of the node's @tc[raw] field, and replace
+them with a special marker.
+
+@chunk[<node-hash>
+       (: node-hash (∀ (fieldᵢ/τ …)
+                       (→ (node-id fieldᵢ/τ … Any Any) (→ Any Fixnum) Fixnum)))
+       (define (node-hash nd racket-recur-hash)
+         (if (eq? (raw-node-database ((struct-accessor node-id raw) nd))
+                  'unique-copy)
+             <compute-hash>
+             <hash-init-table-and-recur>))]
+
+When the node's @tc[raw] field does not indicate @tc['unique-copy], we first
+initialise the hash table if needed, then recursively call
+@tc[racket-recur-hash] on the unique copy of the node:
+
+@chunk[<hash-init-table-and-recur>
+       (let ([seen-table (or (seen-nodes)
+                             ((inst make-hash (raw-node Any Any) Any)))])
+         (parameterize ([seen-nodes seen-table])
+           (racket-recur-hash (find-in-table seen-table nd))))]
+
+To obtain the unique copy of the node, we look it up in the hash table, creating
+it and adding it to the hash table if the current node is not already present
+there:
+
+@chunk[<find-in-table>
+       (: find-in-table (∀ (fieldᵢ/τ …)
+                           (→ (HashTable (raw-node Any Any) Any)
+                              (node-id fieldᵢ/τ … Any Any)
+                              Any)))
+       (define (find-in-table seen-table nd)
+         (hash-ref! seen-table
+                    ((struct-accessor node-id raw) nd)
+                    (λ () <make-unique-copy-node>)))]
+
+To create a unique copy of the node, we create a new instance of the node's
+struct, and copy over all the fields except for the @tc[raw] field, whose value
+becomes @tc['unique-copy].
+
+@chunk[<make-unique-copy-node>
+       ((struct-constructor node-id) ((struct-accessor common-id fieldᵢ) nd)
+                                     …
+                                     (raw-node 'unique-copy 'unique-copy))]
+
+The hash code is finally computed by combining the hash code for each field's
+contents (after forcing it). The node's tag name is also hashed, and added to
+the mix.
+
+@chunk[<compute-hash>
+       (combine-hash-codes
+        (racket-recur-hash 'name)
+        (racket-recur-hash (force ((struct-accessor common-id fieldᵢ) nd)))
+        …)]
+
+To combine hash codes, we simply compute their @elem[#:style 'tt]{xor}. Later
+versions of this library may use more sophisticated mechanisms.
+
+@chunk[<combine-hash-codes>
+       (: combine-hash-codes (→ Fixnum * Fixnum))
+       (define (combine-hash-codes . fixnums)
+         (apply fxxor fixnums))]
+
+@subsection{Caching node equality}
+
+We provide a mechanism at run-time to cache the result of equality tests
+within a limited dynamic scope. The graph generation procedure can coalesce
+nodes which are @racket[equal?], which means that it needs to perform a
+significant number of equality comparisons, and can therefore benefit from
+caching the result of inner equality tests during the execution of the
+coalescing operation.
+
+@chunk[<equality-cache>
+       (define equality-cache
+         : (Parameterof (U #f (HashTable (Pairof (raw-node Any Any)
+                                                 (raw-node Any Any))
+                                         Boolean)))
+         (make-parameter #f))]
+
+The @racket[with-node-equality-cache] form executes its body while enabling
+caching of the result of direct and recursive calls to @racket[equal?] on
+nodes.
+
+@chunk[<with-node-equality-cache>
+       (define-syntax-rule (with-node-equality-cache . body)
+         (parameterize ([equality-cache (or (equality-cache)
+                                            <make-equality-cache>)])
+           . body))]
+
+If necessary, a new equality cache is created, unless
+@racket[with-node-equality-cache] is used within the dynamic extent of another
+use of itself.
+
+@chunk[<make-equality-cache>
+       ((inst make-hash (Pairof (raw-node Any Any) (raw-node Any Any)) Any))]
+
+When comparing two nodes, we first check whether an equality cache is
+installed. If so, we attempt to query the cache, and memoize the result of the
+comparison when the pair of values is not already in the cache.
+
+@chunk[<memoize-equality>
+       (λ (result-thunk)
+         (let ([e-cache (equality-cache)])
+           (if e-cache
+               (cond
+                 [(hash-has-key? e-cache (cons a-raw b-raw))
+                  (hash-ref e-cache (cons a-raw b-raw))]
+                 [(hash-has-key? e-cache (cons b-raw a-raw))
+                  (hash-ref e-cache (cons b-raw a-raw))]
+                 [else
+                  (let ([result (result-thunk)])
+                    (hash-set! e-cache (cons a-raw b-raw) result)
+                    result)])
+               (result-thunk))))]
+
+@subsection{Comparing nodes for equality}
+
+We implement equality following the same architecture as for hash codes, but
+check that both nodes are already unique copies. In addition, the implementation
+of @tc[equal?] checks that both values are of the node's type.
+
+@chunk[<node-equal?>
+       (λ (a b racket-recur-equal?)
+         (and ((struct-predicate node-id) a)
+              ((struct-predicate node-id) b)
+              (let ([a-raw ((struct-accessor node-id raw) a)]
+                    [b-raw ((struct-accessor node-id raw) b)])
+                (if (and (eq? (raw-node-database a-raw) 'unique-copy)
+                         (eq? (raw-node-database b-raw) 'unique-copy))
+                    <compare>
+                    (or (same-node? a b)
+                        (<memoize-equality>
+                         (λ () <equality-init-table-and-recur>)))))))]
+
+When either or both of the node's @tc[raw] field do not indicate
+@tc['unique-copy], we first initialise the hash table if needed, then
+recursively call @tc[racket-recur-hash] on the unique copy of each node:
+
+@chunk[<equality-init-table-and-recur>
+       (let ([seen-table (or (seen-nodes)
+                             ((inst make-hash (raw-node Any Any) Any)))])
+         (parameterize ([seen-nodes seen-table])
+           (racket-recur-equal? (find-in-table seen-table a)
+                                (find-in-table seen-table b))))]
+
+The nodes are compared pointwise, checking each pair of fields for equality,
+after forcing both:
+
+@chunk[<compare>
+       (and (racket-recur-equal? (force ((struct-accessor common-id fieldᵢ) a))
+                                 (force ((struct-accessor common-id fieldᵢ) b)))
+            …)]
+
+@chunk[<*>
+       (require racket/promise
+                racket/string
+                racket/require
+                phc-toolkit
+                remember
+                typed-struct-props
+                (for-syntax racket/base
+                            racket/syntax
+                            racket/list
+                            racket/set
+                            racket/format
+                            (subtract-in syntax/stx phc-toolkit/untyped)
+                            syntax/parse
+                            phc-toolkit/untyped))
+       
+       (provide make-node-comparer
+                make-node-writer
+                raw-node
+                write-node-depth
+                with-node-equality-cache)
+
+       <equality-cache>
+       <with-node-equality-cache>
+       <seen-hash-table>
+       <write-node-depth>
+       <node-custom-write>
+       <raw-node>
+       <combine-hash-codes>
+       <node-equal+hash>]
+
+@define[adams2008scheme-equality
+        (string-append "Efficient nondestructive equality checking for trees"
+                       " and graphs, Adams and Dybvig, 2008")]
+@bibliography[
+ @bib-entry[#:key adams2008scheme-equality
+            #:title @list{Efficient nondestructive equality checking for trees
+              and graphs in @emph{ACM Sigplan Notices} (Vol. 43, No. 9)
+              pp. 179–188}
+            #:date "2008"
+            #:author "Michael D. Adams and R. Kent Dybvig"
+            #:url "http://www.cs.indiana.edu/~dyb/pubs/equal.pdf"]]

phc-adt-lib/phc-adt/structure.hl.rkt

@@ -0,0 +1,124 @@
+#lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require
+@(require racket/require
+          scribble-math
+          scribble-enhanced/doc
+          (for-label phc-toolkit
+                     (lib "phc-adt/tagged.hl.rkt")
+                     multi-id
+                     racket/base
+                     phc-toolkit/untyped-only))
+@doc-lib-setup
+
+@(unless-preexpanding
+  (require (for-label (submod ".."))))
+
+@title[#:style (with-html5 manual-doc-style)
+       #:tag "structure"
+       #:tag-prefix "phc-adt/structure"
+       ]{User API for untagged structures}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/structure"))
+
+@(table-of-contents)
+
+@section{Introduction}
+
+Untagged structures are implemented exactly like @racket[tagged] structures,
+except that they always use the @racket[untagged] tag name.
+
+@chunk[<structure>
+       (define-multi-id structure
+         #:type-expander  <expand-to-tagged>
+         #:match-expander <expand-to-tagged>
+         #:call           <expand-to-tagged>)]
+
+All three cases simply expand to
+@racket[(tagged untagged . _original-arguments)].
+
+@chunk[<expand-to-tagged>
+       (λ/syntax-case (_ . _original-arguments) ()
+         (syntax/top-loc stx
+           (tagged untagged . _original-arguments)))]
+
+The @racket[structure?] predicate is implemented in the same way:
+
+@chunk[<structure?>
+       (define-syntax structure?
+         (λ/syntax-case (_ . _original-arguments) ()
+           (syntax/top-loc stx
+             (tagged? untagged . _original-arguments))))]
+
+@section{Defining untagged structures with @racket[define-structure]}
+
+The @racket[define-structure] expands to the
+@racket[(define-tagged #:tag untagged . _original-arguments)], which uses
+@racket[define-tagged] but forces the tag name to be @racket[untagged].
+
+@chunk[<define-structure>
+       (define-syntax/case (define-structure . _original-arguments) ()
+         (syntax/top-loc stx
+           (define-tagged #:tag untagged . _original-arguments)))]
+
+@section{Implementation of @racket[StructureTop] and @racket[StructureTop?]}
+
+The @racket[StructureTop?] predicate is defined in terms of
+@racket[tagged-any-fields-predicate]:
+
+@CHUNK[<StructureTop?>
+       (define-syntax StructureTop?
+         (make-id+call-transformer-delayed
+          (λ () (tagged-any-fields-predicate #'untagged))))]
+
+Similarly, the @racket[StructureTop] type is defined using
+@racket[tagged-any-fields-type]:
+
+@CHUNK[<StructureTop>
+       (define-type-expander (StructureTop stx)
+         (syntax-case stx ()
+           [id
+            (identifier? #'id)
+            (tagged-any-fields-type #'untagged)]))]
+
+@section{Supertypes for structures}
+
+Like the @racket[structure] and @racket[structure?] identifiers,
+@racket[structure-supertype] is defined in terms of its tagged structure
+counterpart, @racket[tagged-supertype]:
+
+@chunk[<structure-supertype>
+       (define-multi-id structure-supertype
+         #:type-expander <expand-to-tagged-supertype>
+         #:match-expander <expand-to-tagged-supertype>)]
+
+@chunk[<expand-to-tagged-supertype>
+       (λ/syntax-case (_ . _original-arguments) ()
+           (syntax/top-loc stx
+             (tagged-supertype untagged . _original-arguments)))]
+
+@section{Putting it all together}
+
+@chunk[<*>
+       (require phc-toolkit
+                "tagged.hl.rkt"
+                "tagged-structure-low-level.hl.rkt"
+                "tagged-supertype.hl.rkt"
+                multi-id
+                type-expander
+                (for-syntax racket/base
+                            phc-toolkit/untyped))
+
+       (provide structure
+                structure?
+                define-structure
+                StructureTop
+                StructureTop?
+                structure-supertype)
+       
+       <structure>
+       <structure?>
+       <define-structure>
+       <StructureTop>
+       <StructureTop?>
+       <structure-supertype>]

phc-adt-lib/phc-adt/tagged-supertype.hl.rkt

@@ -0,0 +1,153 @@
+#lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require
+@(require scribble-enhanced/doc
+          scribble-math
+          racket/require
+          hyper-literate
+          (for-label (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                     (lib "phc-adt/tagged.hl.rkt")
+                     extensible-parser-specifications
+                     racket/format
+                     phc-toolkit
+                     phc-toolkit/untyped-only
+                     remember
+                     syntax/parse
+                     syntax/parse/experimental/template
+                     (subtract-in typed/racket/base type-expander)
+                     type-expander
+                     type-expander/expander
+                     multi-id))
+@doc-lib-setup
+
+@title[#:style manual-doc-style
+       #:tag "tagged-supertype"
+       #:tag-prefix "phc-adt/tagged-supertype"
+       ]{Supertypes of tagged structures}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/tagged-supertype"))
+
+
+@section{type-expander}
+
+@chunk[<tagged-supertype>
+       (define-multi-id tagged-supertype
+         #:type-expander <tagged-supertype-type-expander>
+         #:match-expander <tagged-supertype-match-expander>)]
+
+As a type, @racket[tagged-supertype] accepts two syntaxes. With the first
+one, the type of each field is specified, and the second returns a parametric
+structure:
+
+@chunk[<tagged-supertype-type-expander-signature-types>
+       (_ name:id [field:id (~optional :colon) type:expr] …)]
+
+@chunk[<tagged-supertype-type-expander-signature-infer>
+       (_ name (~either [field:id] field:id) …)]
+
+The type uses the @racket[structure] type-expander, and
+expands to the union of all structures which contain a
+superset of the given set of fields. It uses the specified
+type for the given fields, and defaults to @racket[Any] for the
+other extra fields.
+
+@chunk[<tagged-supertype-type-expander-impl-types>
+       (has-fields/type #'([field type] …))]
+
+The second syntax builds upon the first, and  produces a
+parametric type, with a @racket[∀] type argument for each
+specified field (other fields still falling back to 
+@racket[Any]).
+
+@CHUNK[<tagged-supertype-type-expander-impl-infer>
+       (define-temp-ids "~a/τ" (field …))
+       #`(∀ (field/τ …)
+            #,(has-fields/type #'([field field/τ] …)))]
+
+The type-expander finally calls either case depending on the
+syntax used.
+
+@chunk[<tagged-supertype-type-expander>
+       (λ (stx)
+         (syntax-parse stx
+           [<tagged-supertype-type-expander-signature-types>
+            <tagged-supertype-type-expander-impl-types>]
+           [<tagged-supertype-type-expander-signature-infer>
+            <tagged-supertype-type-expander-impl-infer>]))]
+
+@section{Match}
+
+The match-expander for tagged-supertype accepts all
+structures which contain a superset of the given set of fields:
+
+@chunk[<tagged-supertype-match-expander>
+       (λ/syntax-parse (_ . :tagged-match-args-syntax-class)
+         (define/with-syntax ([common . (all-field …)] …)
+           (has-fields/common #'(fieldᵢ …)))
+         (define/with-syntax ((maybe-fieldᵢ …) …)
+           (if (attribute no-implicit)
+               (map (const #'()) #'(fieldᵢ …))
+               #'((fieldᵢ) …)))
+         (define/with-syntax ((maybe-pats …) …)
+           (quasitemplate ((<maybe-pat…> …) …)))
+         #`(or (tagged name #:no-implicit-bind [all-field . maybe-pats] …) …))]
+
+@chunk[<tagged-anytag-match>
+       (define-match-expander tagged-anytag-match
+         (λ/syntax-case ([fieldᵢ patᵢⱼ …] …) ()
+           (tagged-anytag-match! #'([fieldᵢ (and patᵢⱼ …)] …))))]
+
+Each field that was passed to @racket[tagged-supertype]
+additionally matches against the given @racket[pat …], and
+other fields do not use any extra pattern.
+
+@chunk[<maybe-pat…>
+       (!cdr-assoc #:default []
+                   all-field
+                   [fieldᵢ . [maybe-fieldᵢ … patᵢⱼ …]]
+                   …)]
+
+@section{Nested supertype}
+
+The @racket[(tagged-supertype* f₁ f₂ … fₙ T)] type describes any structure
+containing a field @racket[f₁], whose type is any structure containing a field
+@racket[f₂] etc. The last field's type is given by @racket[T].
+
+@chunk[<tagged-supertype*>
+       (define-multi-id tagged-supertype*
+         #:type-expander
+         (λ (stx)
+           (error (string-append "tagged-supertype* is currently broken (needs"
+                                 " to ignore the tag name, since it doe not"
+                                 " have a tag at each step."))
+           (syntax-parse stx
+             [(_ T:expr)
+              #`T]
+             [(_ T:expr field:id other-fields:id …)
+              #`(tagged-supertype
+                 [field (tagged-supertype* T other-fields …)])]))
+         (code:comment
+          "#:match-expander <tagged-supertype-match-expander> ; TODO"))]
+
+@section{Conclusion}
+
+@chunk[<*>
+       (require (for-syntax racket/base
+                            racket/function
+                            racket/syntax
+                            syntax/parse
+                            syntax/parse/experimental/template
+                            phc-toolkit/untyped
+                            type-expander/expander)
+                phc-toolkit
+                multi-id
+                type-expander
+                "tagged-structure-low-level.hl.rkt"
+                "tagged.hl.rkt")
+
+       (provide tagged-supertype
+                tagged-supertype*)
+
+       <tagged-anytag-match>
+       <tagged-supertype>
+       <tagged-supertype*>]

phc-adt-lib/phc-adt/tagged.hl.rkt

@@ -0,0 +1,718 @@
+#lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require
+@(require racket/require
+          scribble-enhanced/doc
+          scribble-math
+          hyper-literate
+          (for-label (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                     (lib "phc-adt/node-low-level.hl.rkt")
+                     extensible-parser-specifications
+                     racket/format
+                     phc-toolkit
+                     phc-toolkit/untyped-only
+                     remember
+                     syntax/parse
+                     (subtract-in typed/racket/base type-expander)
+                     type-expander
+                     multi-id))
+
+@(unless-preexpanding
+  (require (for-label (submod ".."))))
+
+@doc-lib-setup
+
+@title[#:style manual-doc-style
+       #:tag "tagged"
+       #:tag-prefix "phc-adt/tagged"]{User API for tagged structures}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/tagged"))
+
+@(table-of-contents)
+
+@section{Overview of the implementation of structures}
+
+Tagged structures are represented using regular Racket @tc[struct]s,
+see @secref["choices" #:tag-prefixes '("phc-adt/choices")]
+for a somewhat outdated discussion of alternative possibilities.
+
+The ADT type system implemented by this library needs to know about all declared
+structures across the program, so that fields can be accessed anonymously, e.g.
+@tc[(get _instance _f)] instead of the traditional @tc[(_s-f _instance)] (where
+@tc[_s] is the struct's identifier, and @tc[f] is the field name). This allows
+the accessor @racket[get] to work on all structures which contain a field with
+the given name (and therefore plays well with
+@seclink["Union_Types" #:doc '(lib "typed-racket/scribblings/ts-guide.scrbl")]{
+ unions} of structures which share some fields). It also avoids the need to
+specify the struct which declared a field in order to accessing it. A separate
+library adds a coat of syntactic sugar to enable the notation
+@racket[instance.f1.f2.f3], following the well-known convention often used by
+object-oriented languages.
+
+The section @secref["tagged-low-level"
+                    #:tag-prefixes '("phc-adt/tagged-low-level")]
+describes the low-level implementation of tagged structures, including how all
+declared structures are remembered across compilations, and the implementation
+of the basic operations on them: constructor, predicate, accessor, type,
+match expander, and row polymorphism (also known as static duck typing). The
+implementation of row polymorphism works by querying the list of all known
+tagged structures and returns those containing a given set of fields.
+
+@section{A polyvalent identifier: type, match, constructor and instance}
+
+The @tc[tagged] identifier can be used to describe a tagged structure type, a
+match pattern, a tagged structure builder function, or to directly create an
+instance. The last two cases are handled by the @tc[<call-expander>].
+
+@chunk[<tagged>
+       (define-multi-id tagged
+         #:type-expander  tagged-type-expander
+         #:match-expander tagged-match-expander
+         #:call           tagged-call-expander)]
+
+@section{The @racket[tagged] call expander (builder and instance)}
+
+@chunk[#:save-as parse-field-instance… |<call [fieldᵢ] …+>|
+       (~seq {~either [fieldᵢ:id] fieldᵢ:id} …+
+             {~global-or builder?}
+             {~global-or no-types?}
+             {~post-fail <no-values-error> #:when (attribute instance?)})]
+
+@chunk[#:save-as parse-field… |<[fieldᵢ] …+>|
+       (~seq {~either [fieldᵢ:id] fieldᵢ:id} …+
+             {~global-or no-types?})]
+
+@chunk[#:save-as parse-field-colon-type… |<call [fieldᵢ : τᵢ] …+>|
+       (~seq [fieldᵢ:id C:colon τᵢ:expr] …+
+             {~global-or builder?}
+             {~global-or types?}
+             {~post-fail <no-values-error> #:when (attribute instance?)})]
+
+@chunk[#:save-as parse-field-type… |<[fieldᵢ τᵢ] …+>|
+       (~seq [fieldᵢ:id {~optional C:colon} τᵢ:expr] …+
+             {~global-or types?})]
+
+@chunk[#:save-as parse-field-pats… |<[fieldᵢ patᵢⱼ …] …+>|
+       (~seq (~either {~and fieldᵢ:id {~bind [(patᵢⱼ 1) (list)]}}
+                      [fieldᵢ:id patᵢⱼ:expr …])
+             …+)]
+
+@chunk[#:save-as parse-field-value… |<call [fieldᵢ valueᵢ] …+>|
+       (~seq [fieldᵢ:id valueᵢ:expr] …+
+             {~global-or instance?}
+             {~global-or no-types?}
+             {~post-fail <values-error> #:when (attribute builder?)})]
+
+@chunk[#:save-as parse-field-value-type… |<call [fieldᵢ valueᵢ : τᵢ] …+>|
+       (~seq (~either [fieldᵢ:id valueᵢ:expr C:colon τᵢ:expr]
+                      [fieldᵢ:id C:colon τᵢ:expr valueᵢ:expr])
+             …+
+             {~global-or instance?}
+             {~global-or types?}
+             {~post-fail <values-error> #:when (attribute builder?)})]
+
+@chunk[#:save-as no-values-error <no-values-error>
+       (~a "The #:instance keyword implies the use of [field value],"
+           " [field : type value] or [field value : type].")]
+
+@chunk[#:save-as values-error <values-error>
+       (~a "The #:builder keyword implies the use of [field], field"
+           " or [field : type].")]
+
+@chunk[#:save-as empty-error <empty-err>
+       (~a "If no fields are specified, then either #:builder or #:instance"
+           " must be present")]
+
+When called like a macro, @tc[tagged] accepts several syntaxes:
+@itemlist[
+ @item{@racket[(tagged name [fieldᵢ] …+)] or @racket[(tagged name fieldᵢ …+)],
+  which return a builder function which has a type argument @racket[τᵢ]
+  corresponding to each @racket[fieldᵢ]'s type.
+  
+  @(parse-field-instance…)
+
+  This clause implies the creation of a builder function, so if 
+  @racket[#:instance] is specified, the following error is raised:
+  
+  @(no-values-error)}
+ @item{@racket[(tagged name [fieldᵢ valueᵢ] …+)], which returns an instance,
+  inferring the type of the fields
+  
+  @(parse-field-colon-type…)
+
+  This clause implies the creation of an instance, so if @racket[#:builder] is
+  specified, the following error is raised:
+  
+  @(values-error)}
+ @item{@racket[(tagged name [fieldᵢ : τᵢ] …+)], which returns a constructor with
+  the given types
+  
+  @(parse-field-value…)
+
+  This clause implies the creation of a builder function, so if
+  @racket[#:instance] is specified, the following error is raised:
+  
+  @(no-values-error)}
+ @item{@racket[(tagged name [fieldᵢ valueᵢ : τᵢ] …+)], which returns an instance
+  using the given types
+  
+  @(parse-field-value-type…)
+
+  This clause implies the creation of an instance, so if @racket[#:builder] is
+  specified, the following error is raised:
+  
+  @(values-error)}]
+
+@subsection{Call to @racket[tagged] with no fields:
+ instance or constructor?}
+
+A call to @tc[(tagged)] with no field is ambiguous: it could return a
+constructor function for the structure with no fields, or an instance of that
+structure.
+
+@racketblock[(tagged)]
+
+We tried to make a hybrid object using @tc[define-struct/exec] which would be an
+instance of the structure with no fields, but could also be called as a function
+(which would return itself). Unfortunately, this use case is not yet fully
+supported by Typed/Racket: the instance cannot be annotated as a function type,
+or passed as an argument to a higher-order function (Typed/Racket issue
+@hyperlink["https://github.com/racket/typed-racket/issues/430"]{#430}). This can
+be circumvented by using unsafe operations to give the instance its proper type
+@tc[(Rec R (∩ (→ R) struct-type))], but Typed/Racket does not consider this type
+applicable, and an annotation is required each time the instance is used as a
+builder function (Typed/Racket issue
+@hyperlink["https://github.com/racket/typed-racket/issues/431"]{#431}.
+
+We therefore added two optional keywords, @tc[#:instance] and @tc[#:builder],
+which can be used to disambiguate. They can also be used when fields
+respectively with or without values are specified, so that macros don't need to
+handle the empty structure as a special case.
+
+@subsection{Signature for the @racket[tagged] call expander}
+
+@chunk[#:save-as disambiguate-mixin <tagged-call-instance-or-builder-mixin>
+       (define-eh-alternative-mixin tagged-call-instance-or-builder-mixin
+         (pattern
+          (~optional (~and instance-or-builder
+                           (~or {~global-or instance? #:instance}
+                                {~global-or builder? #:builder}))
+                     #:name "either #:instance or #:builder")))]
+
+@chunk[#:save-as fields-mixin <tagged-call-fields-mixin>
+       (define-eh-alternative-mixin tagged-call-fields-mixin
+         (pattern
+          (~optional/else
+           (~try-after name-order-point <name-after-field-error>
+                       (~or |<call [fieldᵢ] …+>|
+                            |<call [fieldᵢ : τᵢ] …+>|
+                            |<call [fieldᵢ valueᵢ] …+>|
+                            |<call [fieldᵢ valueᵢ : τᵢ] …+>|))
+           #:defaults ([(fieldᵢ 1) (list)]
+                       [(valueᵢ 1) (list)]
+                       [(τᵢ 1) (list)])
+           #:else-post-fail <empty-err> #:unless (or (attribute builder?)
+                                                     (attribute instance?))
+           #:name (~a "field or [field] or [field : type] for #:builder,"
+                      " [field value] or [field : type value]"
+                      " or [field value : type] for #:instance"))))]
+
+@chunk[#:save-as ∀-mixin <∀-mixin>
+       (define-eh-alternative-mixin ∀-mixin
+         (pattern {~optional (~seq #:∀ ({~named-seq tvarᵢ :id …})
+                                   (~global-or tvars?))}))]
+
+@chunk[#:save-as name-id-mixin <name-id-mixin>
+       (define-eh-alternative-mixin name-id-mixin
+         (pattern
+          (~once (~order-point name-order-point name:id))))]
+
+@chunk[#:save-as name-after-field-error <name-after-field-error>
+       "the name must appear before any field"]
+
+When called as a macro, @tc[tagged] expects:
+
+@itemlist[
+ @item{The tagged structure's tag name:
+
+  @(name-id-mixin)}
+ @item{An optional list of type variables, preceded by @racket[#:∀]:
+
+  @(∀-mixin)}
+ @item{Either of the @racket[#:builder] or @racket[#:instance] options, or none:
+
+  @(disambiguate-mixin)}
+ @item{An optional list of fields, possibly annotated with a type, and possibly
+  associated to a value:
+
+  @(fields-mixin)
+
+  When no fields are specified, the following error is raised unless either
+  @racket[#:builder] or @racket[#:instance] is specified.
+
+  @(empty-error)}]
+
+The four elements can appear in any order, with one constraint: the name must
+appear before the first field descriptor. Not only does it make more sense
+semantically, but it also avoids ambiguities when the list of field names is
+just a list of plain identifiers (without any type or value).
+
+@(name-after-field-error)
+
+We can now combine all four mixins.
+
+@chunk[<tagged-call-args-mixin>
+       (define-eh-alternative-mixin tagged-call-args-mixin
+         #:define-splicing-syntax-class tagged-call-args-syntax-class
+         (pattern {~mixin name-id-mixin})
+         (pattern {~mixin tagged-call-instance-or-builder-mixin})
+         (pattern {~mixin tagged-call-fields-mixin})
+         (pattern {~mixin ∀-mixin}))]
+
+@subsection{Implementation}
+
+The call expander uses the low-level functions @tc[tagged-builder!],
+@tc[tagged-∀-builder!] and @tc[tagged-infer-builder!] implemented in
+@secref["Creating_instances_of_a_tagged_structure"
+        #:tag-prefixes '("phc-adt/tagged-low-level")].
+The first returns the syntax for a builder function for the given tagged
+structure. The second returns the syntax for a polymorphic builder function for
+the given tagged structure, using the given type variables which are bound
+inside the field type declarations. The last returns the syntax for a
+polymorphic builder function for the given tagged structure, with one type
+parameter per field, which allows the type of each field to be inferred.
+
+@chunk[<call-expander>
+       (define/syntax-parse+simple
+           (tagged-call-expander :tagged-call-args-syntax-class)
+         <call-expander-cases>)]
+
+If type variables are present, then @tc[tagged-∀-builder!] is used. Otherwise,
+if types are specified, then @tc[tagged-builder!] is used, otherwise
+@tc[tagged-infer-builder!] is used.
+
+@chunk[<call-expander-cases>
+       (define/with-syntax f
+         (if (attribute tvars?)
+             (tagged-∀-builder! #'((tvarᵢ …) name [fieldᵢ : τᵢ] …))
+             (if (attribute types?)
+                 (tagged-builder! #'(name [fieldᵢ τᵢ] …))
+                 (tagged-infer-builder! #'(name fieldᵢ …)))))]
+
+If the @tc[#:instance] keyword was specified, or if values are specified for
+each field, the builder function is immediately called with those values, in
+order to produce an instance of the tagged structure. Otherwise, the builder
+function itself is produced.
+
+@chunk[<call-expander-cases>
+       (if (attribute instance?)
+           #'(f valueᵢ …)
+           #'f)]
+
+@section{Type expander}
+
+@chunk[#:save-as type-fields-mixin <tagged-type-fields-mixin>
+       (define-eh-alternative-mixin tagged-type-fields-mixin
+         (pattern
+          (~optional
+           (~try-after name-order-point <name-after-field-error>
+                       (~named-seq field-declarations
+                         (~or |<[fieldᵢ] …+>|
+                              |<[fieldᵢ τᵢ] …+>|)))
+           #:defaults ([(fieldᵢ 1) (list)]
+                       [(τᵢ 1) (list)])
+           #:name "field or [field] or [field type] or [field : type]")))]
+
+When used as a type expander, @tc[tagged] expects:
+
+@itemlist[
+ @item{The tagged structure's tag name, as defined for the call expander in
+  @racket[<name-id-mixin>]}
+ @item{An optional list of type variables, as defined for the call expander in
+  @racket[<∀-mixin>]}
+ @item{An optional list of fields, possibly annotated with a type:
+
+  @(type-fields-mixin)
+
+  The main difference with the allowed field specifications for the call
+  expander are that values are not allowed. Furthermore, the @racket[:] between
+  a field and its type is optional:
+
+  @(parse-field-type…)
+
+  Furthermore, the @racket[instance?] and @racket[builder?] attributes are not
+  meaningful for the type expander.
+
+  @(parse-field…)}]
+
+The three elements can appear in any order, with the same constraint as for the
+call expander: the name must appear before the first field descriptor.
+
+@(name-after-field-error)
+
+@chunk[<tagged-type-args-mixin>
+       (define-eh-alternative-mixin tagged-type-args-mixin
+         #:define-splicing-syntax-class tagged-type-args-syntax-class
+         (pattern {~mixin name-id-mixin})
+         (pattern {~mixin tagged-type-fields-mixin})
+         (pattern {~mixin ∀-mixin}))]
+
+The type expander uses the low-level functions @tc[tagged-type!],
+@tc[tagged-∀-type!] and @tc[tagged-infer-type!] implemented in
+@secref["Type_of_a_tagged_structure"
+        #:tag-prefixes '("phc-adt/tagged-low-level")]. The first
+returns the syntax for the type for the given tagged structure. The second
+returns the syntax for a polymorphic type for the given tagged structure, using
+the given type variables which are bound inside the field type declarations. The
+last returns the syntax for a polymorphic type for the given tagged structure,
+with one type parameter per field, which allows the type of each field to be
+inferred or filled in later.
+
+@chunk[<type-expander>
+       (define/syntax-parse+simple
+           (tagged-type-expander :tagged-type-args-syntax-class)
+         <type-expander-cases>)]
+
+If type variables are present, then @tc[tagged-∀-type!] is used. Otherwise,
+if types are specified, then @tc[tagged-type!] is used, otherwise
+@tc[tagged-infer-type!] is used.
+
+@chunk[<type-expander-cases>
+       (if (attribute tvars?)
+           (tagged-∀-type! #'((tvarᵢ …) name [fieldᵢ : τᵢ] …))
+           (if (attribute types?)
+               (tagged-type! #'(name [fieldᵢ τᵢ] …))
+               (tagged-infer-type! #'(name fieldᵢ …))))]
+
+@subsection{The @racket[TaggedTop] type}
+
+The @tc[TaggedTop] type is extracted from the low-level @tc[TaggedTop-struct]
+identifier (which is a struct identifier). The @tc[TaggedTop] type includes not
+only tagged structures, but also nodes.
+
+@chunk[<TaggedTop>
+       (define-type TaggedTop TaggedTop-struct)]
+
+Additionally, the @racket[TaggedTop?] predicate is simply aliased from the
+low-level @racket[TaggedTop-struct?].
+
+@; Do not use rename-out, as it confuses scribble (two documentations for one
+@; identifier: the user-level documentation of the TaggedTop? function, and
+@; the low-level documentation of the TaggedTop-struct struct.
+@chunk[<TaggedTop>
+       (define TaggedTop? TaggedTop-struct?)]
+
+@section{Match expander}
+
+@chunk[#:save-as match-fields-mixin <tagged-match-fields-mixin>
+       (define-eh-alternative-mixin tagged-match-fields-mixin
+         (pattern
+          (~maybe/empty
+           (~try-after name-order-point <name-after-field-error>
+                       |<[fieldᵢ patᵢⱼ …] …+>|)
+           #:name (~a "field or [field pat …]"))))]
+
+@chunk[#:save-as no-implicit-mixin <tagged-match-no-implicit-bind-mixin>
+       (define-eh-alternative-mixin tagged-match-no-implicit-bind-mixin
+         (pattern (~optional (~global-or no-implicit #:no-implicit-bind))))]
+
+When used as a match expander, @tc[tagged] expects:
+
+@itemlist[
+ @item{The tagged structure's tag name, as defined for the call expander in
+  @racket[<name-id-mixin>]}
+ @item{The @racket[#:no-implicit-bind], which specified that the field name
+  should not automatically be bound by the match pattern to the field's
+  contents:
+
+  @(no-implicit-mixin)}
+ @item{A (possibly empty) list of fields, each associated with zero or more
+  patterns:
+
+  @(match-fields-mixin)
+
+  The main differences with the allowed field specifications for the call
+  expander are that values and types are not allowed, but instead the field name
+  may be followed by match patterns:
+
+  @(parse-field-pats…)}]
+
+The three elements can appear in any order, with the same constraint as for the
+call expander: the name must appear before the first field descriptor.
+
+@(name-after-field-error)
+
+@chunk[<tagged-match-args-mixin>
+       (define-eh-alternative-mixin tagged-match-args-mixin
+         #:define-syntax-class tagged-match-args-syntax-class
+         (pattern {~mixin name-id-mixin})
+         (pattern {~mixin tagged-match-no-implicit-bind-mixin})
+         (pattern {~mixin tagged-match-fields-mixin}))]
+
+The match expander uses the low-level function @tc[tagged-match!] implemented in
+@secref["Type_of_a_tagged_structure"
+        #:tag-prefixes '("phc-adt/tagged-low-level")]. It returns
+the syntax for a match pattern for the given tagged structure. The resulting
+match pattern checks that the value is an instance of a tagged structure with
+the given name and fields, and matches the value of each field against the
+corresponding pattern.
+
+@chunk[<match-expander>
+       (define/syntax-parse+simple
+           (tagged-match-expander . :tagged-match-args-syntax-class)
+         <match-expander-body>)]
+
+Unless @racket[#:no-implicit-bind] is specified, we include the field name as
+part of the pattern, so that field names are bound to the field's contents.
+
+@chunk[<match-expander-body>
+       (if (attribute no-implicit)
+           (tagged-match! #'(name [fieldᵢ (and patᵢⱼ …)] …))
+           (tagged-match! #'(name [fieldᵢ (and fieldᵢ patᵢⱼ …)] …)))]
+
+@section{Predicates for tagged structures}
+
+@chunk[<tagged?>
+       (define-syntax tagged?
+         (syntax-parser
+           [(_ name fieldᵢ:id …)
+            (tagged-any-predicate! #'(name fieldᵢ …))]
+           [(_ name [fieldᵢ:id :colon τᵢ:type] …)
+            (tagged-predicate! #'(name [fieldᵢ τᵢ] …))]
+           [(_ name [fieldᵢ:id predᵢ:type] …)
+            (tagged-pred-predicate! #'(name [fieldᵢ predᵢ] …))]))]
+
+@subsection{The @racket[TaggedTop?] predicate}
+
+The @tc[TaggedTop?] predicate is simply re-provided. It is initially defined in
+@secref["Common_ancestor_to_all_tagged_structures__TaggedTop-struct"
+        #:tag-prefixes '("phc-adt/tagged-low-level")].
+
+@chunk[|<provide TaggedTop?>|
+       (provide (rename-out [TaggedTop-struct? TaggedTop?]))]
+
+@section{Defining shorthands with @racket[define-tagged]}
+
+The @tc[define-tagged] macro can be used to bind to an
+identifier the type expander, match expander, predicate and
+constructor function for a given tagged structure.
+
+@chunk[#:save-as tag-kw-mixin <tag-kw-mixin>
+       (define-eh-alternative-mixin tag-kw-mixin
+         (pattern {~optional {~seq #:tag explicit-tag <default-tag-name>}}))]
+
+@chunk[#:save-as tag-kw-mixin-default <default-tag-name>
+       {~post-check
+        {~bind [tag-name (or (attribute explicit-tag)
+                             #'name)]}}]
+
+@chunk[#:save-as predicate?-mixin <predicate?-mixin>
+       (define-eh-alternative-mixin predicate?-mixin
+         (pattern {~optional {~seq #:? predicate? <default-name?>}}))]
+
+@chunk[#:save-as predicate?-mixin-default <default-name?>
+       {~post-check
+        {~bind [name? (or (attribute predicate?)
+                          (format-id/record #'name "~a?" #'name))]}}]
+
+The @tc[define-tagged] macro expects:
+
+@itemlist[
+ @item{The tagged structure's tag name, as defined for the call expander in
+  @racket[<name-id-mixin>]}
+ @item{An optional list of type variables, as defined for the call expander in
+  @racket[<∀-mixin>]}
+ @item{A possibly empty list of fields, possibly annotated with a type, as
+  defined for the type expander in @racket[<tagged-type-fields-mixin>]}
+ @item{Optionally, the tag name to be used, specified with
+  @racket[#:tag tag-name]:
+
+  @(tag-kw-mixin)
+
+  The tag name defaults to @racket[_name], i.e. the identifier currently being
+  defined.
+
+  @(tag-kw-mixin-default)}
+ @item{Optionally, a name for the predicate, specified with
+  @racket[#:? predicate-name?]:
+  
+  @(predicate?-mixin)
+
+  The predicate name defaults to @racket[_name?], where @racket[_name] is the
+  identifier currently being defined.
+
+  @(predicate?-mixin-default)}]
+
+The five elements can appear in any order, with the same constraint as for the
+call expander: the name must appear before the first field descriptor.
+
+@chunk[<define-tagged-args-mixin>
+       (define-eh-alternative-mixin define-tagged-args-mixin
+         #:define-splicing-syntax-class define-tagged-args-syntax-class
+         (pattern (~or {~mixin name-id-mixin}
+                       {~mixin tag-kw-mixin}
+                       {~mixin tagged-type-fields-mixin}
+                       {~mixin predicate?-mixin}
+                       {~mixin ∀-mixin})))]
+
+The @tc[define-tagged] macro is then implemented using @racket[define-multi-id]:
+
+@CHUNK[<define-tagged>
+       (define-syntax/parse+simple
+           (define-tagged :define-tagged-args-syntax-class)
+         (define-temp-ids "~a/pat" (fieldᵢ …))
+         (quasisyntax/top-loc stx
+           (begin
+             (define-multi-id name
+               #:type-expander    (make-id+call-transformer
+                                   #'<type-expander/define>)
+               #:match-expander   <match-expander/define>
+               #:else             <else-expander/define>)
+             (define name?        <predicate/define>))))]
+
+The type expander handles the same three cases as for @tc[tagged]: with type
+variables, with a type for each field, or inferred.
+
+@CHUNK[<type-expander/define>
+       #,(if (attribute tvars?)
+             (tagged-∀-type! #'((tvarᵢ …) tag-name [fieldᵢ τᵢ] …))
+             (if (attribute types?)
+                 (tagged-type! #'(tag-name [fieldᵢ τᵢ] …))
+                 (tagged-infer-type! #'(tag-name fieldᵢ …))))]
+
+The match expander is a short form of the one implemented for @tc[tagged], as it
+takes only one positional pattern per field.
+
+@chunk[<match-expander/define>
+       (λ (stx2)
+         (syntax-case stx2 ()
+           [(_ fieldᵢ/pat …)
+            (tagged-match! #'(tag-name [fieldᵢ fieldᵢ/pat] …))]
+           (code:comment "Todo: implement a \"rest\" pattern")))]
+
+Otherwise, when @racket[_name] is called as a function, or used as an identifier
+on its own, we produce a builder function. When @racket[_name] is called as a
+function, the builder function is applied immediately to the arguments,
+otherwise the builder function itself is used. The same three cases as for
+@tc[tagged] are handled: with type variables, with a type for each field, or
+inferred.
+
+@CHUNK[<else-expander/define>
+       #'#,(if (attribute tvars?)
+               (tagged-∀-builder!
+                #'((tvarᵢ …) tag-name [fieldᵢ τᵢ] …))
+               (if (attribute types?)
+                   (tagged-builder! #'(tag-name [fieldᵢ τᵢ] …))
+                   (tagged-infer-builder! #'(tag-name fieldᵢ …))))]
+
+Finally, we define the predicate @racket[name?]. Contrarily to @racket[tagged?],
+it does not take into account the field types, as we have no guarantee that
+Typed/Racket's @racket[make-predicate] works for those. Instead, @racket[name?]
+recognises any instance of a tagged structure with the given tag name and
+fields. If a more accurate predicate is desired, it can easily be implemented
+using @racket[tagged?].
+
+@CHUNK[<predicate/define>
+       #,(tagged-any-predicate! #'(tag-name fieldᵢ …))]
+
+@section{Implementation of @racket[uniform-get]}
+
+@racket[uniform-get] operates on tagged structures. It retrieves the desired
+field from the structure, and forces it to obtain the actual value.
+
+It is implemented as @racket[tagged-get-field] in
+@secref["Accessing_fields_of_tagged_structures"
+        #:tag-prefixes '("phc-adt/tagged-low-level")], and is
+simply re-provided here.
+
+@section{Putting it all together}
+
+@chunk[<*>
+       (require (for-syntax racket/base
+                            racket/syntax
+                            syntax/parse
+                            phc-toolkit/untyped
+                            syntax/strip-context
+                            racket/function
+                            extensible-parser-specifications
+                            racket/format
+                            type-expander/expander)
+                phc-toolkit
+                multi-id
+                type-expander
+                racket/promise
+                "tagged-structure-low-level.hl.rkt"
+                racket/format)
+
+       @; Do not use rename-out, as it confuses scribble (two documentations for
+       @; one identifier: the user-level documentation of uniform-get, and the
+       @; low-level documentation of tagged-get-field.
+       (define-syntax uniform-get
+         (make-rename-transformer #'tagged-get-field))
+       (define-syntax λuniform-get
+         (make-rename-transformer #'λ-tagged-get-field))
+       (provide uniform-get
+                λuniform-get
+                tagged
+                tagged?
+                define-tagged
+                TaggedTop
+                TaggedTop?
+                
+                (for-syntax tagged-call-args-syntax-class
+                            tagged-call-expander-forward-attributes
+                            tagged-call-expander
+                  
+                            tagged-type-args-syntax-class
+                            tagged-type-expander-forward-attributes
+                            tagged-type-expander
+                  
+                            tagged-match-args-syntax-class
+                            tagged-match-expander-forward-attributes
+                            tagged-match-expander
+
+                            define-tagged-args-syntax-class
+                            define-tagged-forward-attributes))
+       
+       (begin-for-syntax
+         <∀-mixin>
+         <name-id-mixin>
+         <tagged-call-instance-or-builder-mixin>
+         <tagged-call-fields-mixin>
+         <tagged-call-args-mixin>
+         <tagged-type-fields-mixin>
+         <tagged-type-args-mixin>
+         <tagged-match-fields-mixin>
+         <tagged-match-no-implicit-bind-mixin>
+         <tagged-match-args-mixin>
+
+         <predicate?-mixin>
+         <tag-kw-mixin>
+         <define-tagged-args-mixin>)
+
+       (begin-for-syntax
+         <call-expander>
+         <type-expander>
+         <match-expander>)
+       <tagged>
+       <tagged?>
+       <TaggedTop>
+       <define-tagged>]
+
+@;tagged-call-instance-or-builder-mixin
+@;tagged-call-fields-mixin
+@;tagged-call-args-mixin
+
+@;tagged-type-fields-mixin
+@;tagged-type-args-mixin
+
+@;tagged-match-fields-mixin
+@;tagged-match-no-implicit-bind-mixin
+@;tagged-match-args-mixin
+
+@;tag-kw-mixin
+@;predicate?-mixin
+@;define-tagged-args-mixin
+
+@;name-id-mixin
+@;∀-mixin

phc-adt-lib/phc-adt/variant.hl.rkt

@@ -0,0 +1,147 @@
+#lang hyper-literate typed/racket/base #:no-require-lang #:no-auto-require
+@(require scribble-enhanced/doc)
+@doc-lib-setup
+
+@require[racket/require
+         @for-label[(subtract-in typed/racket/base type-expander)
+                    racket/list
+                    syntax/parse
+                    syntax/parse/experimental/template
+                    (subtract-in racket/syntax phc-toolkit)
+                    phc-toolkit/untyped-only
+                    type-expander/expander
+                    phc-toolkit
+                    multi-id
+                    type-expander
+                    "constructor.hl.rkt"
+                    "structure.hl.rkt"]]
+
+@title[#:style manual-doc-style
+       #:tag "variant"
+       #:tag-prefix "phc-adt/variant"]{User API for variants}
+
+@(chunks-toc-prefix
+  '("(lib phc-adt/scribblings/phc-adt-implementation.scrbl)"
+    "phc-adt/variant"))
+
+@(table-of-contents)
+
+@section{Introduction}
+
+For convenience, we write a @tc[variant] form, which is a
+thin wrapper against @tc[(U (~or constructor tagged) …)].
+
+@section{Implementation of @racket[variant]}
+
+In @tc[define-variant], we only define the type (which is
+the union of all the possible constructors. We do not bind
+identifiers for 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[<constructor-or-tagged-stx-class>
+       (begin-for-syntax
+         (define-syntax-class constructor-or-tagged
+           (pattern [constructor-name:id . (~or ([field:id C:colon type:expr] …)
+                                                (type:expr …))])))]
+
+@chunk[<variant>
+       (define-type-expander (variant stx)
+         (syntax-parse stx
+           [(_ :constructor-or-tagged …)
+            (template
+             (U (?? (tagged constructor-name [field C type] …)
+                    (constructor constructor-name type …))
+                …))]))]
+
+@section{Predicate}
+
+@chunk[<variant?>
+       (define-syntax/parse (variant? :constructor-or-tagged …)
+         (template
+          (λ (v) (or (?? ((tagged? constructor-name field …) v)
+                         (constructor? constructor-name v))
+                     …))))]
+
+@section{@racket[define-variant]}
+
+@chunk[<define-variant>
+       (define-syntax/parse
+           (define-variant variant-name
+             (~optkw #:debug)
+             (~maybe #:? name?)
+             (~maybe #:match variant-match)
+             (~and constructor-or-tagged :constructor-or-tagged) …)
+         (define/with-syntax default-name? (format-id #'name "~a?" #'name))
+         (define/with-syntax default-match (format-id #'name "~a-match" #'name))
+         (define-temp-ids "pat" ((type …) …))
+         (define-temp-ids "match-body" (constructor-name …))
+         (template
+          (begin
+            (define-type variant-name
+              (variant [constructor-name (?? (?@ [field C type] …)
+                                             (?@ type …))]
+                       …))
+            (define-syntax (?? variant-match default-match)
+              (syntax-rules (constructor-name … (?? (?@ field …)) …)
+                [(_ v
+                    [(constructor-name (?? (?@ [field pat] …)
+                                           (pat …)))
+                     . match-body]
+                    …)
+                 (match v
+                   (?? [(tagged constructor-name [field pat] …) . match-body]
+                       [(constructor constructor-name pat …) . match-body])
+                   …)]))
+            (define-multi-id (?? name? default-name?)
+              #:else
+              #'(variant? constructor-or-tagged …))))
+         #|
+         (if (andmap (λ (t) (check-remember-all 'variant t))
+                     (syntax->list #'(tag …)))
+             (let ()
+               (define/with-syntax (stx-name …)
+                 (stx-map (λ (t)
+                            (cdr (assoc (syntax->datum (datum->syntax #f t))
+                                        tag-name→stx-name/alist)))
+                          #'(tag …)))
+               (quasitemplate
+                (begin
+                  (define-type name (U (constructor tag type …) …))
+                  (: (?? name? default-name?)
+                     (→ Any Boolean :
+                        #:+ (or (stx-name Any) …)
+                        #:- (and (! (stx-name Any)) …)))
+                  (define ((?? name? default-name?) x)
+                    (or (Tagged-predicate? tag x) …)))))
+             (stx-map (λ (t)
+                        (remember-all-errors2 (syntax/loc t #'please-recompile)
+                                              t))
+                      #'(tag …)))|#)]
+
+@section{Conclusion}
+
+@chunk[<*>
+       (require (for-syntax racket/base
+                            racket/list
+                            syntax/parse
+                            syntax/parse/experimental/template
+                            racket/syntax
+                            phc-toolkit/untyped
+                            type-expander/expander)
+                phc-toolkit
+                multi-id
+                type-expander
+                "constructor.hl.rkt"
+                "structure.hl.rkt")
+           
+       (provide variant
+                variant?
+                define-variant)
+           
+       <constructor-or-tagged-stx-class>
+       <variant>
+       <variant?>
+       <define-variant>]

phc-adt-test/info.rkt

@@ -0,0 +1,14 @@
+#lang info
+(define collection 'multi)
+(define deps '("base"
+               "phc-adt-lib"
+               "rackunit-lib"
+               "typed-racket-lib"
+               "typed-racket-more"
+               "multi-id"
+               "phc-toolkit"
+               "type-expander"))
+(define build-deps '())
+(define pkg-desc "Tests for the phc-adt library")
+(define version "1.1")
+(define pkg-authors '("Georges Dupéron"))

phc-adt-test/phc-adt/test/adt-pre-declarations.rkt

@@ -0,0 +1,54 @@
+#lang s-exp phc-adt/declarations
+(remembered! tagged-structure (untagged a b))
+(remembered! tagged-structure (st2 a b))
+(remembered! tagged-structure (t a b c))
+(remembered! tagged-structure (tabc a b c))
+(remembered! tagged-structure (tag1 values))
+(remembered! tagged-structure (a values))
+(remembered! tagged-structure (b values))
+(remembered! tagged-structure (c values))
+(remembered! tagged-structure (d values))
+(remembered! tagged-structure (e values))
+(remembered! tagged-structure (F values))
+(remembered! tagged-structure (tag0 values))
+(remembered! tagged-structure (tag2 values))
+(remembered! tagged-structure (tag3 values))
+(remembered! tagged-structure (tagged-s1))
+(remembered! tagged-structure (tagged-s2 f g))
+(remembered! tagged-structure (tagged-s3 f g))
+(remembered! tagged-structure (tagged-s4 f g))
+(remembered! tagged-structure (c1 values))
+(remembered! tagged-structure (c2 values))
+(remembered! tagged-structure (c3 values))
+(remembered! tagged-structure (txyz a b))
+(remembered! tagged-structure (cxyz values))
+(remembered! tagged-structure (txyz x y))
+(remembered! tagged-structure (untagged))
+(remembered! tagged-structure (empty-tg))
+(remembered! tagged-structure (empty-ct values))
+(remembered! tagged-structure (empty-ct-t2 values))
+(remembered! tagged-structure (empty-ct-t3 values))
+(remembered! tagged-structure (empty-ct-2 values))
+(remembered! tagged-structure (empty-ct-3 values))
+(remembered! tagged-structure (untagged test-fa test-fb))
+(remembered! tagged-structure (untagged test-fa test-fc))
+(remembered! tagged-structure (untagged test-fa test-fd))
+(remembered! tagged-structure (untagged a c))
+(remembered! tagged-structure (untagged a b c d))
+(remembered! tagged-structure (untagged a b c y))
+(remembered! tagged-structure (untagged a b c))
+(remembered! tagged-structure (untagged a))
+(remembered! tagged-structure (t0 tagged-fa tagged-fb tagged-fc))
+(remembered! tagged-structure (t0 tagged-fx tagged-fy tagged-fz))
+(remembered! tagged-structure (a a b))
+(remembered! tagged-structure (b a b))
+(remembered! tagged-structure (c a b))
+(remembered! tagged-structure (ma faa fab fav))
+(remembered! tagged-structure (mb fba fbv))
+(remembered! tagged-structure (t1 x y))
+(remembered! tagged-structure (foo x y z))
+(remembered! tagged-structure (x values))
+(remembered! tagged-structure (y values))
+(remembered! tagged-structure (z values))
+(remembered! tagged-structure (w values))
+(remembered! tagged-structure (tg x y))

phc-adt-test/phc-adt/test/ck.rkt

@@ -0,0 +1,49 @@
+#lang typed/racket/base
+
+(require phc-toolkit
+         typed/rackunit
+         type-expander
+         racket/string
+         (for-syntax racket/base
+                     phc-toolkit/untyped)
+         (lib "phc-adt/ctx.hl.rkt"))
+
+(provide ck
+         ck-not
+         check-print-type)
+
+(define-syntax (ck stx)
+  (syntax-case stx ()
+    [(_ v t)
+     (quasisyntax/top-loc stx
+       (check-tc
+        (require (only-in (lib "phc-adt/ctx.hl.rkt") set-adt-context-macro))
+        (set-adt-context-macro #,(datum->syntax #'t 'there))
+        (ann v t)))]))
+
+(define-syntax (ck-not stx)
+  (syntax-case stx ()
+    [(_ v t)
+     (quasisyntax/top-loc stx
+       (check-not-tc
+        (require (only-in (lib "phc-adt/ctx.hl.rkt") set-adt-context-macro))
+        (set-adt-context-macro #,(datum->syntax #'t 'there))
+        (ann v t)))]))
+
+(: clean-type-str (→ String String))
+(define (clean-type-str type-str)
+  (string-trim
+   (regexp-replace* #px"(?-s:[ \n]+)"
+                    (regexp-replace #px"^- :" type-str "")
+                    " ")))
+
+(define-syntax/case (check-print-type e str) ()
+  (eval-tc
+   (λ (f)
+     (quasisyntax/top-loc stx
+       (check-equal?: (clean-type-str (#,f)) str)))
+   (quasisyntax/top-loc stx
+     (begin (current-print (λ _ (void)))
+            (require (only-in (lib "phc-adt/ctx.hl.rkt") set-adt-context-macro))
+            (set-adt-context-macro #,(datum->syntax #'t 'there))
+            e))))

phc-adt-test/phc-adt/test/mailing-list-example/adt-pre-declarations.rkt

@@ -0,0 +1,5 @@
+#lang s-exp phc-adt/declarations
+(remembered! tagged-structure (foo-ct values))
+(remembered! tagged-structure (foo values))
+(remembered! tagged-structure (untagged a b))
+(remembered! tagged-structure (untagged a c))

phc-adt-test/phc-adt/test/mailing-list-example/example.rkt

@@ -0,0 +1,53 @@
+#lang typed/racket
+;; phc-adt sets registers some information in its support files when it
+;; encounters new structure types, so this file has to be compiled twice
+;; in DrRacket (not on the command-line). The first compilation will fail,
+;; it is normal and expected (but it should soon give a better error message)
+(require type-expander multi-id phc-adt typed/rackunit)
+(adt-init)
+
+;; This internally does
+;; (define-multi-id s1
+;;   #:type-expander  (λ (stx) …)
+;;   #:match-expander (λ (stx) …)
+;;   #:call           (λ (stx) …)
+;;   #:id             (λ (stx) …))
+(define-structure s1 [a : Number] [b : String])
+
+;; The "structure" identifier is also a multi-id, for on-the-fly usage of a
+;; structure as a type, match pattern, constructor function or instance creation
+
+(: foo (→ (U
+           ;; type-expander: s1
+           s1
+           ;; type-expander: (structure [field : type] …)
+           (structure [a : Number] [c : Symbol]))
+          Number))
+(define (foo s)
+  (match s
+    ;; match-expander: (s1 pat ...)
+    [(s1 (? number? the-a) the-b) (+ the-a (string-length the-b))]
+    ;; match-expander: (structure field-name …)
+    [(structure a c) (+ a (string-length (symbol->string c)))]))
+
+(define instances
+  (append
+   ;; identifier macro: s1, to pretend it's a function
+   (map s1
+        (range 5)
+        '("x" "xx" "xxx" "xxxx" "xxxxx"))
+   ;; macro: (s1 args …), to pretend it's a function call
+   (list (s1 42 "Why does six times nine equal forty two?"))
+   ;; macro: (structure [field : type] …), produces a bulder function
+   (map (structure [a : Number] [c : Symbol])
+        (reverse (range 5))
+        '(x xx xxx xxxx xxxxx))
+   ;; macro: (structure [field value] …) or (structure [field : type value]),
+   ;; produces an instance
+   (list (structure [a pi] [c 'three-fourteen]))))
+
+(check-equal? (map foo instances)
+              (append '(1 3 5 7 9)
+                      '(82)
+                      '(5 5 5 5 5)
+                      '(17.141592653589793)))

phc-adt-test/phc-adt/test/node-low-level-quick-test.rkt

@@ -0,0 +1,31 @@
+#lang typed/racket
+(require (lib "phc-adt/node-low-level.hl.rkt")
+         typed/rackunit
+         phc-toolkit
+         phc-adt)
+(adt-init "./mailing-list-example/adt-pre-declarations.rkt")
+
+(define-constructor foo-ct #:tag foo :)
+
+(check-not-exn
+ (λ ()
+   (equal-hash-code
+    (|(node foo values)| (delay (list 'a 'b 'c))
+                         (raw-node (vector (list 'a 'b 'c)) 0)))))
+
+(check-not-exn
+ (λ ()
+   (equal-secondary-hash-code
+    (|(node foo values)| (delay (list 'a 'b 'c))
+                         (raw-node (vector (list 'a 'b 'c)) 0)))))
+
+(check-true: (equal?
+              (|(node foo values)| (delay (list 'a 'b 'c))
+                                   (raw-node (vector (list 'a 'b 'c)) 0))
+              (|(node foo values)| (delay (list 'a 'b'c))
+                                   (raw-node (vector (list 'a 'b 'c)) 1))))
+(check-false: (equal?
+               (|(node foo values)| (delay (list 'a 'b 'c))
+                                    (raw-node (vector (list 'a 'b 'c)) 0))
+               (|(node foo values)| (delay (list 'a 'x 'c))
+                                    (raw-node (vector (list 'a 'x 'c)) 1))))

phc-adt-test/phc-adt/test/row-polymorphism/adt-pre-declarations.rkt

@@ -0,0 +1,24 @@
+#lang s-exp phc-adt/declarations
+(remembered! tagged-structure (foo a b c))
+(remembered! tagged-structure (tag b))
+(remembered! tagged-structure (foo b))
+(remembered! tagged-structure (foo a c))
+(remembered! tagged-structure (bar a b c))
+(remembered! tagged-structure (baz a b))
+(remembered! tagged-structure (qux b d))
+(remembered! tagged-structure (bar a c))
+(remembered! tagged-structure (baz a))
+(remembered! tagged-structure (qux d))
+(remembered! tagged-structure (bar b))
+(remembered! tagged-structure (baz b))
+(remembered! tagged-structure (qux b))
+(remembered! tagged-structure (foo d))
+(remembered! tagged-structure (foo a))
+(remembered! tagged-structure (foo a b))
+(remembered! tagged-structure (foo a))
+(remembered! tagged-structure (foo a b))
+(remembered! tagged-structure (foo b d))
+(remembered! tagged-structure (foo a b d))
+(remembered! tagged-structure (foo a b c d))
+(remembered! tagged-structure (foo a d))
+(remembered! tagged-structure (foo a c d))

phc-adt-test/phc-adt/test/row-polymorphism/test-merge.rkt

@@ -0,0 +1,40 @@
+#lang type-expander
+
+(require phc-adt phc-toolkit)
+(adt-init)
+
+(check-equal?:
+ (merge (tagged foo [b 'b1]) (tagged foo [a 'a1] [c 'c1])
+        : (U [(foo b) (foo a c)]))
+ : (tagged foo [a 'a1] [b 'b1] [c 'c1])
+ (tagged foo [a 'a1] [b 'b1] [c 'c1]))
+
+(check-equal?:
+ (merge (tagged bar [b 'b2]) (tagged bar [a 'a2] [c 'c2])
+        : (U [(bar b) (bar a c)] [(foo b) (foo a c)]))
+ : (tagged bar [a 'a2] [b 'b2] [c 'c2])
+ (tagged bar [a 'a2] [b 'b2] [c 'c2]))
+
+(check-equal?:
+ (merge (tagged baz [b 'b3]) (tagged baz [a 'a3])
+        : (U [(baz b) (baz a)] [(foo b) (foo a c)]))
+ : (tagged baz [a 'a3] [b 'b3])
+ (tagged baz [a 'a3] [b 'b3]))
+
+(check-equal?:
+ (merge (tagged qux [b 'b4]) (tagged qux [d 'd4])
+        : (U [(qux b) (qux d)] [(foo b) (foo a c)]))
+ : (tagged qux [b 'b4] [d 'd4])
+ (tagged qux [b 'b4] [d 'd4]))
+
+;; Different tags
+(check-equal?:
+ (merge (tagged qux [b 'b4]) (tagged foo [d 'd4])
+        : (U [(qux b) (foo d)] [(foo b) (foo a c)]))
+ : (tagged qux [b 'b4] [d 'd4])
+ (tagged qux [b 'b4] [d 'd4]))
+(check-equal?:
+ (merge (tagged qux [b 'b4]) (tagged foo [d 'd4])
+        : (U [(qux b) (foo d)] [(foo b) (foo a)]))
+ : (tagged qux [b 'b4] [d 'd4])
+ (tagged qux [b 'b4] [d 'd4]))

phc-adt-test/phc-adt/test/row-polymorphism/test-split.rkt

@@ -0,0 +1,25 @@
+#lang type-expander
+
+(require phc-adt phc-toolkit)
+(adt-init)
+
+(define-tagged foo [a : 'a1] [b : 'b1] [c : 'c1])
+(define-tagged bar [a : 'a2] [b : 'b2] [c : 'c2])
+(define-tagged baz [a : 'a3] [b : 'b3])
+(define-tagged qux           [b : 'b4] [d : 'd4])
+
+(let-values ([(x y) (split (foo 'a1 'b1 'c1) : (U (foo a b c)) b)])
+  (check-equal?: x : (tagged foo [b 'b1]) (tagged foo [b 'b1]))
+  (check-equal?: y : (tagged foo [a 'a1] [c 'c1]) (tagged foo [a 'a1] [c 'c1])))
+
+(let-values ([(x y) (split (bar 'a2 'b2 'c2) : (U (foo a b c) (bar a b c)) b)])
+  (check-equal?: x : (tagged bar [b 'b2]) (tagged bar [b 'b2]))
+  (check-equal?: y : (tagged bar [a 'a2] [c 'c2]) (tagged bar [a 'a2] [c 'c2])))
+
+(let-values ([(x y) (split (baz 'a3 'b3) : (U (foo a b c) (baz a b)) b)])
+  (check-equal?: x : (tagged baz [b 'b3]) (tagged baz [b 'b3]))
+  (check-equal?: y : (tagged baz [a 'a3]) (tagged baz [a 'a3])))
+
+(let-values ([(x y) (split (qux 'b4 'd4) : (U (foo a b c) (qux b d)) b)])
+  (check-equal?: x : (tagged qux [b 'b4]) (tagged qux [b 'b4]))
+  (check-equal?: y : (tagged qux [d 'd4]) (tagged qux [d 'd4])))

phc-adt-test/phc-adt/test/row-polymorphism/test-with-plus.rkt

@@ -0,0 +1,62 @@
+#lang type-expander
+
+(require phc-adt phc-toolkit)
+(adt-init)
+
+(check-equal?: (with+ (tagged foo [b 'b1]) : (U (foo b)))
+               : (tagged foo [b 'b1])
+               (tagged foo [b 'b1]))
+(check-equal?: (with+ (tagged foo [b 'b1]) : (U (foo b)) [a 'a1])
+               : (tagged foo [a 'a1] [b 'b1])
+               (tagged foo [a 'a1] [b 'b1]))
+(check-equal?: (with+ (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1] [c 'c1])
+               (tagged foo [a 'a1] [b 'b1] [c 'c1]))
+;; Correctly gave an error:
+;(check-equal?: (with+ (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [b 'b1-update])
+;               : (tagged foo [a 'a1] [b 'b1-update])
+;               (tagged foo [a 'a1] [b 'b1-update]))
+;(check-equal?: (with+ (tagged foo [b 'b1]) : (U (foo b)) [b 'b1-update])
+;               : (tagged foo [b 'b1-update])
+;               (tagged foo [b 'b1-update]))
+;(check-equal?: (with+ (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [b 'b1-update] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1])
+;               (tagged foo [a 'a1] [b 'b1-update] [c 'c1]))
+
+(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)))
+               : (tagged foo [b 'b1] [d 'd1])
+               (tagged foo [b 'b1] [d 'd1]))
+(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1])
+               : (tagged foo [a 'a1] [b 'b1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1] [d 'd1]))
+(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [b 'b1-update])
+;               : (tagged foo [a 'a1] [b 'b1-update] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [b 'b1-update])
+;               : (tagged foo [b 'b1-update] [d 'd1])
+;               (tagged foo [b 'b1-update] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [b 'b1-update] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1]))
+
+(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)))
+               : (tagged foo [b 'b1] [d 'd1])
+               (tagged foo [b 'b1] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1])
+;               : (tagged foo [a 'a1] [b 'b1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [b 'b1-update])
+;               : (tagged foo [a 'a1] [b 'b1-update] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [b 'b1-update])
+;               : (tagged foo [b 'b1-update] [d 'd1])
+;               (tagged foo [b 'b1-update] [d 'd1]))
+;(check-equal?: (with+ (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [b 'b1-update] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1]))

phc-adt-test/phc-adt/test/row-polymorphism/test-with-update-only.rkt

@@ -0,0 +1,65 @@
+#lang type-expander
+
+(require phc-adt phc-toolkit)
+(adt-init)
+
+;; Correctly gave an error:
+(check-equal?: (with!! (tagged foo [b 'b1]) : (U (foo b)))
+               : (tagged foo [b 'b1])
+               (tagged foo [b 'b1]))
+;(check-equal?: (with!! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1])
+;               : (tagged foo [a 'a1] [b 'b1])
+;               (tagged foo [a 'a1] [b 'b1]))
+;(check-equal?: (with!! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1] [c 'c1])
+;               (tagged foo [a 'a1] [b 'b1] [c 'c1]))
+;(check-equal?: (with!! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [b 'b1-update])
+;               : (tagged foo [a 'a1] [b 'b1-update])
+;               (tagged foo [a 'a1] [b 'b1-update]))
+(check-equal?: (with!! (tagged foo [b 'b1]) : (U (foo b)) [b 'b1-update])
+               : (tagged foo [b 'b1-update])
+               (tagged foo [b 'b1-update]))
+;(check-equal?: (with!! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [b 'b1-update] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1])
+;               (tagged foo [a 'a1] [b 'b1-update] [c 'c1]))
+
+(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)))
+               : (tagged foo [b 'b1] [d 'd1])
+               (tagged foo [b 'b1] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1])
+;               : (tagged foo [a 'a1] [b 'b1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [b 'b1-update])
+;               : (tagged foo [a 'a1] [b 'b1-update] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [d 'd1]))
+(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [b 'b1-update])
+               : (tagged foo [b 'b1-update] [d 'd1])
+               (tagged foo [b 'b1-update] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [b 'b1-update] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1]))
+
+(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)))
+               : (tagged foo [b 'b1] [d 'd1])
+               (tagged foo [b 'b1] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1])
+;               : (tagged foo [a 'a1] [b 'b1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [b 'b1-update])
+;               : (tagged foo [a 'a1] [b 'b1-update] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [b 'b1-update])
+;               : (tagged foo [b 'b1-update] [d 'd1])
+;               (tagged foo [b 'b1-update] [d 'd1]))
+;(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [b 'b1-update] [c 'c1])
+;               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1])
+;               (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1]))
+(check-equal?: (with!! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [d 'd1-update])
+               : (tagged foo [b 'b1] [d 'd1-update])
+               (tagged foo [b 'b1] [d 'd1-update]))

phc-adt-test/phc-adt/test/row-polymorphism/test-with.rkt

@@ -0,0 +1,61 @@
+#lang type-expander
+
+(require phc-adt phc-toolkit)
+(adt-init)
+
+(check-equal?: (with! (tagged foo [b 'b1]) : (U (foo b)))
+               : (tagged foo [b 'b1])
+               (tagged foo [b 'b1]))
+(check-equal?: (with! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1])
+               : (tagged foo [a 'a1] [b 'b1])
+               (tagged foo [a 'a1] [b 'b1]))
+(check-equal?: (with! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1] [c 'c1])
+               (tagged foo [a 'a1] [b 'b1] [c 'c1]))
+(check-equal?: (with! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [b 'b1-update])
+               : (tagged foo [a 'a1] [b 'b1-update])
+               (tagged foo [a 'a1] [b 'b1-update]))
+(check-equal?: (with! (tagged foo [b 'b1]) : (U (foo b)) [b 'b1-update])
+               : (tagged foo [b 'b1-update])
+               (tagged foo [b 'b1-update]))
+(check-equal?: (with! (tagged foo [b 'b1]) : (U (foo b)) [a 'a1] [b 'b1-update] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1])
+               (tagged foo [a 'a1] [b 'b1-update] [c 'c1]))
+
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)))
+               : (tagged foo [b 'b1] [d 'd1])
+               (tagged foo [b 'b1] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1])
+               : (tagged foo [a 'a1] [b 'b1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [b 'b1-update])
+               : (tagged foo [a 'a1] [b 'b1-update] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1-update] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [b 'b1-update])
+               : (tagged foo [b 'b1-update] [d 'd1])
+               (tagged foo [b 'b1-update] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d)) [a 'a1] [b 'b1-update] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1]))
+
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)))
+               : (tagged foo [b 'b1] [d 'd1])
+               (tagged foo [b 'b1] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1])
+               : (tagged foo [a 'a1] [b 'b1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1] [c 'c1] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [b 'b1-update])
+               : (tagged foo [a 'a1] [b 'b1-update] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1-update] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [b 'b1-update])
+               : (tagged foo [b 'b1-update] [d 'd1])
+               (tagged foo [b 'b1-update] [d 'd1]))
+(check-equal?: (with! (tagged foo [b 'b1] [d 'd1]) : (U (foo b d) (foo a d)) [a 'a1] [b 'b1-update] [c 'c1])
+               : (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1])
+               (tagged foo [a 'a1] [b 'b1-update] [c 'c1] [d 'd1]))

phc-adt-test/phc-adt/test/test-adt-init-error.rkt

@@ -0,0 +1,18 @@
+#lang typed/racket
+
+(require phc-adt
+         syntax/macro-testing
+         typed/rackunit
+         type-expander)
+
+(define compile-time-exception-regexp
+  #px"phc-adt: adt-init must be called before using the features in phc-adt")
+(check-exn compile-time-exception-regexp
+           (λ () (convert-compile-time-error
+                  (tagged tg [x "x"] [y 2]))))
+(check-exn compile-time-exception-regexp
+           (λ () (convert-compile-time-error
+                  (match '() [(tagged tg x y) 'a] [_ 'b]))))
+(check-exn compile-time-exception-regexp
+           (λ () (convert-compile-time-error
+                  (let () (define-type foo (tagged tg x y)) 1))))

phc-adt-test/phc-adt/test/test-adt-init-no-error.rkt

@@ -0,0 +1,11 @@
+#lang typed/racket
+
+(require phc-adt
+         syntax/macro-testing
+         typed/rackunit
+         type-expander)
+
+(adt-init)
+(check-not-exn (λ () (tagged t1 [x "x"] [y "2"])))
+(check-not-exn (λ () (match '() [(tagged tg x y) 'a] [_ 'b])))
+(check-not-exn (λ () (let () (define-type foo (tagged tg x y)) 1)))

phc-adt-test/phc-adt/test/test-adt-structure-wrapped.rkt

@@ -0,0 +1,18 @@
+#lang typed/racket
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                  λ-tagged-get-field))
+(adt-init)
+
+(define i (structure [a 1 : Number] [b "b" : String]))
+(define c (structure [a : Number] [b : String]))
+(define i2 (c 1 "b"))
+
+(check-equal?: (uniform-get i a) : Number 1)
+(check-equal?: (uniform-get i b) : String "b")
+(check-equal?: (uniform-get i2 a) : Number 1)
+(check-equal?: (uniform-get i2 b) : String "b")

phc-adt-test/phc-adt/test/test-adt.rkt

@@ -0,0 +1,22 @@
+#lang typed/racket
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                  λ-tagged-get-field))
+(adt-init)
+
+(define-tagged st2 [b String] [a Number])
+
+((tagged t a b c) 1 'b "c")
+((tagged t a [b] c) 1 'b "c")
+((tagged t [a] [b] [c]) 1 'b "c")
+((tagged t [a : Number] [b : Symbol] [c : String]) 1 'b "c")
+(tagged t [a : Number 1] [b : Symbol 'b] [c : String "c"])
+(tagged t [a 1] [b 'b] [c "c"])
+
+(tagged t [a 1] [b 'b] [c "c"])
+
+(define-tagged tabc [a 1] [b 'b] [c "c"])

phc-adt-test/phc-adt/test/test-constructor.rkt

@@ -0,0 +1,126 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander typed/rackunit)
+(adt-init)
+
+; (_ name:id *)
+(check-not-exn
+ (λ ()
+   (ann (constructor tag1 *)
+        (∀ (A ...) (→ A ... A (tagged tag1 [values (List A ... A)]))))))
+
+(check-equal?: (constructor-values
+                (ann ((constructor tag1 *))
+                     (constructor tag1)))
+               '())
+(check-equal?: (constructor-values
+                (ann ((constructor tag1 *) 1)
+                     (constructor tag1 One)))
+               '(1))
+(check-equal?: (constructor-values
+                (ann ((constructor tag1 *) 1 "b")
+                     (constructor tag1 Number String)))
+               '(1 "b"))
+(check-equal?: (constructor-values
+                (ann ((constructor tag1 *) 1 "b" 'c)
+                     (constructor tag1 Number String 'c)))
+               '(1 "b" c))
+
+; (_ name:id :colon)
+(check-not-exn (λ () (ann (constructor tag1 :)
+                          (→ (constructor tag1)))))
+
+; (_ name:id :colon T₀:expr)
+(check-not-exn (λ () (ann (constructor tag1 : Number)
+                          (→ Number (constructor tag1 Number)))))
+
+; (_ name:id :colon Tᵢ:expr …+)
+(check-not-exn
+ (λ () (ann (constructor tag1 : Number String)
+            (→ Number String (constructor tag1 Number String)))))
+(check-not-exn
+ (λ () (ann (constructor tag1 : Number String 'c)
+            (→ Number String 'c (constructor tag1 Number String 'c)))))
+
+; Call (_ name:id :colon)
+(check-equal?: (constructor-values (ann ((constructor tag1 :))
+                                        (constructor tag1)))
+               '())
+
+; Call (_ name:id :colon T₀:expr)
+(check-equal?: (constructor-values (ann ((constructor tag1 : Number) 1)
+                                        (constructor tag1 Number)))
+               '(1))
+
+; Call (_ name:id :colon Tᵢ:expr …+)
+(check-equal?: (constructor-values
+                (ann ((constructor tag1 : Number String) 1 "b")
+                     (constructor tag1 Number String)))
+               '(1 "b"))
+(check-equal?: (constructor-values
+                (ann ((constructor tag1 : Number String 'c) 1 "b" 'c)
+                     (constructor tag1 Number String 'c)))
+               '(1 "b" c))
+
+; (_ name:id [val₀:expr :colon T₀:expr])
+(check-equal?: (constructor-values
+                (ann (constructor tag1 [1 : One])
+                     (constructor tag1 One)))
+               '(1))
+
+; (_ name:id [valᵢ:expr :colon Tᵢ:expr] …)
+(check-equal?: (constructor-values
+                (ann (constructor tag1 [1 : One] ["b" : (U "b" "B")])
+                     (constructor tag1 One (U "b" "B"))))
+               '(1 "b"))
+
+; (_ name:id val₀:expr)
+(check-equal?: (constructor-values
+                (ann (constructor tag1 "a")
+                     (constructor tag1 String)))
+               '("a"))
+
+; (_ name:id valᵢ:expr …)
+(check-equal?: (constructor-values
+                (ann (constructor tag1 "a" "b")
+                     (constructor tag1 String String)))
+               '("a" "b"))
+(check-equal?: (constructor-values
+                (ann (constructor tag1 "a" "b" 'c)
+                     (constructor tag1 String String Symbol)))
+               '("a" "b" c))
+
+(check-equal?: (constructor-values
+                (constructor tag1 "a" #(#\b 3) #t . "a"))
+               : (List* "a" (Vector Char 3) #t "a")
+               '("a" #(#\b 3) #t . "a"))
+
+(check-equal?: (constructor-values
+                (constructor tag1 "a" #(#\b 3) #t . #\b))
+               : (List* "a" (Vector Char 3) #t Char)
+               '("a" #(#\b 3) #t . #\b))
+
+(check-equal?: (constructor-values
+                (constructor tag1 "a" #(#\b 3) #t . 3))
+               : (List* "a" (Vector Char 3) #t 3)
+               '("a" #(#\b 3) #t . 3))
+
+(check-equal?: (constructor-values
+                (constructor tag1 "a" #(#\b 3) #t . #t))
+               : (List* "a" (Vector Char 3) #t #t)
+               '("a" #(#\b 3) #t . #t))
+
+(check-equal?: (constructor-values
+                (constructor tag1 "a" #(#\b 3) #t . #("x" #\y 26 #f)))
+               : (List* "a" (Vector Char 3) #t (Vector "x" Char 26 #f))
+               '("a" #(#\b 3) #t . #("x" #\y 26 #f)))
+
+(check-equal?: (constructor-values
+                (constructor tag1 "a" #(#\b 3) #t #("x" #\y 26 #f) . 123))
+               : (List* "a" (Vector Char 3) #t (Vector "x" Char 26 #f) 123)
+               '("a" #(#\b 3) #t #("x" #\y 26 #f) . 123))
+
+(check-equal?: (constructor-values
+                (constructor tag1 "a" #(#\b 3) #t #("x" #\y 26 #f)))
+               : (List "a" (Vector Char 3) #t (Vector "x" Char 26 #f))
+               '("a" #(#\b 3) #t #("x" #\y 26 #f)))

phc-adt-test/phc-adt/test/test-constructor2.rkt

@@ -0,0 +1,33 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander typed/rackunit)
+(adt-init)
+  
+(check-equal?: (constructor-values
+                (ann (constructor a 1 "x")
+                     ;; TODO: Make a (Constructor-AnyTag …) type expander.
+                     (tagged a [values (List Number String)])))
+               (list 1 "x"))
+(check-equal?: (constructor-values
+                (ann (constructor a 1 "x")
+                     (tagged a [values Any])))
+               (list 1 "x"))
+(check-equal?: (constructor-values
+                (ann (constructor a 1 "x")
+                     (constructor a Number String)))
+               (list 1 "x"))
+(check-equal?: (constructor-values
+                (ann (constructor b)
+                     (constructor b)))
+               (list))
+(check-equal?: (constructor-values
+                (ann (constructor c 'd)
+                     (constructor c Symbol)))
+               '(d))
+(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"))

phc-adt-test/phc-adt/test/test-constructor3.rkt

@@ -0,0 +1,69 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander typed/rackunit)
+(adt-init)
+
+;; define-constructor
+(define-constructor tag0 :)
+(define-constructor tag1 : Number)
+(define-constructor tag2 : Number String)
+(define-constructor tag3 : Number String 'c)
+
+;; Type expander
+(check-equal?: (constructor-values (ann (constructor tag0) tag0))
+               '())
+(check-equal?: (constructor-values (ann (constructor tag1 1) tag1))
+               '(1))
+(check-equal?: (constructor-values (ann (constructor tag2 1 "b") tag2))
+               '(1 "b"))
+(check-equal?: (constructor-values
+                (ann (constructor tag3 1 "b" (ann 'c 'c)) tag3))
+               '(1 "b" c))
+
+;; Call
+(check-equal?: (constructor-values (ann (tag0) (constructor tag0)))
+               '())
+(check-equal?: (constructor-values (ann (tag1 1) (constructor tag1 Number)))
+               '(1))
+(check-equal?: (constructor-values
+                (ann (tag2 1 "b") (constructor tag2 Number String)))
+               '(1 "b"))
+(check-equal?: (constructor-values
+                (ann (tag3 1 "b" 'c) (constructor tag3 Number String 'c)))
+               '(1 "b" c))
+
+;; Id
+(check-not-exn (λ () (ann tag0 (→ (constructor tag0)))))
+(check-not-exn (λ () (ann tag1 (→ Number (constructor tag1 Number)))))
+(check-not-exn
+ (λ () (ann tag2 (→ Number String (constructor tag2 Number String)))))
+(check-not-exn
+ (λ () (ann tag3 (→ Number String 'c (constructor tag3 Number String 'c)))))
+
+;; Match expander
+(check-equal?: (ann (match (constructor tag0) [(tag0) #t]) #t)
+               #t)
+(check-equal?: (ann (match (constructor tag1 1) [(tag1 x) (list x)])
+                    (List Number))
+               '(1))
+(check-equal?: (ann (match (constructor tag2 1 "b") [(tag2 x y) (list y x)])
+                    (List String Number))
+               '("b" 1))
+(check-equal?: (ann (match (constructor tag3 1 "b" (ann 'c 'c))
+                      [(tag3 x y z) (list z y x)])
+                    (List 'c String Number))
+               '(c "b" 1))
+
+;; Match expander which single pattern
+(check-equal?: (ann (match (constructor tag0) [(tag0 #:rest whole) whole]) Null)
+               '())
+(check-equal?: (ann (match (constructor tag1 1) [(tag1 x) x])
+                    Number)
+               '1)
+(check-equal?: (ann (match (constructor tag2 1 "b") [(tag2 x y) (list x y)])
+                    (List Number String))
+               '(1 "b"))
+(check-equal?: (ann (match (constructor tag3 1 "b" (ann 'c 'c))
+                      [(tag3 x y z) (list x y z)])
+                    (List Number String 'c))
+               '(1 "b" c))

phc-adt-test/phc-adt/test/test-define-adt.rkt

@@ -0,0 +1,195 @@
+#lang typed/racket
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                  λ-tagged-get-field))
+(adt-init)
+
+;(define-constructor c2 : Fixnum String)
+
+;; define-tagged
+(begin
+  (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")))
+
+;; define-constructor
+(begin
+  (define-constructor c1 :)
+  (define-constructor c2 : Fixnum String)
+  (define-constructor c3 : Fixnum String)
+    
+  (check-equal?: (match (ann (c1) (constructor c1))
+                   [(c1) #t])
+                 #t)
+    
+  (check-equal?: (match (ann (c2 99 "z") c2)
+                   [(c2 f g) (cons g f)])
+                 '("z" . 99))
+    
+  (let ()
+    (check-equal?: (match (ann (c2 99 "in-let") c2)
+                     [(c2 f g) (cons g f)])
+                   '("in-let" . 99)))
+    
+  (define (test-c-match val)
+    (match val
+      [(c1) (list 'found-c1)]
+      [(constructor c2 x y z) (list 'found-c2-xyz z y x)]
+      [(c2 x y) (list 'found-c2 y x)]
+      [(c3 x y) (list 'found-c3 y x)]))
+    
+  (check-equal?:
+   (test-c-match (ann (c2 2 "flob")
+                      (constructor c2 Fixnum String)))
+   '(found-c2 "flob" 2))
+    
+  (check-equal?:
+   (test-c-match (ann (c3 2 "flob")
+                      (constructor c3 Fixnum String)))
+   '(found-c3 "flob" 2)))
+
+;; define-tagged (used to use #:private, updated the tests now that the option
+;; was removed).
+(begin
+  (define-syntax-rule (defp make mt)
+    (begin
+      (define-tagged txyz #:? txyz?
+        [a Number]
+        [b String])
+        
+      (define (make) (txyz 1 "b"))
+        
+      (define (mt v)
+        (match v
+          ((txyz x y) (list 'macro y x))
+          (_ #f)))))
+    
+  (defp make mt)
+    
+  (define-tagged txyz #:? txyz?
+    [a Number]
+    [b String])
+    
+  (check-equal?: (match (make)
+                   ((tagged txyz x y) (list 'out y x))
+                   (_ #f))
+                 #f)
+    
+  (check-equal?: (mt (tagged txyz [x 1] [y "b"]))
+                 #f)
+    
+  (check-equal?: (mt (make))
+                 '(macro "b" 1))
+    
+  (check-equal?: (make) (txyz 1 "b"))
+  (check-equal?: (match (make)
+                   ((txyz x y) (list 'out y x))
+                   (_ #f))
+                 '(out "b" 1))
+    
+  (check-equal?: (mt (txyz 1 "b"))
+                 '(macro "b" 1)))
+  
+;; define-constructor #:private
+(begin
+  (define-syntax-rule (defpc makec mtc)
+    (begin
+      (define-constructor cxyz #:? cxyz? : Number String)
+        
+      (define (makec) (cxyz 1 "b"))
+        
+      (define (mtc v)
+        (match v
+          ((cxyz x y) (list 'macro y x))
+          (_ #f)))))
+    
+  (defpc makec mtc)
+    
+  (define-constructor cxyz #:? cxyz? : Number String)
+    
+  (check-equal?: (match (makec)
+                   ((constructor cxyz e f) (list 'out f e))
+                   (_ #f))
+                 '(out "b" 1))
+    
+  (check-equal?: (mtc (constructor cxyz 1 "b"))
+                 '(macro "b" 1))
+    
+  (check-equal?: (mtc (makec))
+                 '(macro "b" 1))
+    
+  (check-equal?: (makec) (cxyz 1 "b"))
+  (check-equal?: (match (makec)
+                   ((cxyz e f) (list 'out f e))
+                   (_ #f))
+                 '(out "b" 1))
+    
+  (check-equal?: (mtc (cxyz 1 "b"))
+                 '(macro "b" 1)))

phc-adt-test/phc-adt/test/test-empty.rkt

@@ -0,0 +1,104 @@
+#lang typed/racket
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                  λ-tagged-get-field))
+(adt-init)
+
+(define-structure empty-st)
+(define-tagged empty-tg)
+(define-constructor empty-ct :)
+(define-constructor empty-ct-t2 #:tag empty-ct ::)
+(define-constructor empty-ct-t3 #:tag empty-ct !)
+(define-constructor empty-ct-2 ::)
+(define-constructor empty-ct-3 !)
+
+;(ann empty-ct (→ (constructor empty-ct)))
+;(ann (empty-ct) (constructor empty-ct))
+(check-equal?: (if (match (constructor empty-ct)
+                     [(empty-ct) #t]
+                     [_ #f])
+                   #t
+                   #f)
+               : #t
+               #t)
+;(ann (constructor empty-ct) empty-ct)
+(check-ann empty-ct?
+           (→ Any Boolean : (constructor empty-ct)))
+(check-equal?: (if (empty-ct? (constructor empty-ct)) #t #f)
+               : #t
+               #t)
+
+(check-ann (structure #:builder)
+           (→ (structure)))
+(check-ann (tagged empty-tg #:builder)
+           (→ (tagged empty-tg)))
+(check-ann (constructor empty-ct :)
+           (→ (constructor empty-ct)))
+(check-ann (constructor empty-ct ::)
+           (→ Null (constructor empty-ct)))
+(check-ann (constructor empty-ct !)
+           (→ Any * (constructor empty-ct)))
+
+(check-true: (match ((constructor empty-ct :))
+               [(tagged empty-ct [values '()]) #t]
+               [_ #f]))
+
+(check-true: (match ((constructor empty-ct ::) null)
+               [(tagged empty-ct [values '()]) #t]
+               [_ #f]))
+
+(check-true: (match ((constructor empty-ct !))
+               [(tagged empty-ct [values '()]) #t]
+               [_ #f]))
+
+(check-true: (match (constructor empty-ct)
+               [(tagged empty-ct [values '()]) #t]
+               [_ #f]))
+
+(check-ann (let ([v ((constructor empty-ct ::) null)])
+             (if ((|(tagged-cast-predicate empty-ct values)|
+                   (make-predicate Null))
+                  v)
+                 v
+                 #f))
+           (constructor empty-ct))
+
+;; result type should be (constructor empty-ct . Number)
+(check-ann (constructor empty-ct . #{1 : Number})
+           (constructor empty-ct . Number))
+(check-ann (constructor empty-ct #:rest 1 : Number)
+           (constructor empty-ct . Number))
+
+(check-ann (constructor empty-ct . 1)
+           (constructor empty-ct . 1))
+(check-ann (constructor empty-ct #:rest 1)
+           (constructor empty-ct . 1))
+(check-ann (constructor empty-ct #:rest (list 1 2))
+           (constructor empty-ct Number Number))
+
+(check-ann (constructor empty-ct 1)
+           (constructor empty-ct 1))
+(check-ann (constructor empty-ct [1 : Number])
+           (constructor empty-ct Number))
+(check-ann (constructor empty-ct)
+           (constructor empty-ct))
+(check-ann (constructor empty-ct)
+           (tagged empty-ct [values Null]))
+
+(check-equal?-classes:
+ [(constructor empty-ct . #{1 : Number})
+  (constructor empty-ct #:rest 1 : Number)
+  (constructor empty-ct . 1)
+  (constructor empty-ct #:rest 1)]
+ [(constructor empty-ct #:rest (list 1 2))]
+ [(constructor empty-ct 1)
+  (constructor empty-ct [1 : Number])]
+ [(constructor empty-ct)
+  (constructor empty-ct . #{null : Null})
+  (constructor empty-ct #:rest null : Null)
+  (constructor empty-ct . null)
+  (constructor empty-ct #:rest null)])

phc-adt-test/phc-adt/test/test-structure-low-level.rkt

@@ -0,0 +1,104 @@
+#lang typed/racket
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+         (for-syntax phc-toolkit/untyped))
+(adt-init)
+
+;; TODO: test all these with unsorted fields too.
+
+;; Inferred type
+(define-syntax (test-structure-infer-type stx)
+  (syntax-case stx ()
+    [(_ name . fields)
+     (quasisyntax/top-loc stx
+       (define-type name #,(tagged-infer-type! #'(untagged . fields))))]))
+
+(test-structure-infer-type test0 test-fa test-fb)
+(test-structure-infer-type test1)
+
+;; Explicit type
+(define-syntax (test-structure-type stx)
+  (syntax-case stx ()
+    [(_ name [field _ type] …)
+     (quasisyntax/top-loc stx
+       (define-type name #,(tagged-type! #'(untagged [field type] …))))]))
+
+(test-structure-type test2 [test-fa : Number] [test-fb : String])
+
+;; Builders. Assigning them to a variable can fail at compile-time if TR does
+;; not see the type properly because it has the wrong scopes).
+(define c3 (structure #:builder))
+(define c4 (structure #:builder [test-fa : Number] [test-fb : String]))
+(define c6 (structure #:builder [test-fa : Number] [test-fc : Number]))
+(define c5 (structure #:builder test-fa test-fb))
+
+;; Call constructors, and check the return type
+(check-not-exn (λ () (ann (c3) test1)))
+(let ([i4 (c4 7 "ee")]
+      [i5 (c5 8 "ff")])
+  (check-not-exn (λ () (ann i4 test2)))
+  (check-not-exn (λ () (ann i5 test2)))
+  (check-not-exn (λ () (ann i4 (test0 Number String))))
+  (check-not-exn (λ () (ann i5 (test0 Number String)))))
+
+;; TODO: bug report because using directly (ann v #t) does not work, but
+;; wrapping it with a no-op if does work.
+(define-syntax-rule (check-true-type v)
+  (check-equal?: (if (ann v Boolean) #t #f)
+                 : #t
+                 #t))
+
+(define-syntax-rule (check-false-type v)
+  (check-false (ann (if (ann v Boolean) #t #f)
+                    #f)))
+
+(let ([i4 (c4 7 "ee")]
+      [i5 (c5 8 "ff")])
+  (check-true-type ((structure? test-fa test-fb) i4))
+  (check-true-type ((structure? test-fa test-fb) i5))
+  (check-false-type ((structure?) i4))
+  (check-true-type ((structure?) (c3)))
+  (check-false-type ((structure? test-fa test-fb) (c3))))
+
+;; Predicate
+
+(check-equal?: (tagged-get-field (c4 7 "ee") test-fa 'else)
+               : Number
+               7)
+(check-equal?: (tagged-get-field (c5 7 "ee") test-fb 'else)
+               : String
+               "ee")
+(check-equal?: ((λ-tagged-get-field test-fa) (c4 7 "ee"))
+               : Number
+               7)
+(check-equal?: ((λ-tagged-get-field test-fb) (c5 7 "ee"))
+               : String
+               "ee")
+
+;; Match-expander
+(define-match-expander test-structure-match
+  (λ/syntax-case (_ [field pat …] …) ()
+    (quasisyntax/loc stx
+      #,(tagged-match! #'(untagged [field (and pat …)] …)))))
+
+(check-equal?: (match (c5 7 "ee")
+                 [(test-structure-match [test-fa x] [test-fb y])
+                  (list y x)])
+               : (List String Number)
+               '("ee" 7))
+
+;; Supertypes
+(define-syntax (test-supertypes stx)
+  (syntax-case stx ()
+    [(_ . fields)
+     #`'#,(map cdr (has-fields #'fields))]))
+
+(check-true (set=?
+             (list->set (test-supertypes test-fa))
+             (set '(untagged test-fa test-fb)
+                  '(untagged test-fa test-fc)
+                  '(untagged test-fa test-fd))))

phc-adt-test/phc-adt/test/test-structure-other.rkt

@@ -0,0 +1,10 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander typed/rackunit)
+(adt-init)
+
+(provide i-other t-other c-other)
+
+(define i-other (structure [test-fa "a"] [test-fb (ann 'b 'b)]))
+(define-type t-other (structure [test-fa Number] [test-fc 'c]))
+(define c-other (structure [test-fa : Number] [test-fd : 'd]))

phc-adt-test/phc-adt/test/test-structure-parametric.rkt

@@ -0,0 +1,22 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander typed/rackunit "ck.rkt")
+(adt-init)
+
+(define-structure #:∀ (T) a [a : T] [b : T])
+(check-print-type (a 3 "b") "((tagged untagged a b) (U Positive-Byte String) (U Positive-Byte String))")
+
+(define-structure b #:∀ (T) [a : T] [b : T])
+(define-structure c [a : T] [b : T] #:∀ (T))
+
+(define printed-type
+  "((tagged untagged a b) (U Positive-Byte String) (U Positive-Byte String))")
+
+(check-print-type (a 3 "b") printed-type)
+(check-ann (a 3 4) (structure [a Positive-Byte] [b Positive-Byte]))
+
+(check-print-type (b 3 "b") printed-type)
+(check-ann (b 3 4) (structure [a Positive-Byte] [b Positive-Byte]))
+
+(check-print-type (c 3 "b") printed-type)
+(check-ann (c 3 4) (structure [a Positive-Byte] [b Positive-Byte]))

phc-adt-test/phc-adt/test/test-structure-speed.rkt

@@ -0,0 +1,23 @@
+#lang typed/racket/base
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (for-syntax racket/base
+                     syntax/stx
+                     racket/list))
+(adt-init)
+
+(define-syntax (repeat-stx stx)
+  (syntax-case stx ()
+    [(_ n expr)
+     (number? (syntax-e #'n))
+     #`(begin . #,(stx-map (λ _ #'expr)
+                           (range (syntax-e #'n))))]))
+
+(repeat-stx 1 (check-not-exn (λ () (structure [test-fa 2 : Number]
+                                              [test-fb "b" : String]))))
+
+;(repeat-stx 1024 (check-not-exn (λ () (structure [test-fa 2 : Number]
+;                                                 [test-fb "b" : String]))))

phc-adt-test/phc-adt/test/test-structure.rkt

@@ -0,0 +1,153 @@
+#lang typed/racket
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                  λ-tagged-get-field))
+(adt-init)
+
+;; define-structure
+(define-structure named1 test-fa test-fb)
+(define-structure named2 test-fb test-fa)
+(define-structure named3 test-fa test-fc)
+
+(check-equal?-classes:
+ [#:name "named1 ∪ named2"
+  : (named1 'a 'b)
+  (ann (named1 (ann 'a 'a) (ann 'b 'b)) (named1 'a 'b))
+  (ann (named1 (ann 'a 'a) (ann 'b 'b)) (structure [test-fa 'a] [test-fb 'b]))
+  (ann (named1 (ann 'a 'a) (ann 'b 'b)) ((structure [test-fa] test-fb) 'a 'b))
+  (ann (named2 (ann 'b 'b) (ann 'a 'a)) (named2 'b 'a))
+  (ann (named2 (ann 'b 'b) (ann 'a 'a)) (structure [test-fa 'a] [test-fb 'b]))
+  (ann (named2 (ann 'b 'b) (ann 'a 'a)) ((structure [test-fa] test-fb) 'a 'b))]
+ [#:name "named3"
+  : (named3 'a 'b)
+  (ann (named3 (ann 'a 'a) (ann 'b 'b)) (named3 'a 'b))
+  (ann (named3 (ann 'a 'a) (ann 'b 'b)) (structure [test-fa 'a] [test-fc 'b]))
+  (ann (named3 (ann 'a 'a) (ann 'b 'b)) ((structure [test-fa] test-fc) 'a 'b))])
+
+(check-equal?: (match (named1 (ann 'a 'a) (ann 'b 'b))
+                 [(named1 fa fb) (list fb fa)])
+               : (List 'b 'a)
+               '(b a))
+
+;; Types
+(define-type t0 (structure [test-fa Number] [test-fb String]))
+(define-type t1 (structure))
+
+(define i2 (structure [test-fa 1] [test-fb "a"]))
+(define i3 (structure #:instance))
+
+(check-not-exn (λ () (ann i2 t0)))
+(check-not-exn (λ () (ann i3 t1)))
+
+(check-not-exn (λ () (ann i2 StructureTop)))
+(check-not-exn (λ () (ann i3 StructureTop)))
+
+(check-true (StructureTop? i2))
+(check-true (StructureTop? i3))
+
+;; Instance and make-instance
+(define c4 (structure test-fa test-fb))
+(define c5 (structure [test-fa : Number] [test-fb : String]))
+(define-type test-fa+test-fb (structure [test-fa Number] [test-fb String]))
+(check-equal?-classes:
+ [#:name "test-fa+test-fb"
+  : test-fa+test-fb
+  ((structure test-fa test-fb) 2 "b")
+  ((structure [test-fa] test-fb) 2 "b")
+  ((structure test-fa [test-fb]) 2 "b")
+  ((structure [test-fa] [test-fb]) 2 "b")
+             
+  (structure [test-fa 2] [test-fb "b"])
+
+  ((structure [test-fa : Number] [test-fb : String]) 2 "b")
+
+  (structure [test-fa 2 : Number] [test-fb "b" : String])
+  
+  ((structure test-fb test-fa) "b" 2)
+  ((structure test-fb [test-fa]) "b" 2)
+  ((structure [test-fb] test-fa) "b" 2)
+  ((structure [test-fb] [test-fa]) "b" 2)
+             
+  (structure [test-fb "b"] [test-fa 2])
+
+  ((structure [test-fb : String] [test-fa : Number]) "b" 2)
+
+  (structure [test-fb "b" : String] [test-fa 2 : Number])])
+
+;; Accessor
+(check-equal?: ((λ-tagged-get-field test-fb) (c4 7 "ee"))
+               : String
+               "ee")
+(check-equal?: ((λ-tagged-get-field test-fb) (c5 7 "ee"))
+               : String
+               "ee")
+
+;; Match
+((inst check-equal?-classes (List String Number))
+ (cons
+  "match"
+  (list
+   ;; Simple
+   (match (c4 7 "ee") [(structure [test-fa fa] [test-fb fb]) (list fb fa)])
+   ;; Change order in the struct definition
+   (match (c4 7 "ee") [(structure [test-fb fb] [test-fa fa]) (list fb fa)])
+   ;; No patterns
+   (match (c4 7 "ee") [(structure [test-fb] [test-fa]) (list test-fb test-fa)])
+   (match (c4 7 "ee") [(structure test-fb test-fa) (list test-fb test-fa)]))))
+
+;; supertypes:
+
+(define fn1 (ann (λ (x) x)
+                 (→ (structure-supertype [test-fa Number])
+                    (structure-supertype [test-fa Number]))))
+(check-not-exn
+ (λ ()
+   (ann fn1
+        (→ (U (structure-supertype [test-fa Number] [test-fb Any])
+              (structure-supertype [test-fa Number] [test-fc Any])
+              (structure-supertype [test-fa Number] [test-fd Any]))
+           (U (structure-supertype [test-fa Number] [test-fb Any])
+              (structure-supertype [test-fa Number] [test-fc Any])
+              (structure-supertype [test-fa Number] [test-fd Any]))))))
+
+(define fn2 (ann (λ (x) x)
+                 (→ ((structure-supertype test-fa) Number)
+                    ((structure-supertype test-fa) Number))))
+(check-not-exn
+ (λ ()
+   (ann fn2
+        (→ (U (structure-supertype [test-fa Number] [test-fb Any])
+              (structure-supertype [test-fa Number] [test-fc Any])
+              (structure-supertype [test-fa Number] [test-fd Any]))
+           (U (structure-supertype [test-fa Number] [test-fb Any])
+              (structure-supertype [test-fa Number] [test-fc Any])
+              (structure-supertype [test-fa Number] [test-fd Any]))))))
+
+(check-not-exn (λ () (ann (structure [test-fa 7] [test-fb 'x])
+                          (structure-supertype [test-fa Number]))))
+
+(check-not-exn (λ () (ann (structure [test-fa 8] [test-fc 42])
+                          ((structure-supertype [test-fa]) Number))))
+
+(check-not-exn (λ () (ann (structure [test-fa 8] [test-fd "blob"])
+                          ((structure-supertype test-fa) Number))))
+
+(check-equal?: (match (structure [test-fa 8] [test-fc 'y])
+                 [(structure-supertype [test-fa x]) (+ x 1)])
+               : Number
+               9)
+
+;; Exchange structures across files (values, types …)
+(require "test-structure-other.rkt")
+
+(check-equal? (ann i-other (structure [test-fa String] [test-fb 'b]))
+              (structure [test-fa "a"] [test-fb (ann 'b 'b)]))
+
+(check-not-exn (λ () (ann (structure [test-fa 1] [test-fc 'c]) t-other)))
+
+(check-equal? (c-other 7 'd)
+              (structure [test-fa 7 : Number] [test-fd 'd : 'd]))

phc-adt-test/phc-adt/test/test-structure2.rkt

@@ -0,0 +1,150 @@
+#lang typed/racket
+
+(require phc-adt
+         phc-toolkit
+         type-expander
+         typed/rackunit
+         (only-in (lib "phc-adt/tagged-structure-low-level.hl.rkt")
+                  λ-tagged-get-field))
+(adt-init)
+
+(define-tagged empty-tg)
+
+;; structure-get field
+(begin
+  (check-equal?:
+   (uniform-get ((structure #:builder a b c d) 1 "b" 'val-c 4) c)
+   : 'val-c
+   'val-c))
+
+;; match-expander
+(begin
+  (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
+                    ((structure #:builder a b c d) 1
+                                                   "b"
+                                                   'value-c
+                                                   4))
+                   '(1 "b" value-c 4))
+    (check-equal?: (test-match
+                    ((structure #:builder a b c y) 1 2 3 4))
+                   '(1 2 3 4))
+    (check-equal?: (test-match 'bad) 'other)))
+  
+;; type-expander
+(begin
+  (check-equal?:
+   (uniform-get (ann ((structure #:builder a b c) 1 "b" #t)
+                       (structure [a Number] [c Boolean] [b String]))
+                  b)
+   "b"))
+
+;; structure
+(begin
+  (let ()
+    (define-structure empty-st)
+    (define-structure stA [a Number])
+    ;; BUG 137 (check-equal?: (empty-st) ((structure #:builder)))
+    (check-not-equal?: (empty-st) (structure [a 1]))
+    (check-not-equal?: (structure #:builder) (structure [a 1]))
+    (check-not-equal?: (empty-st) (stA 1))
+    (check-not-equal?: (structure #:builder) (stA 1))
+    (void))
+    
+  ;; TODO: uncomment these tests:
+  (let ()
+    (define-structure st [a Number] [b String])
+    (define-structure stA [a Number])
+    (define-structure stABC [a Number] [b String] [c Number])
+    (define st1 (st 1 "b"))
+    (define st2 (st 2 "b"))
+    (define sta (stA 1))
+    (define st3 (stABC 1 "b" 3))
+        
+    (check-equal?-classes:
+     [#:name st1
+      st1
+      (structure [a 1] [b "b"])
+      (structure [a : Number 1] [b : String "b"])
+      ((structure [a : Number] [b : String]) 1 "b")
+      (structure [a : Any 1] [b : Any "b"])
+      ((structure [a : Any] [b : Any]) 1 "b")
+      ((structure [a] [b]) 1 "b")
+      ((structure a b) 1 "b")
+      ((structure [a] b) 1 "b")]
+     [(structure [a "1"] [b 'b])
+      (structure [a : String "1"] [b : Symbol 'b])
+      (structure [a : Any "1"] [b : Any 'b])]
+     [st2]
+     [sta]
+     [st3])))
+  
+;; define-structure
+(begin
+  (define-structure empty-st)
+  (define-structure st [a Number] [b String])
+  (define-structure st2 [b String] [a Number] #:? custom-is-st2?)
+  (define-structure st3 [c String] [a Number] #:? custom-is-st3?))
+  
+;; Constructor:
+(check-equal?: (empty-st) : empty-st (empty-st))
+(begin
+  (check-equal?: (uniform-get (st 1 "b") b) : String "b")
+  (check-equal?: (uniform-get (st2 "a" 2) b) : String "a"))
+  
+;; Constructor, as id:
+(begin
+  (check-equal?: (uniform-get (cadr (map st '(1 2 3) '("x" "y" "z"))) b)
+                 : String
+                 "y")
+  (check-equal?: (uniform-get (cadr (map st2 '("d" "e" "f") '(1 2 3))) b)
+                 : String
+                 "e"))
+  
+;; type-expander
+(begin
+  (check-equal?: (uniform-get (ann (st2 "g" 123) st2) b) "g"))
+  
+;; match-expander
+(begin
+  (check-equal?: (match (st2 "h" 7) [(st x y) (cons x y)])
+                 : (Pairof Number String)
+                 '(7 . "h")))
+  
+;; Equality
+(begin
+  (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)))
+  
+;; Predicate
+(begin
+  (check-equal?: (st? (ann (st 1 "i") (U st st2))) #t)
+  (check-equal?: (custom-is-st2? (ann (st 1 "i") (U st st2))) #t)
+  (check-equal?: (custom-is-st3? (ann (st 1 "i") (U st st2))) #f)
+  (check-equal?: (st? (ann (st 1 "i") (U Number st st2))) #t)
+  (check-equal?: (st? (ann 1 (U Number st st2))) #f)
+  ;; Occurrence typing won't work well, if only because fields could be of
+  ;; a type for which TR doesn't know how to make-predicate.
+  (define (check-occurrence-typing [x : (U Number st st3)])
+    (if (st? x)
+        (match (ann x st) [(st the-a the-b) (cons the-b the-a)])
+        'other))
+  (check-equal?:
+   (check-occurrence-typing (ann (st 1 "i") (U Number st st3)))
+   '("i" . 1))
+  (check-equal?:
+   (check-occurrence-typing (ann (st2 "j" 2) (U Number st st3)))
+   '("j" . 2))
+  (check-equal?:
+   (check-occurrence-typing (ann 9 (U Number st st3)))
+   'other))

phc-adt-test/phc-adt/test/test-tagged-call-syntax.rkt

@@ -0,0 +1,110 @@
+#lang racket/base
+
+(require (for-template (lib "phc-adt/tagged.hl.rkt"))
+         rackunit
+         syntax/parse)
+
+(check-equal?
+ (syntax-parse #'(nam #:instance)
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?) (syntax->datum #'(name [fieldᵢ ...])))]
+   [_ 'wrong])
+ '(#t nam []))
+         
+(check-equal?
+ (syntax-parse #'(nam [field0 value0])
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?) (attribute no-types?)
+           (syntax->datum #'(name [fieldᵢ ...] [valueᵢ ...])))]
+   [_ 'wrong])
+ '(#t #t nam [field0] [value0]))
+
+(check-equal?
+ (syntax-parse #'(nam [field0 value0] [field1 value1])
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?) (attribute no-types?)
+           (syntax->datum #'(name [fieldᵢ ...] [valueᵢ ...])))]
+   [_ 'wrong])
+ '(#t #t nam [field0 field1] [value0 value1]))
+
+(check-equal?
+ (syntax-parse #'(nam [field0 : type0 value0])
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?) (attribute types?)
+           (syntax->datum #'(name [fieldᵢ ...] [τᵢ ...] [valueᵢ ...])))]
+   [_ 'wrong])
+ '(#t #t nam [field0] [type0] [value0]))
+
+(check-equal?
+ (syntax-parse #'(nam [field0 : type0 value0] [field1 : type1 value1])
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?) (attribute types?)
+           (syntax->datum #'(name [fieldᵢ ...] [τᵢ ...] [valueᵢ ...])))]
+   [_ 'wrong])
+ '(#t #t nam [field0 field1] [type0 type1] [value0 value1]))
+
+(check-equal?
+ (syntax-parse #'(nam #:instance)
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?)
+           (syntax->datum #'(name)))]
+   [_ 'wrong])
+ '(#t nam))
+
+(check-equal?
+ (syntax-parse #'(nam [field0 value0])
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?) (attribute no-types?)
+           (syntax->datum #'(name [fieldᵢ ...] [valueᵢ ...])))]
+   [_ 'wrong])
+ '(#t #t nam [field0] [value0]))
+
+(check-equal?
+ (syntax-parse #'(nam [field0 : type0 value0])
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute instance?) (attribute types?)
+           (syntax->datum #'(name [fieldᵢ ...] [τᵢ ...] [valueᵢ ...])))]
+   [_ 'wrong])
+ '(#t #t nam [field0] [type0] [value0]))
+
+(check-equal?
+ (syntax-parse #'(nam [field0] field1)
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute builder?)
+           (syntax->datum #'(name [fieldᵢ ...])))]
+   [_ 'wrong])
+ '(#t nam [field0 field1]))
+
+(check-equal?
+ (syntax-parse #'(nam [field0] field1)
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute builder?)
+           (syntax->datum #'(name [fieldᵢ ...])))]
+   [_ 'wrong])
+ '(#t nam [field0 field1]))
+
+(check-equal?
+ (syntax-parse #'(nam [field0] field1)
+   [(:tagged-call-args-syntax-class)
+    (list* (attribute builder?)
+           (syntax->datum #'(name [fieldᵢ ...])))]
+   [_ 'wrong])
+ '(#t nam [field0 field1]))
+
+(check-equal?
+ (syntax-parse #'(nam)
+   [(:tagged-call-args-syntax-class) 'wrong]
+   [_ 'parse-failed])
+ 'parse-failed)
+
+(check-equal?
+ (syntax-parse #'(#:instance)
+   [(:tagged-call-args-syntax-class) 'wrong]
+   [_ 'parse-failed])
+ 'parse-failed)
+
+(check-equal?
+ (syntax-parse #'()
+   [(:tagged-call-args-syntax-class) 'wrong]
+   [_ 'parse-failed])
+ 'parse-failed)

phc-adt-test/phc-adt/test/test-tagged-define.rkt

@@ -0,0 +1,67 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander "ck.rkt")
+(adt-init)
+
+(module m-abc typed/racket
+  (require phc-adt phc-toolkit type-expander "ck.rkt")
+  (adt-init)
+  
+  (define-tagged t0 tagged-fc tagged-fb tagged-fa)
+  (define c0 t0)
+  (provide (rename-out [t0 t0-cba]
+                       [c0 c0-cba])))
+
+(module m-xyz typed/racket
+  (require phc-adt phc-toolkit type-expander "ck.rkt")
+  (adt-init)
+  
+  (define-tagged t0 tagged-fx tagged-fy tagged-fz)
+  (define c0 t0)
+  (provide (rename-out [t0 t0-xyz]
+                       [c0 c0-xyz])))
+
+(require 'm-abc
+         'm-xyz)
+
+(define-tagged t0 tagged-fa tagged-fb tagged-fc)
+(define c0 t0)
+
+(ck (t0 'a "b" 3) (t0 Symbol String Number))
+(ck (c0 'a "b" 3) (t0 Symbol String Number))
+(ck-not (t0 'a "b" 3) (t0 Number Number Number))
+(ck-not (c0 'a "b" 3) (t0 Number Number Number))
+
+(ck (t0 'a "b" 3) (t0-cba Number String Symbol))
+(ck (c0 'a "b" 3) (t0-cba Number String Symbol))
+(ck-not (t0 'a "b" 3) (t0-cba Number Number Number))
+(ck-not (c0 'a "b" 3) (t0-cba Number Number Number))
+
+(ck (t0-cba 'a "b" 3) (t0 Number String Symbol))
+(ck (c0-cba 'a "b" 3) (t0 Number String Symbol))
+(ck-not (t0-cba 'a "b" 3) (t0 Number Number Number))
+(ck-not (c0-cba 'a "b" 3) (t0 Number Number Number))
+
+(ck (t0-cba 'a "b" 3) (t0-cba Symbol String Number))
+(ck (c0-cba 'a "b" 3) (t0-cba Symbol String Number))
+(ck-not (t0-cba 'a "b" 3) (t0-cba Number Number Number))
+(ck-not (c0-cba 'a "b" 3) (t0-cba Number Number Number))
+
+(ck (t0-xyz 'a "b" 3) (t0-xyz Symbol String Number))
+(ck (c0-xyz 'a "b" 3) (t0-xyz Symbol String Number))
+(ck-not (t0-xyz 'a "b" 3) (t0 Number Number Number))
+(ck-not (c0-xyz 'a "b" 3) (t0 Number Number Number))
+(ck-not (t0 'a "b" 3) (t0-xyz Symbol String Number))
+(ck-not (c0 'a "b" 3) (t0-xyz Symbol String Number))
+
+(check-equal?-classes:
+ [#:name "abc"
+  (t0 'a "b" 3)
+  (c0 'a "b" 3)
+  (t0-cba 3 "b" 'a)
+  (c0-cba 3 "b" 'a)]
+ [#:name "cba"
+  (t0 3 "b" 'a)
+  (c0 3 "b" 'a)
+  (t0-cba 'a "b" 3)
+  (c0-cba 'a "b" 3)])

phc-adt-test/phc-adt/test/test-tagged-parametric.rkt

@@ -0,0 +1,21 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander typed/rackunit "ck.rkt")
+(adt-init)
+
+(define-tagged #:∀ (T) a [a : T] [b : T])
+(define-tagged b #:∀ (T) [a : T] [b : T])
+(define-tagged c [a : T] [b : T] #:∀ (T))
+
+(define (printed-type [t : String])
+  (string-append "((tagged " t " a b)"
+                 " (U Positive-Byte String) (U Positive-Byte String))"))
+
+(check-print-type (a 3 "b") (printed-type "a"))
+(check-ann (a 3 4) (tagged a [a Positive-Byte] [b Positive-Byte]))
+
+(check-print-type (b 3 "b") (printed-type "b"))
+(check-ann (b 3 4) (tagged b [a Positive-Byte] [b Positive-Byte]))
+
+(check-print-type (c 3 "b") (printed-type "c"))
+(check-ann (c 3 4) (tagged c [a Positive-Byte] [b Positive-Byte]))

phc-adt-test/phc-adt/test/test-tagged.rkt

@@ -0,0 +1,20 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander)
+(adt-init)
+
+(check-equal?: (match (ann (tagged t1 [x 1] [y "b"])
+                           (tagged t1 [x : Number] [y : String]))
+                 [(tagged t1 [x a] [y b]) (list 'ok b a)]
+                 [_ #f])
+               '(ok "b" 1))
+(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"))
+
+(define-type ma (tagged ma (fav String) (faa ma) (fab mb)))
+(define-type mb (tagged mb (fbv String) (fba ma)))

phc-adt-test/phc-adt/test/test-variant.rkt

@@ -0,0 +1,21 @@
+#lang typed/racket
+
+(require phc-adt phc-toolkit type-expander typed/rackunit)
+(adt-init)
+  
+(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))

phc-adt/info.rkt

@@ -0,0 +1,12 @@
+#lang info
+(define collection 'multi)
+(define deps '("phc-adt-lib"
+               "phc-adt-doc"
+               "phc-adt-test"))
+(define implies '("phc-adt-lib"
+                  "phc-adt-doc"
+                  "phc-adt-test"))
+(define build-deps '())
+(define pkg-desc "Algebraic Datatypes tailored for writing compilers")
+(define version "1.1")
+(define pkg-authors '("Georges Dupéron"))