From 26256a09b94a4e29e31fa2db6321fee4e068b087 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= <georges.duperon@gmail.com>
Date: Tue, 15 Mar 2016 00:55:04 +0100
Subject: [PATCH] WIP on FB case 128
---
graph-lib/graph/__DEBUG_constructor.rkt | 5 +
graph-lib/graph/adt.lp2.rkt | 108 ++++++++
graph-lib/graph/constructor.lp2.rkt | 256 ++++++++++++++++++
graph-lib/graph/define-adt.lp2.rkt | 102 ++++++++
graph-lib/graph/remember.rkt | 101 ++++----
graph-lib/graph/structure.lp2.rkt | 21 +-
graph-lib/graph/tagged.lp2.rkt | 155 +++++++++++
graph-lib/graph/variant.lp2.rkt | 328 +-----------------------
graph-lib/graph/variant2.lp2.rkt | 158 ++++++++++++
graph-lib/lib/low/todo.rkt | 15 ++
10 files changed, 870 insertions(+), 379 deletions(-)
create mode 100644 graph-lib/graph/__DEBUG_constructor.rkt
create mode 100644 graph-lib/graph/adt.lp2.rkt
create mode 100644 graph-lib/graph/constructor.lp2.rkt
create mode 100644 graph-lib/graph/define-adt.lp2.rkt
create mode 100644 graph-lib/graph/tagged.lp2.rkt
create mode 100644 graph-lib/graph/variant2.lp2.rkt
create mode 100644 graph-lib/lib/low/todo.rkt
diff --git a/graph-lib/graph/__DEBUG_constructor.rkt b/graph-lib/graph/__DEBUG_constructor.rkt
new file mode 100644
index 00000000..4fab3b0d
--- /dev/null
+++ b/graph-lib/graph/__DEBUG_constructor.rkt
@@ -0,0 +1,5 @@
+#lang racket
+(require syntax/parse
+ syntax/parse/experimental/template)
+(require (for-template "../type-expander/type-expander.lp2.rkt"))
+(require (submod "../lib/low.rkt" untyped))
\ No newline at end of file
diff --git a/graph-lib/graph/adt.lp2.rkt b/graph-lib/graph/adt.lp2.rkt
new file mode 100644
index 00000000..ffe6df25
--- /dev/null
+++ b/graph-lib/graph/adt.lp2.rkt
@@ -0,0 +1,108 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Algebaraic Data Types: Constructor}
+
+@(table-of-contents)
+
+@section[#:tag "ADT|introduction"]{Introduction}
+
+We define variants (tagged unions), with the following constraints:
+
+@itemlist[
+ @item{Unions are anonymous: two different unions can contain the same tag, and
+ there's no way to distinguish these two occurrences of the tag}
+ @item{Callers can require an uninterned tag which inherits the interned tag, so
+ that @racket[(constructor #:uninterned tag Number)] is a subtype of
+ @racket[(constructor #:uninterned tag Number)], but not the reverse}
+ @item{The tag can be followed by zero or more “fields”}
+ @item{An instance of a variant only @racket[match]es with its constructor and
+ the same number of fields, with exact matching on the tag for uninterned
+ tags}]
+
+See @url{https://github.com/andmkent/datatype/} for an existing module providing
+Algebraic Data Types. The main difference with our library is that a given tag
+(i.e. constructor) cannot be shared by multiple unions, as can be seen in the
+example below where the second @tc[define-datatype] throws an error:
+
+@chunk[<datatype-no-sharing>
+ (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
+ (define-datatype Simple-Expr
+ [Var (Symbol)]
+ [Lambda (Symbol Expr)])]
+
+@section{Constructors, tagged, variants and structures}
+
+We first define @tc[structure] and @tc[constructor], the
+primitives allowing us to build instance, match against them
+and express the type itself.
+
+@chunk[<require-modules>
+ (require "structure.lp2.rkt")
+ (require "constructor.lp2.rkt")]
+
+We then define @tc[tagged], which is a shorthand for
+manipulating constructors which single value is a promise
+for a structure.
+
+@chunk[<require-modules>
+ (require "tagged.lp2.rkt")]
+
+For convenience, we write a @tc[variant] form, which is a
+thin wrapper against @tc[(U (~or constructor tagged) …)].
+
+@chunk[<require-modules>
+ (require "variant2.lp2.rkt")]
+
+The @tc[define-tagged] and @tc[define-constructor] forms
+also allow the @tc[#:uninterned] and @tc[#:private]
+keywords, to create uninterned constructors and tagged
+structures as described in @secref{ADT|introduction}.
+
+@chunk[<require-modules>
+ (require "define-adt.lp2.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
+which single value is a promise for a structure)@note{This
+ avoids the risk of combinatorial explosion for the intput
+ 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} then depth
+ of the accessed field.}
+
+@chunk[<require-modules>
+ (void)] @;(require "uniform-get.lp2.rkt")
+
+@chunk[<*>
+ (void)
+ #;(begin
+ (module main typed/racket
+ <require-modules>
+ (provide constructor
+ define-constructor
+ tagged
+ define-tagged
+ variant
+ define-variant
+ (rename-out [wrapped-structure structure])
+ uniform-get))
+
+ (require 'main)
+ (provide (all-from-out 'main)))]
\ No newline at end of file
diff --git a/graph-lib/graph/constructor.lp2.rkt b/graph-lib/graph/constructor.lp2.rkt
new file mode 100644
index 00000000..eabeadcd
--- /dev/null
+++ b/graph-lib/graph/constructor.lp2.rkt
@@ -0,0 +1,256 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Algebaraic Data Types: 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 wrapp them.
+
+@section[#:tag "variant|supertype"]{The @racket[ConstructorTop] supertype}
+
+We define variants as instances of subtypes of the @tc[Tagged] structure:
+
+@chunk[<constructor-top>
+ (struct (T) ConstructorTop ([values : T]) #:transparent)
+ (define-type ConstructorTopType ConstructorTop)]
+
+Other options would include defining the variant as a @tc[list], with the tag
+symbol in the first element. We couldn't use a @tc[vector], because these are
+mutable in @tc[typed/racket] (for now), and occurrence typing can't work
+properly on mutable data structures. Using a @tc[list] has the drawback that
+other data can easily take the same shape, meaning that it is impossible to
+define a reliable predicate for a tagged instance that also works well with*
+@tc[typed/racket]'s occurrence typing.
+
+@section{Declaring a new constructor}
+
+The constructor type will be a @tc[struct] inheriting from
+@tc[ConstructorTop], without adding any field. By default, the
+constructor's name is "interned" (not in racket's interned
+symbols sense), so that two uses of the same constructor
+name in different files refer to the same constructor type.
+
+For this, we use the @tc[remember] library:
+
+@chunk[<remember-lib>
+ (require (for-syntax "remember-lib.rkt"))]
+
+We pre-declare here in this file all the remembered constructors:
+
+@CHUNK[<constructor-declarations>
+ (struct (T)
+ constructor-name/struct
+ #,(syntax-local-introduce #'ConstructorTop)
+ ()
+ #:transparent)
+ …]
+
+We define an associative list which maps the constructor
+name to the structure identifier (with the same scopes as
+the one declared just above):
+
+@CHUNK[<declare-all-constructors>
+ (define-syntax (declare-all-constructors stx)
+ (define/with-syntax (constructor-name …)
+ constructor-names-no-duplicates)
+ (define/with-syntax alist
+ (syntax-local-introduce #'constructor-name→stx-name/alist))
+ (define-temp-ids "~a/struct" (constructor-name …))
+ #`(begin
+ <constructor-declarations>
+
+ (define-for-syntax alist
+ (stx-map (λ (x y) (cons (syntax->datum x) y))
+ #'(constructor-name …)
+ #'(constructor-name/struct …)))))]
+
+We call this macro once, to define the structs in the
+template meta-level, and the
+@tc[constructor-name→stx-name/alist] in the transformer
+meta-level.
+
+@CHUNK[<declare-all-constructors>
+ (declare-all-constructors)]
+
+The list of constructor names, @tc[constructor-names-no-duplicates], is the one
+remembered by “@code{remember-lib.rkt}” with duplicate entries removed:
+
+@CHUNK[<named-sorted-constructors>
+ (define-for-syntax constructor-names-no-duplicates
+ (remove-duplicates (get-remembered 'constructor)))]
+
+Finally, we define @tc[with-constructor-name→stx-name], a
+helper macro which accesses the structure identifier for a
+given constructor name, checking whether the constructor
+name has been remembered already (and throwing an error
+otherwise):
+
+@chunk[<with-constructor-name→stx-name>
+ (begin-for-syntax
+ (define-syntax (with-constructor-name→stx-name stx)
+ (syntax-case stx ()
+ [(_ (stx-name with-struct constructor-name fallback error-stx)
+ . body)
+ #`<with-constructor-name→stx-name-body>])))]
+
+@chunk[<with-constructor-name→stx-name-body>
+ (if #,(syntax/loc #'with-struct (attribute with-struct))
+ (with-syntax ([stx-name #'with-struct])
+ . body)
+ (if (check-remember-all 'constructor constructor-name)
+ (with-syntax
+ ([stx-name (cdr
+ (assoc (syntax->datum
+ (datum->syntax #f constructor-name))
+ constructor-name→stx-name/alist))])
+ . body)
+ (remember-all-errors2 fallback constructor-name)))]
+
+@section{@racket[constructor]}
+
+We define the @tc[constructor] macro which acts as a type, a
+match expander, and a procedure returning a constructor
+instance:
+
+@chunk[<constructor>
+ (define-multi-id constructor
+ #:type-expander <type-expander>
+ #:match-expander <match-expander>
+ #:call <make-instance>)]
+
+@chunk[<test-constructor>
+ (check-equal?: (constructor-values
+ (ann (constructor a 1 "x")
+ ;; TODO: Make a (ConstructorTop …) type expander.
+ (ConstructorTop (List Number String))))
+ (list 1 "x"))
+ (check-equal?: (constructor-values
+ (ann (constructor a 1 "x")
+ (ConstructorTop Any)))
+ (list 1 "x"))
+ (check-equal?: (constructor-values
+ (ann (constructor a 1 "x")
+ (constructor a Number String)))
+ (list 1 "x")) ;; TODO: test that the tag is 'a
+ (check-equal?: (constructor-values
+ (ann (constructor b)
+ (constructor b)))
+ (list)) ;; TODO: test that the tag is 'b
+ (check-equal?: (constructor-values
+ (ann (constructor c 'd)
+ (constructor c Symbol)))
+ 'd) ;; TODO: test that the tag is 'c
+ (check-equal?: (ann (constructor c 2 "y")
+ (constructor c Number String))
+ (constructor c 2 "y"))
+ (check-not-equal?: (constructor d 2 "y")
+ (constructor d 2 "y" 'z))
+ (check-not-equal?: (constructor e 2 "y")
+ (constructor F 2 "y"))]
+
+@subsection{Type-expander}
+
+@CHUNK[<type-expander>
+ (λ/syntax-parse (_ constructor-name:id
+ (~maybe #:with-struct with-struct)
+ . (~or (T₀:expr) (Tᵢ:expr …)))
+ (with-constructor-name→stx-name
+ (stx-name with-struct #'constructor-name #'please-recompile stx)
+ (template
+ (stx-name (?? T₀ (List Tᵢ …))))))]
+
+@subsection{Predicate}
+
+@CHUNK[<predicate>
+ (define-syntax (Constructor-predicate? stx)
+ (syntax-parse stx
+ [(_ constructor-name (~maybe #:with-struct with-struct) v)
+ (quasisyntax/loc stx
+ (#,(syntax/loc stx
+ (Constructor-predicate? constructor-name
+ (?? (?@ #:with-struct with-struct))))
+ v))]
+ [(_ constructor-name (~maybe #:with-struct with-struct))
+ ;; make-predicate works for polymorphic structs when
+ ;; instantiating them with Any.
+ (with-constructor-name→stx-name
+ (stx-name with-struct
+ #'constructor-name
+ (syntax/loc #'constructor-name please-recompile)
+ stx)
+ (syntax/loc stx (make-predicate (stx-name Any))))]
+ [(_)
+ (syntax/loc stx (make-predicate (ConstructorTop Any)))]))]
+
+@subsection{Match-expander}
+
+@chunk[<match-expander>
+ (λ/syntax-parse (_ constructor-name:id (~maybe #:with-struct with-struct)
+ . (~or (pat₀:expr) (patᵢ:expr …)))
+ (template
+ (? (Constructor-predicate? constructor-name
+ (?? (?@ #:with-struct with-struct)))
+ (app ConstructorTop-values (?? pat₀ (list patᵢ …))))))]
+
+@subsection{Instance creation}
+
+@CHUNK[<make-instance>
+ (λ/syntax-parse (_ constructor-name:id
+ (~maybe #:with-struct with-struct)
+ value:expr …)
+ (define/with-syntax (arg …) (generate-temporaries #'(value …)))
+ (define/syntax-parse (~or (arg₀) (argᵢ …)) #'(arg …))
+ (define/with-syntax (T …) (generate-temporaries #'(value …)))
+ (with-constructor-name→stx-name
+ (stx-name with-struct
+ #'constructor-name
+ (syntax/loc #'constructor-name please-recompile)
+ stx)
+ (template
+ ((λ #:∀ (T …) ([arg : T] …)
+ : (constructor constructor-name T …)
+ (stx-name (?? arg₀ (list argᵢ …))))
+ value …))))]
+
+@chunk[<*>
+ (begin
+ (module main typed/racket
+ (require (for-syntax racket/list
+ syntax/parse
+ syntax/parse/experimental/template
+ racket/syntax
+ (submod "../lib/low.rkt" untyped))
+ (for-meta 2 racket/base)
+ "../lib/low.rkt"
+ "../type-expander/multi-id.lp2.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+
+ (provide constructor
+ (rename-out [Constructor-predicate? constructor?])
+ (rename-out [ConstructorTopType ConstructorTop])
+ ConstructorTop?
+ (rename-out [ConstructorTop-values constructor-values]))
+
+ <constructor-top>
+ <remember-lib>
+ <named-sorted-constructors>
+ <declare-all-constructors>
+ <with-constructor-name→stx-name>
+
+ <constructor>
+ <predicate>)
+
+ (require 'main)
+ (provide (all-from-out 'main))
+
+ (module* test typed/racket
+ (require (submod "..")
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+ <test-constructor>))]
\ No newline at end of file
diff --git a/graph-lib/graph/define-adt.lp2.rkt b/graph-lib/graph/define-adt.lp2.rkt
new file mode 100644
index 00000000..86f4ad4c
--- /dev/null
+++ b/graph-lib/graph/define-adt.lp2.rkt
@@ -0,0 +1,102 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Algebaraic Data Types:
+ @racket[define-constructor] and @racket[define-tagged]}
+
+@(table-of-contents)
+
+@section{Introduction}
+
+@section{@racket{define-constructor}}
+
+@chunk[<define-constructor>
+ (define-syntax/parse
+ (define-constructor constructor-name:id
+ (~maybe #:with-struct with-struct)
+ (~maybe #:? name?)
+ type …)
+
+ (define/with-syntax default-name? (format-id #'name "~a?" #'name))
+ (define-temp-ids "pat" (type …))
+ (define-temp-ids "value" (type …))
+ (template
+ (begin
+ (define-multi-id constructor-name
+ #:type-expand-once
+ (constructor constructor-name
+ (?? (?@ #:with-struct with-struct))
+ type …)
+ #:match-expander
+ (λ/syntax-parse (_ pat …)
+ #'(constructor constructor-name
+ (?? (?@ #:with-struct with-struct))
+ pat …))
+ #:call
+ (λ/syntax-parse (_ value …)
+ #'(constructor constructor-name
+ (?? (?@ #:with-struct with-struct))
+ value …)))
+ (define-multi-id (?? name? default-name?)
+ #:else
+ #'(constructor? constructor-name
+ (?? (?@ #:with-struct with-struct)))))))]
+
+@chunk[<define-tagged>
+ (define-syntax/parse (define-tagged tag:id
+ (~maybe #:with-struct with-struct)
+ (~maybe #:? name?)
+ [field type] …)
+ (define/with-syntax default-name? (format-id #'name "~a?" #'name))
+ (define-temp-ids "pat" (type …))
+ (define-temp-ids "value" (type …))
+ (template
+ (begin
+ (define-multi-id tag
+ #:type-expand-once
+ (tagged tag
+ (?? (?@ #:with-struct with-struct))
+ [field type] …)
+ #:match-expander
+ (λ/syntax-parse (_ pat …)
+ #'(tagged tag
+ (?? (?@ #:with-struct with-struct))
+ [field pat] …))
+ #:call
+ (λ/syntax-parse (_ value …)
+ #'(tagged #:instance
+ tag
+ (?? (?@ #:with-struct with-struct))
+ value …)))
+ (define-multi-id (?? name? default-name?)
+ #:else
+ #'(tagged? tag
+ (?? (?@ #:with-struct with-struct))
+ field …)))))]
+
+@section{Conclusion}
+
+@chunk[<*>
+ (begin
+ (module main typed/racket
+ (require (for-syntax racket/list
+ syntax/parse
+ syntax/parse/experimental/template
+ racket/syntax
+ (submod "../lib/low.rkt" untyped))
+ (for-meta 2 racket/base)
+ "../lib/low.rkt"
+ "../type-expander/multi-id.lp2.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+
+ <define-constructor>
+ <define-tagged>)
+
+ (require 'main)
+ (provide (all-from-out 'main))
+
+ (module* test typed/racket
+ (require (submod "..")
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt")))]
\ No newline at end of file
diff --git a/graph-lib/graph/remember.rkt b/graph-lib/graph/remember.rkt
index d5453d34..eeeefe7e 100644
--- a/graph-lib/graph/remember.rkt
+++ b/graph-lib/graph/remember.rkt
@@ -100,58 +100,63 @@
(structure foo)
(structure foo)
(structure foo)
-(variant . x)
-(variant . y)
-(variant . z)
-(variant . tagged-s1)
-(variant . tagged-s2)
-(variant . tagged-s3)
-(variant . tagged-s4)
-(variant . a)
-(variant . b)
-(variant . c)
-(variant . c)
-(variant . d)
-(variant . e)
-(variant . dd)
-(variant . ddd)
-(variant . dde)
-(variant . ddf)
-(variant . ddg)
-(variant . ddh)
-(variant . ddi)
-(variant . ddj)
-(variant . ddk)
-(variant . ddl)
-(variant . F)
-(variant . w)
-(variant . foo)
-(variant . foo)
-(variant . foo)
-(variant . de1)
-(variant . de2)
-(variant . de3)
-(variant . df3)
-(variant . df1)
-(variant . df2)
+(constructor . x)
+(constructor . y)
+(constructor . z)
+(constructor . tagged-s1)
+(constructor . tagged-s2)
+(constructor . tagged-s3)
+(constructor . tagged-s4)
+(constructor . a)
+(constructor . b)
+(constructor . c)
+(constructor . c)
+(constructor . d)
+(constructor . e)
+(constructor . dd)
+(constructor . ddd)
+(constructor . dde)
+(constructor . ddf)
+(constructor . ddg)
+(constructor . ddh)
+(constructor . ddi)
+(constructor . ddj)
+(constructor . ddk)
+(constructor . ddl)
+(constructor . F)
+(constructor . w)
+(constructor . foo)
+(constructor . foo)
+(constructor . foo)
+(constructor . de1)
+(constructor . de2)
+(constructor . de3)
+(constructor . df3)
+(constructor . df1)
+(constructor . df2)
(structure Number String)
(structure Number String)
(structure Number String)
-(variant . dg1)
-(variant . dh1)
-(variant . dh1)
-(variant . dh1)
-(variant . di2)
-(variant . dj1)
-(variant . dk1)
-(variant . dl1)
+(constructor . dg1)
+(constructor . dh1)
+(constructor . dh1)
+(constructor . dh1)
+(constructor . di2)
+(constructor . dj1)
+(constructor . dk1)
+(constructor . dl1)
(structure x y)
-(variant . txyz)
-(variant . City89/with-promises-tag)
-(variant . Street90/with-promises-tag)
-(variant . House91/with-promises-tag)
-(variant . Person92/with-promises-tag)
+(constructor . txyz)
+(constructor . City89/with-promises-tag)
+(constructor . Street90/with-promises-tag)
+(constructor . House91/with-promises-tag)
+(constructor . Person92/with-promises-tag)
(structure n)
(structure water)
(structure water)
-(variant . cxyz)
+(constructor . cxyz)
+(constructor . v)
+(constructor . t1)
+(constructor . Number)
+(constructor . String)
+(constructor . Number)
diff --git a/graph-lib/graph/structure.lp2.rkt b/graph-lib/graph/structure.lp2.rkt
index e61713b9..5b474e2d 100644
--- a/graph-lib/graph/structure.lp2.rkt
+++ b/graph-lib/graph/structure.lp2.rkt
@@ -232,7 +232,8 @@ field part of the structure.
@CHUNK[<declare-all-structs>
(define-syntax/parse (declare-all-structs fields→stx-name-alist:id
(name field ...) ...)
- #'(begin
+ (define-temp-ids "~a/T" ((field …) …))
+ #`(begin
<struct-declarations>
(define-for-syntax fields→stx-name-alist
@@ -283,10 +284,18 @@ associative list.
The struct declarations are rather standard. We use @tc[#:transparent], so that
@tc[equal?] compares instances memberwise.
+@chunk[<structure-top>
+ (struct StructureTop ())
+ (define-type StructureTopType StructureTop)]
+
@; TODO: write “field : Tfield”, it's cleaner.
@CHUNK[<struct-declarations>
- (struct (field ...) name ([field : field] ...) #:transparent)
- ...]
+ (struct (field/T …)
+ name
+ #,(syntax-local-introduce #'StructureTop)
+ ([field : field/T] …)
+ #:transparent)
+ …]
@section{Constructor}
@@ -561,10 +570,14 @@ its arguments across compilations, and adds them to the file
structure
structure-supertype
structure-supertype*
- structure?)
+ structure?
+ (rename-out [StructureTopType StructureTop])
+ StructureTop?)
(begin-for-syntax
(provide structure-args-stx-class))
+
+ <structure-top>
<check-remember-fields>
diff --git a/graph-lib/graph/tagged.lp2.rkt b/graph-lib/graph/tagged.lp2.rkt
new file mode 100644
index 00000000..907afa75
--- /dev/null
+++ b/graph-lib/graph/tagged.lp2.rkt
@@ -0,0 +1,155 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Algebaraic Data Types: Tagged}
+
+@(table-of-contents)
+
+@section{Introduction}
+
+We define @tc[tagged], which is a shorthand for
+manipulating constructors which single value is a promise
+for a structure.
+
+@section{@racket[tagged]}
+
+@chunk[<tagged>
+ (define-multi-id tagged
+ #:type-expander <type-expander>
+ #:match-expander <match-expander>
+ #:call <make-instance>)]
+
+@subsection{@racket[TaggedTop]}
+
+@chunk[<tagged-top>
+ (define-type TaggedTop (ConstructorTop (Promise StructureTop)))]
+
+@subsection{@racket[type-expander]}
+
+@chunk[<type-expander>
+ (λ/syntax-parse (_ tag:id (~maybe #:with-struct with-struct)
+ . structure-type)
+ (quasitemplate
+ (constructor tag (?? (?@ #:with-struct with-struct))
+ #,(syntax/loc #'structure-type
+ (structure . structure-type)))))]
+
+@subsection{@racket[match-expander]}
+
+@chunk[<match-expander>
+ (λ/syntax-parse (_ tag:id (~maybe #:with-struct with-struct)
+ . structure-pat)
+ (quasitemplate
+ (constructor tag (?? (?@ #:with-struct with-struct))
+ #,(syntax/loc #'structure-pat
+ (structure . structure-pat)))))]
+
+@subsection{@racket[instance creation]}
+
+@; TODO: clean this up a bit, and explain it.
+@chunk[<make-instance>
+ (λ/syntax-parse
+ (~and (_ (~and (~seq disambiguate …)
+ (~or (~seq #:instance)
+ (~seq #:make-instance)
+ (~seq)))
+ tag:id (~maybe #:with-struct with-struct)
+ . fields)
+ (~parse (sa:structure-args-stx-class)
+ #'(disambiguate … . fields)))
+ (define-temp-ids "~a/TTemp" (sa.field …))
+ (define-temp-ids "~a/arg" (sa.field …))
+ (define/with-syntax c
+ (if (attribute sa.type)
+ (quasitemplate
+ (λ ([sa.field/arg : sa.type] …)
+ : (constructor tag (?? (?@ #:with-struct with-struct))
+ #,(syntax/loc #'fields
+ (structure [sa.field sa.type] …)))
+ (constructor tag (?? (?@ #:with-struct with-struct))
+ #,(syntax/loc #'fields
+ (structure #:instance
+ [sa.field : sa.type sa.field/arg]
+ …)))))
+ (quasitemplate
+ (λ #:∀ (sa.field/TTemp …) ([sa.field/arg : sa.field/TTemp] …)
+ : (constructor tag (?? (?@ #:with-struct with-struct))
+ #,(syntax/loc #'fields
+ (structure [sa.field sa.field/TTemp] …)))
+ (constructor tag (?? (?@ #:with-struct with-struct))
+ #,(syntax/loc #'fields
+ (structure #:instance
+ [sa.field sa.field/arg] …)))))))
+ (if (attribute sa.value)
+ #'(c sa.value …)
+ #'c))]
+
+@subsection{@racket[predicate]}
+
+@CHUNK[<tagged-top?>
+ (define-multi-id TaggedTop?
+ #:else #'(λ (v) (and (ConstructorTop? v)
+ (promise? (constructor-values v))
+ (StructureTop? (force (constructor-values v))))))]
+
+@CHUNK[<tagged?>
+ (define-syntax/parse (tagged? tag (~maybe #:with-struct with-struct)
+ field …)
+ #'(λ (v) (and (constructor? tag (?? (?@ #:with-struct with-struct)) v)
+ (promise? (constructor-values v))
+ ((structure? field …)
+ (force (constructor-values v))))))]
+
+@section{Tests}
+
+@chunk[<test-tagged>
+ (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))]
+
+@chunk[<test-tagged>
+ (check-equal?: (match (ann (tagged foo [x "o"] [y 3] [z 'z])
+ (tagged foo
+ [x String]
+ [z 'z]
+ [y Fixnum]))
+ [(tagged foo z x y) (list z y x)])
+ '(z 3 "o"))]
+
+@section{Conclusion}
+
+@chunk[<*>
+ (begin
+ (module main typed/racket
+ (require (for-syntax racket/list
+ syntax/parse
+ syntax/parse/experimental/template
+ racket/syntax
+ (submod "../lib/low.rkt" untyped))
+ "../lib/low.rkt"
+ "../type-expander/multi-id.lp2.rkt"
+ "../type-expander/type-expander.lp2.rkt"
+ "constructor.lp2.rkt"
+ "structure.lp2.rkt")
+
+ (provide tagged
+ tagged?
+ TaggedTop
+ TaggedTop?)
+
+ <tagged-top>
+ <tagged>
+ <tagged-top?>
+ <tagged?>)
+
+ (require 'main)
+ (provide (all-from-out 'main))
+
+ (module* test typed/racket
+ (require (submod "..")
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+ <test-tagged>))]
\ No newline at end of file
diff --git a/graph-lib/graph/variant.lp2.rkt b/graph-lib/graph/variant.lp2.rkt
index f35144af..69deb195 100644
--- a/graph-lib/graph/variant.lp2.rkt
+++ b/graph-lib/graph/variant.lp2.rkt
@@ -6,331 +6,8 @@
@(table-of-contents)
-@section{Introduction}
-
-We define variants (tagged unions), with the following constraints:
-
-@itemlist[
- @item{Unions are anonymous: two different unions can contain the same tag, and
- there's no way to distinguish these two occurrences of the tag}
- @item{Callers can require an uninterned tag which inherits the interned tag, so
- that @racket[(tagged #:uninterned tag Number)] is a subtype of
- @racket[(tagged #:uninterned tag Number)], but not the reverse}
- @item{The tag can be followed by zero or more “fields”}
- @item{An instance of a variant only @racket[match]es with its constructor and
- the same number of fields, with exact matching for uninterned tags}]
-
-See @url{https://github.com/andmkent/datatype/} for an existing module providing
-Algebraic Data Types. The main difference with our library is that a given tag
-(i.e. constructor) cannot be shared by multiple unions, as can be seen in the
-example below where the second @tc[define-datatype] throws an error:
-
-@chunk[<datatype-no-sharing>
- (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
- (define-datatype Simple-Expr
- [Var (Symbol)]
- [Lambda (Symbol Expr)])]
-
-@section[#:tag "variant|supertype"]{The @racket[Variant] supertype}
-
-We define variants as instances of subtypes of the @tc[Tagged] structure:
-
-@chunk[<variant-supertype>
- (struct (T) Tagged ([value : T]) #:transparent)
- (define-type Tagged-type Tagged)]
-
-Other options would include defining the variant as a @tc[list], with the tag
-symbol in the first element. We couldn't use a @tc[vector], because these are
-mutable in @tc[typed/racket] (for now), and occurrence typing can't work
-properly on mutable data structures. Using a @tc[list] has the drawback that
-other data can easily take the same shape, meaning that it is impossible to
-define a reliable predicate for a tagged instance that is also understood by
-@tc[typed/racket].
-
-@section{Declaring a new tag}
-
-The tag type will be a @tc[struct] inheriting from
-@tc[Tagged], without adding any field. By default, the tag
-is "interned" (not in racket's interned symbols sense), so
-that two uses of the same tag name in different files refer
-to the same tag type.
-
-For this, we use the @tc[remember] library:
-
-@chunk[<remember-tags>
- (require (for-syntax "remember-lib.rkt"))]
-
-We pre-declare here in this file all the remembered tags:
-
-@CHUNK[<tag-declarations>
- (struct (T) tag-name/struct Tagged () #:transparent)
- …]
-
-We define an associative list which maps tag names to the
-structure identifier (with the same scopes as the one
-declared just above):
-
-@CHUNK[<declare-all-tags>
- (define-syntax/parse (declare-all-tags tag-name→stx-name/alist:id
- tag-name …)
- (define-temp-ids "~a/struct" (tag-name …))
- #'(begin
- <tag-declarations>
-
- (define-for-syntax tag-name→stx-name/alist
- (stx-map (λ (x y) (cons (syntax->datum x) y))
- #'(tag-name …)
- #'(tag-name/struct …)))))]
-
-This macro should be called only once, and given as parameters the whole
-remembered list of tag names:
-
-@CHUNK[<declare-all-tags>
- (define-syntax/parse (call-declare-all-tags tag-name→stx-name/alist:id)
- #`(declare-all-tags tag-name→stx-name/alist
- #,@tag-names-no-duplicates))
-
- (call-declare-all-tags tag-name→stx-name/alist)]
-
-This list of tag names is the one remembered by
-“@code{remember-lib.rkt}” with duplicate entries removed:
-
-@CHUNK[<named-sorted-tags>
- (define-for-syntax tag-names-no-duplicates
- (remove-duplicates (get-remembered 'variant)))]
-
-Finally, we define @tc[with-tag-name→stx-name], a helper
-macro which accesses the structure identifier for a given
-tag name, checking whether the tag name has been remembered
-already:
-
-@chunk[<tag-name→stx-name>
- (begin-for-syntax
- (define-syntax-rule (with-tag-name→stx-name
- (stx-name tag-name fallback error-stx)
- . body)
- (if (check-remember-all 'variant tag-name)
- (with-syntax ([stx-name (cdr (assoc (syntax->datum
- (datum->syntax #f tag-name))
- tag-name→stx-name/alist))])
- . body)
- (remember-all-errors2 fallback tag-name))))]
-
-@section{@racket[constructor]}
-
-We define the @tc[constructor] macro which acts as a type,
-a match expander, and a procedure returning a tagged
-instance:
-
-@chunk[<constructor>
- (define-multi-id constructor
- #:type-expander <type-expander>
- #:match-expander <match-expander>
- #:call <make-instance>)]
-
-@chunk[<test-constructor>
- (check-equal?: (Tagged-value
- (ann (constructor a 1 "x")
- (constructor a Number String)))
- (list 1 "x")) ;; TODO: test that the tag is 'a
- (check-equal?: (Tagged-value
- (ann (constructor b)
- (constructor b)))
- (list)) ;; TODO: test that the tag is 'b
- (check-equal?: (Tagged-value
- (ann (constructor c 'd)
- (constructor c Symbol)))
- 'd) ;; TODO: test that the tag is 'c
- (check-equal?: (ann (constructor c 2 "y")
- (constructor c Number String))
- (constructor c 2 "y"))
- (check-not-equal?: (constructor d 2 "y")
- (constructor d 2 "y" 'z))
- (check-not-equal?: (constructor e 2 "y")
- (constructor F 2 "y"))]
-
-@subsection{Type-expander}
-
-@CHUNK[<type-expander>
- (λ/syntax-parse (_ tag:id . (~or (T₀:expr) (Tᵢ:expr …)))
- (with-tag-name→stx-name (stx-name #'tag #'please-recompile stx)
- (quasitemplate
- (stx-name (?? T₀ (List Tᵢ …))))))]
-
-@subsection{Predicate}
-
-@CHUNK[<predicate>
- (define-syntax (Tagged-predicate? stx)
- (syntax-case stx ()
- [(_ tag v)
- #'((Tagged-predicate? tag) v)]
- [(_ tag)
- ;; make-predicate works for polymorphic structs when
- ;; instantiating them with Any.
- (with-tag-name→stx-name
- (stx-name #'tag (syntax/loc #'tag please-recompile) stx)
- #`(make-predicate (stx-name Any)))]
- [(_)
- #'(make-predicate (Tagged Any))]))]
-
-@subsection{Match-expander}
-
-@chunk[<match-expander>
- (λ/syntax-parse (_ tag:id . (~or (pat₀:expr) (patᵢ:expr …)))
- (template
- (and (? (Tagged-predicate? tag))
- (app Tagged-value (?? pat₀ (list patᵢ …))))))]
-
-@subsection{Actual constructor}
-
-@CHUNK[<make-instance>
- (λ/syntax-parse (_ tag:id value:expr …)
- (define/with-syntax (arg …) (generate-temporaries #'(value …)))
- (define/syntax-parse (~or (arg₀) (argᵢ …)) #'(arg …))
- (define/with-syntax (T …) (generate-temporaries #'(value …)))
- (with-tag-name→stx-name
- (stx-name #'tag (syntax/loc #'tag please-recompile) stx)
- (template
- ((λ #:∀ (T …) ([arg : T] …)
- : (constructor tag T …)
- (stx-name (?? arg₀ (list argᵢ …))))
- value …))))]
-
-@section{@racket[define-variant]}
-
-In @tc[define-variant], we only define the type (which is the union of all the
-possible constructors. We don't define the constructors, for two reasons: the
-same @tc[constructor]s could appear in several variants, so we would define them
-twice, and it is likely that a constructor will have the same identifier as an
-existing variable or function.
-
-@CHUNK[<define-variant>
- (define-syntax/parse (define-variant name [tag:id type:expr …] …
- (~maybe #:? name?))
- (define/with-syntax default-name? (format-id #'name "~a?" #'name))
- (define-temp-ids "pat" ((type …) …))
- (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 …))))]
-
-@chunk[<test-define-variant>
- (define-variant v1 [x Number String] [y String Number] [z Number String])
- (check-equal?: (ann (constructor x 1 "a")
- (U [constructor w Number String]
- [constructor x Number String]
- [constructor y String Number]))
- (constructor x 1 "a"))
- (check-equal?: (constructor x 1 "a")
- (constructor x 1 "a"))
- (check-equal?: (ann (constructor x 1 "a") v1)
- (constructor x 1 "a"))
- (check-equal?: (ann (constructor x 1 "a") v1)
- (ann (constructor x 1 "a") v1))
- (check-not-equal?: (ann (constructor x 2 "b") v1)
- (ann (constructor y "b" 2) v1))
- (check-not-equal?: (ann (constructor x 3 "c") v1)
- (ann (constructor z 3 "c") v1))]
-
-This makes pattern-matching more verbose, though, since we have to specify
-@tc[(variant tag pat …)] each time, instead of just @tc[(tag pat …)]. I
-don't really know how to solve that. It should be noted that constructors are
-likely to have names starting with a capital letter, so maybe this reduces the
-number of name collisions.
-
@section{@racket[tagged]}
-@CHUNK[<tagged>
- (define-multi-id tagged
- #:type-expander
- (λ/syntax-parse (_ tag:id . structure-type)
- #`(constructor tag #,(syntax/loc #'structure-type
- (structure . structure-type))))
- #:match-expander
- (λ/syntax-parse (_ tag:id . structure-pat)
- #`(constructor tag #,(syntax/loc #'structure-pat
- (structure . structure-pat))))
- #:call ;; TODO: clean this up a bit, and explain it.
- (λ/syntax-parse
- (~and (_ (~and (~seq disambiguate …) (~or (~seq #:instance)
- (~seq #:constructor)
- (~seq)))
- tag:id . fields)
- (~parse (sa:structure-args-stx-class)
- #'(disambiguate … . fields)))
- (define-temp-ids "~a/TTemp" (sa.field …))
- (define-temp-ids "~a/arg" (sa.field …))
- (define/with-syntax c
- (if (attribute sa.type)
- #`(λ ([sa.field/arg : sa.type] …)
- : (constructor tag #,(syntax/loc #'fields
- (structure [sa.field sa.type] …)))
- (constructor tag
- #,(syntax/loc #'fields
- (structure #:instance
- [sa.field : sa.type
- sa.field/arg]
- …))))
- #`(λ #:∀ (sa.field/TTemp …) ([sa.field/arg : sa.field/TTemp] …)
- : (constructor tag #,(syntax/loc #'fields
- (structure [sa.field sa.field/TTemp]
- …)))
- (constructor tag
- #,(syntax/loc #'fields
- (structure #:instance
- [sa.field sa.field/arg] …))))))
- (if (attribute sa.value)
- #'(c sa.value …)
- #'c)))]
-
-@CHUNK[<tagged>
- (define-multi-id any-tagged
- #:type-expander
- (λ/syntax-parse (_ . structure-type)
- #'(Tagged (structure . structure-type)))
- ;; This would require each tag struct to contain a field with its
- ;; tag name. We'll implement it if we need that kind of reflection.
- #|
- #:match-expander
- (λ/syntax-parse (_ tag-pat:id . structure-pat)
- #`(any-constructor (? symbol? tag-pat:id)
- #,(syntax/loc #'structure-pat
- (structure . structure-pat))))|#)]
-
-@chunk[<test-tagged>
- (check-equal?: (match (ann (tagged foo [x "o"] [y 3] [z 'z])
- (tagged foo
- [x String]
- [z 'z]
- [y Fixnum]))
- [(tagged foo z x y) (list z y x)])
- '(z 3 "o"))]
-
@section{@racket[define-tagged]}
@chunk[<define-tagged>
@@ -615,11 +292,8 @@ the uninterned @tc[tag] either).
Tagged-value
constructor
define-variant
- tagged
- define-tagged
define-private-tagged
- define-private-constructor
- any-tagged)
+ define-private-constructor)
<variant-supertype>
<remember-tags>
diff --git a/graph-lib/graph/variant2.lp2.rkt b/graph-lib/graph/variant2.lp2.rkt
new file mode 100644
index 00000000..15f509b1
--- /dev/null
+++ b/graph-lib/graph/variant2.lp2.rkt
@@ -0,0 +1,158 @@
+#lang scribble/lp2
+@(require "../lib/doc.rkt")
+@doc-lib-setup
+
+@title[#:style manual-doc-style]{Algebaraic Data Types: 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{@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/debug debug
+ (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{Tests}
+
+@chunk[<test-define-variant>
+ (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))]
+
+@section{Conclusion}
+
+@chunk[<*>
+ (begin
+ (module main typed/racket
+ (require (for-syntax racket/list
+ syntax/parse
+ syntax/parse/experimental/template
+ racket/syntax
+ (submod "../lib/low.rkt" untyped))
+ "../lib/low.rkt"
+ "../type-expander/multi-id.lp2.rkt"
+ "../type-expander/type-expander.lp2.rkt"
+ "constructor.lp2.rkt"
+ "structure.lp2.rkt")
+
+ (provide variant
+ variant?
+ define-variant)
+
+ <constructor-or-tagged-stx-class>
+ <variant>
+ <variant?>
+ <define-variant>)
+
+ (require 'main)
+ (provide (all-from-out 'main))
+
+ (module* test typed/racket
+ (require (submod "..")
+ "constructor.lp2.rkt"
+ "../lib/low.rkt"
+ "../type-expander/type-expander.lp2.rkt")
+
+ <test-define-variant>))]
diff --git a/graph-lib/lib/low/todo.rkt b/graph-lib/lib/low/todo.rkt
new file mode 100644
index 00000000..080967bd
--- /dev/null
+++ b/graph-lib/lib/low/todo.rkt
@@ -0,0 +1,15 @@
+#lang racket
+
+(module m racket
+ (require syntax/parse
+ syntax/parse/experimental/template)
+ (provide (rename-out [template syntax]
+ [quasitemplate quasisyntax])
+ (all-from-out syntax/parse
+ syntax/parse/experimental/template)))
+
+(require 'm)
+
+(syntax-parse #'(a b)
+ [(x (~optional y) z)
+ #'(x (?? y 1) z)])
\ No newline at end of file