Added uniform-get, fixed most uses of the new constructor representation.
This commit is contained in:
Georges Dupéron
parent
26256a09b9
commit
e17c026a9d
|
|
@ -6,8 +6,7 @@
|
|||
"get.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"structure.lp2.rkt" ; debug
|
||||
"variant.lp2.rkt" ; debug
|
||||
"adt.lp2.rkt" ; debug
|
||||
"fold-queues.lp2.rkt"; debug
|
||||
"rewrite-type.lp2.rkt"; debug
|
||||
"meta-struct.rkt"; debug
|
||||
|
|
@ -22,6 +21,8 @@
|
|||
|#
|
||||
|
||||
|
||||
(require "../lib/debug-syntax.rkt")
|
||||
|
||||
(define-type blob String)
|
||||
(define-type-expander (bubble stx) #'String)
|
||||
|
||||
|
|
@ -52,18 +53,20 @@
|
|||
: (Listof Street)
|
||||
(map Street snames)])
|
||||
|
||||
#|
|
||||
|
||||
#;(super-define-graph/rich-return
|
||||
grr3
|
||||
([City [streets : (~> m-streets)]]
|
||||
[Street [sname : String]])
|
||||
[(m-cities [cnames : (Listof (Listof bubble))])
|
||||
: (Listof City)
|
||||
(define (strings→city [s : (Listof blob)])
|
||||
(City (m-streets s)))
|
||||
(map strings→city cnames)]
|
||||
[(m-streets [snames : (Listof String)])
|
||||
: (Listof Street)
|
||||
(map Street snames)])
|
||||
grr3
|
||||
([City [streets : (~> m-streets)]]
|
||||
[Street [sname : String]])
|
||||
[(m-cities [cnames : (Listof (Listof bubble))])
|
||||
: (Listof City)
|
||||
(define (strings→city [s : (Listof blob)])
|
||||
(City (m-streets s)))
|
||||
(map strings→city cnames)]
|
||||
[(m-streets [snames : (Listof String)])
|
||||
: (Listof Street)
|
||||
(map Street snames)])
|
||||
|
||||
#|
|
||||
|
||||
|
|
@ -82,4 +85,5 @@
|
|||
|
||||
(dg grr)
|
||||
(dg grra)
|
||||
|#
|
||||
|#
|
||||
|
|
@ -21,7 +21,7 @@
|
|||
(constructor dh1 Number String))
|
||||
(constructor dh1 2 "y"))
|
||||
|
||||
(define-private-tagged txyz #:? txyz?
|
||||
(define-tagged txyz #:private #:? txyz?
|
||||
[a Number]
|
||||
[b String])
|
||||
|
||||
|
|
@ -32,7 +32,7 @@
|
|||
(begin
|
||||
(module main typed/racket
|
||||
(require (for-syntax racket/list)
|
||||
"variant.lp2.rkt")
|
||||
"adt.lp2.rkt")
|
||||
<mainbody>)
|
||||
|
||||
(require 'main)
|
||||
|
|
@ -43,6 +43,6 @@
|
|||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
typed/rackunit
|
||||
"variant.lp2.rkt")
|
||||
"adt.lp2.rkt")
|
||||
|
||||
<testbody>))]
|
||||
|
|
@ -10,21 +10,33 @@
|
|||
|
||||
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}]
|
||||
@; TODO: put a short usage example here
|
||||
|
||||
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:
|
||||
@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{Users can define an uninterned tag, i.e. one which
|
||||
will not match against other uses of the same tag name. A
|
||||
constructor using this uninterned tag is a subtype of the
|
||||
constructor using the interned one, but not the reverse.
|
||||
This means that
|
||||
@racket[(constructor #:uninterned tag Number)] is a
|
||||
subtype of @racket[(constructor tag Number)], but not the
|
||||
opposite. This allows testing if a constructor instance
|
||||
was created by the rightful owner, or by some other code
|
||||
which happens to use the same name.}
|
||||
@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 is that unlike our library, 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:
|
||||
|
||||
@chunk[<datatype-no-sharing>
|
||||
(require datatype)
|
||||
|
|
@ -43,7 +55,7 @@ example below where the second @tc[define-datatype] throws an error:
|
|||
@section{Constructors, tagged, variants and structures}
|
||||
|
||||
We first define @tc[structure] and @tc[constructor], the
|
||||
primitives allowing us to build instance, match against them
|
||||
primitives allowing us to build instances, match against them
|
||||
and express the type itself.
|
||||
|
||||
@chunk[<require-modules>
|
||||
|
|
@ -51,7 +63,7 @@ and express the type itself.
|
|||
(require "constructor.lp2.rkt")]
|
||||
|
||||
We then define @tc[tagged], which is a shorthand for
|
||||
manipulating constructors which single value is a promise
|
||||
manipulating constructors whose single value is a promise
|
||||
for a structure.
|
||||
|
||||
@chunk[<require-modules>
|
||||
|
|
@ -66,7 +78,7 @@ thin wrapper against @tc[(U (~or constructor tagged) …)].
|
|||
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}.
|
||||
structures as described in the @secref{ADT|introduction}.
|
||||
|
||||
@chunk[<require-modules>
|
||||
(require "define-adt.lp2.rkt")]
|
||||
|
|
@ -77,31 +89,39 @@ operate on @tc[tagged] structures. We also wrap the plain
|
|||
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
|
||||
whose 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
|
||||
field: allowing
|
||||
@racket[(U structure
|
||||
(constructor structure)
|
||||
(constructor (Promise structure)))]
|
||||
would result in a type of size @${n⁴}, with ${n} then depth
|
||||
would result in a type of size @${n⁴}, with @${n} the depth
|
||||
of the accessed field.}
|
||||
|
||||
@chunk[<require-modules>
|
||||
(void)] @;(require "uniform-get.lp2.rkt")
|
||||
(require "uniform-get.lp2.rkt")]
|
||||
|
||||
@chunk[<*>
|
||||
(void)
|
||||
#;(begin
|
||||
(begin
|
||||
(module main typed/racket
|
||||
<require-modules>
|
||||
(provide constructor
|
||||
define-constructor
|
||||
ConstructorTop
|
||||
ConstructorTop?
|
||||
constructor?
|
||||
constructor-values
|
||||
tagged
|
||||
define-tagged
|
||||
variant
|
||||
define-variant
|
||||
(rename-out [wrapped-structure structure])
|
||||
(rename-out
|
||||
[wrapped-structure structure]
|
||||
[wrapped-structure-supertype structure-supertype]
|
||||
[structure plain-structure]
|
||||
[structure-supertype plain-structure-supertype]
|
||||
[define-structure define-plain-structure])
|
||||
uniform-get))
|
||||
|
||||
(require 'main)
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ 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}
|
||||
@section[#:tag "constructor|supertype"]{The @racket[ConstructorTop] supertype}
|
||||
|
||||
We define variants as instances of subtypes of the @tc[Tagged] structure:
|
||||
|
||||
|
|
@ -43,12 +43,31 @@ For this, we use the @tc[remember] library:
|
|||
|
||||
We pre-declare here in this file all the remembered constructors:
|
||||
|
||||
@CHUNK[<declare-constructor-struct>
|
||||
(define-syntax (declare-constructor-struct stx)
|
||||
(syntax-case stx ()
|
||||
[(_ name)
|
||||
#`(struct (T)
|
||||
name
|
||||
#,(syntax-local-introduce #'ConstructorTop)
|
||||
()
|
||||
#:transparent)]))]
|
||||
|
||||
@CHUNK[<declare-uninterned-constructor-struct>
|
||||
(define-syntax (declare-uninterned-constructor-struct stx)
|
||||
(syntax-parse stx
|
||||
[(_ name)
|
||||
(define/syntax-parse ((~maybe no-with-struct)) #'())
|
||||
(with-constructor-name→stx-name
|
||||
(parent no-with-struct #'name #'please-recompile stx)
|
||||
#'(struct (T)
|
||||
name
|
||||
parent
|
||||
()
|
||||
#:transparent))]))]
|
||||
|
||||
@CHUNK[<constructor-declarations>
|
||||
(struct (T)
|
||||
constructor-name/struct
|
||||
#,(syntax-local-introduce #'ConstructorTop)
|
||||
()
|
||||
#:transparent)
|
||||
(declare-constructor-struct constructor-name/struct)
|
||||
…]
|
||||
|
||||
We define an associative list which maps the constructor
|
||||
|
|
@ -214,7 +233,9 @@ instance:
|
|||
stx)
|
||||
(template
|
||||
((λ #:∀ (T …) ([arg : T] …)
|
||||
: (constructor constructor-name T …)
|
||||
: (constructor constructor-name
|
||||
(?? (?@ #:with-struct with-struct))
|
||||
T …)
|
||||
(stx-name (?? arg₀ (list argᵢ …))))
|
||||
value …))))]
|
||||
|
||||
|
|
@ -238,13 +259,18 @@ instance:
|
|||
(rename-out [ConstructorTop-values constructor-values]))
|
||||
|
||||
<constructor-top>
|
||||
<declare-constructor-struct>
|
||||
<remember-lib>
|
||||
<named-sorted-constructors>
|
||||
<declare-all-constructors>
|
||||
<with-constructor-name→stx-name>
|
||||
<declare-uninterned-constructor-struct>
|
||||
|
||||
<constructor>
|
||||
<predicate>)
|
||||
<predicate>
|
||||
|
||||
(module+ private
|
||||
(provide declare-constructor-struct)))
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
|
|
|||
|
|
@ -9,20 +9,60 @@
|
|||
|
||||
@section{Introduction}
|
||||
|
||||
@section{@racket[uninterned] and @racket[private]}
|
||||
|
||||
We wish to be able to declare tags and constructors only
|
||||
visible to the creator, unlike the default ones which can be
|
||||
instantiated and matched against anonymously.
|
||||
|
||||
We will define two flavours. In the first case,
|
||||
@tc[uninterned] constructors inherit the interned one. It
|
||||
means that the interned constructor is a supertype of the
|
||||
uninterned constructor (but not the converse). Two distinct
|
||||
uninterned constructors with the same name are unrelated
|
||||
too. The second possibility is to declare a @tc[private]
|
||||
constructor, where the private constructor inherits directly
|
||||
from @tc[ConstructorTop], the base structure described in
|
||||
section @secref{constructor|supertype}, and is therefore
|
||||
unrelated to the interned constructor (and is unrelated to
|
||||
the uninterned constructor too).
|
||||
|
||||
The choice to declare an uninterned or private
|
||||
|
||||
@CHUNK[<uninterned+private>
|
||||
(define/syntax-parse ((~maybe with-struct declare-uninterned/private))
|
||||
(cond [(attribute uninterned)
|
||||
#`(#,(syntax-local-introduce #'constructor-name)
|
||||
declare-uninterned-constructor-struct)]
|
||||
[(attribute private)
|
||||
#`(#,(syntax-local-introduce #'constructor-name)
|
||||
declare-constructor-struct)]
|
||||
[else #'()]))]
|
||||
|
||||
The above code binds @tc[declare-uninterned/private] to
|
||||
either @tc[declare-uninterned-constructor-struct] or
|
||||
@tc[declare-constructor-struct], depending on the keyword
|
||||
used. The macro's expansion will use this to declare
|
||||
@tc[with-struct].
|
||||
|
||||
@chunk[<declare-uninterned-or-private-struct>
|
||||
(?? (declare-uninterned/private with-struct))]
|
||||
|
||||
@section{@racket{define-constructor}}
|
||||
|
||||
@chunk[<define-constructor>
|
||||
(define-syntax/parse
|
||||
(define-constructor constructor-name:id
|
||||
(~maybe #:with-struct with-struct)
|
||||
(~maybe (~optkw #:uninterned) (~optkw #:private))
|
||||
(~maybe #:? name?)
|
||||
type …)
|
||||
|
||||
(define/with-syntax default-name? (format-id #'name "~a?" #'name))
|
||||
(define-temp-ids "pat" (type …))
|
||||
(define-temp-ids "value" (type …))
|
||||
<uninterned+private>
|
||||
(template
|
||||
(begin
|
||||
<declare-uninterned-or-private-struct>
|
||||
(define-multi-id constructor-name
|
||||
#:type-expand-once
|
||||
(constructor constructor-name
|
||||
|
|
@ -44,37 +84,220 @@
|
|||
(?? (?@ #:with-struct with-struct)))))))]
|
||||
|
||||
@chunk[<define-tagged>
|
||||
(define-syntax/parse (define-tagged tag:id
|
||||
(~maybe #:with-struct with-struct)
|
||||
(define-syntax/parse (define-tagged constructor-name:id
|
||||
(~maybe (~optkw #:uninterned) (~optkw #:private))
|
||||
(~maybe #:? name?)
|
||||
[field type] …)
|
||||
(define/with-syntax default-name? (format-id #'name "~a?" #'name))
|
||||
(define-temp-ids "pat" (type …))
|
||||
(define-temp-ids "value" (type …))
|
||||
<uninterned+private>
|
||||
(template
|
||||
(begin
|
||||
(define-multi-id tag
|
||||
<declare-uninterned-or-private-struct>
|
||||
(define-multi-id constructor-name
|
||||
#:type-expand-once
|
||||
(tagged tag
|
||||
(tagged constructor-name
|
||||
(?? (?@ #:with-struct with-struct))
|
||||
[field type] …)
|
||||
#:match-expander
|
||||
(λ/syntax-parse (_ pat …)
|
||||
#'(tagged tag
|
||||
#'(tagged constructor-name
|
||||
(?? (?@ #:with-struct with-struct))
|
||||
[field pat] …))
|
||||
#:call
|
||||
(λ/syntax-parse (_ value …)
|
||||
#'(tagged #:instance
|
||||
tag
|
||||
constructor-name
|
||||
(?? (?@ #:with-struct with-struct))
|
||||
value …)))
|
||||
[field value] …)))
|
||||
(define-multi-id (?? name? default-name?)
|
||||
#:else
|
||||
#'(tagged? tag
|
||||
#'(tagged? constructor-name
|
||||
(?? (?@ #:with-struct with-struct))
|
||||
field …)))))]
|
||||
|
||||
@section{Tests}
|
||||
|
||||
@chunk[<test-define-tagged>
|
||||
(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"))]
|
||||
|
||||
@chunk[<test-define-constructor>
|
||||
(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))]
|
||||
|
||||
@chunk[<test-private-tagged>
|
||||
(define-syntax-rule (defp make mt)
|
||||
(begin
|
||||
(define-tagged txyz #:private #:? 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 #:private #:? 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-not-equal?: (make) (txyz 1 "b"))
|
||||
(check-equal?: (match (make)
|
||||
((txyz x y) (list 'out y x))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mt (txyz 1 "b"))
|
||||
#f)]
|
||||
|
||||
@chunk[<test-private-constructor>
|
||||
(define-syntax-rule (defpc makec mtc)
|
||||
(begin
|
||||
(define-constructor cxyz #:private #:? 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 #:private #:? cxyz? Number String)
|
||||
|
||||
(check-equal?: (match (makec)
|
||||
((constructor cxyz e f) (list 'out f e))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mtc (constructor cxyz 1 "b"))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mtc (makec))
|
||||
'(macro "b" 1))
|
||||
|
||||
(check-not-equal?: (makec) (cxyz 1 "b"))
|
||||
(check-equal?: (match (makec)
|
||||
((cxyz e f) (list 'out f e))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mtc (cxyz 1 "b"))
|
||||
#f)]
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
@chunk[<*>
|
||||
|
|
@ -86,10 +309,16 @@
|
|||
racket/syntax
|
||||
(submod "../lib/low.rkt" untyped))
|
||||
(for-meta 2 racket/base)
|
||||
"constructor.lp2.rkt"
|
||||
(submod "constructor.lp2.rkt" main private)
|
||||
"tagged.lp2.rkt"
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
|
||||
(provide define-constructor
|
||||
define-tagged)
|
||||
|
||||
<define-constructor>
|
||||
<define-tagged>)
|
||||
|
||||
|
|
@ -98,5 +327,12 @@
|
|||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
"constructor.lp2.rkt"
|
||||
"tagged.lp2.rkt"
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")))]
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
|
||||
<test-define-constructor>
|
||||
<test-define-tagged>
|
||||
<test-private-constructor>
|
||||
<test-private-tagged>))]
|
||||
|
|
@ -103,14 +103,15 @@ otherwise throw an error:
|
|||
l))
|
||||
v)]
|
||||
[(_ v:expr field other-fields:id …)
|
||||
#'(let ([v-cache v])
|
||||
#'(get (uniform-get v field) other-fields …)
|
||||
#;#'(let ([v-cache v])
|
||||
(cond <get-tagged>
|
||||
<get-promise>
|
||||
<get-plain-struct>))])))]
|
||||
|
||||
@chunk[<get-tagged>
|
||||
[((make-predicate (List Symbol Any)) v-cache)
|
||||
(get (structure-get (cadr v-cache) field) other-fields …)]]
|
||||
(get (uniform-get v-cache field) other-fields …)]]
|
||||
|
||||
@chunk[<get-promise>
|
||||
[(promise? v-cache)
|
||||
|
|
@ -177,9 +178,9 @@ The type for the function generated by @tc[λget] mirrors the cases from
|
|||
|
||||
@chunk[<type-for-get-field>
|
||||
[(_ T:expr field:id other-fields:id …)
|
||||
#'(Promise
|
||||
(List Symbol
|
||||
(structure-supertype [field : (has-get T other-fields …)])))]]
|
||||
#'(ConstructorTop
|
||||
(Promise
|
||||
(plain-structure-supertype [field : (has-get T other-fields …)])))]]
|
||||
|
||||
@chunk[<result-type-for-get>
|
||||
(λ (stx)
|
||||
|
|
@ -203,8 +204,7 @@ The type for the function generated by @tc[λget] mirrors the cases from
|
|||
racket/syntax
|
||||
(submod "../lib/low.rkt" untyped))
|
||||
"../lib/low.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"adt.lp2.rkt"
|
||||
"graph.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
|
|
@ -216,7 +216,7 @@ The type for the function generated by @tc[λget] mirrors the cases from
|
|||
|
||||
(begin-for-syntax
|
||||
<c…r-syntax-class>)
|
||||
|
||||
|
||||
<get>
|
||||
<λget>)]
|
||||
|
||||
|
|
|
|||
|
|
@ -110,6 +110,7 @@ plain list.
|
|||
(define-temp-ids "~a/node-marker" (mapping …))
|
||||
(define-temp-ids "~a/from-first-pass" (node …))
|
||||
;(define/with-syntax id-~> (datum->syntax #'name '~>))
|
||||
(define/with-syntax introduced-~> (datum->syntax #'name '~>))
|
||||
<inline-temp-nodes>
|
||||
(quasitemplate/debug debug
|
||||
(begin
|
||||
|
|
@ -150,7 +151,7 @@ plain list.
|
|||
|
||||
@chunk[<replace-in-instance>
|
||||
(tmpl-replace-in-instance
|
||||
(Let ~> second-step-marker-expander field-type)
|
||||
(Let (introduced-~> second-step-marker-expander) field-type)
|
||||
<second-pass-replace>)]
|
||||
|
||||
@chunk[<second-pass-type-expander>
|
||||
|
|
@ -276,8 +277,7 @@ encapsulating the result types of mappings.
|
|||
"get.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"structure.lp2.rkt" ; debug
|
||||
"variant.lp2.rkt" ; debug
|
||||
"adt.lp2.rkt" ; debug
|
||||
"fold-queues.lp2.rkt"; debug
|
||||
"rewrite-type.lp2.rkt"; debug
|
||||
"meta-struct.rkt"; debug
|
||||
|
|
|
|||
|
|
@ -562,15 +562,11 @@ the @tc[tmpl-replace-in-type] template metafunction from the rewrite-type
|
|||
library. We replace all occurrences of a @tc[node] name with a @tc[Promise] for
|
||||
that node's @tc[with-promises] type.
|
||||
|
||||
@; TODO: use a type-expander here, instead of a template metafunction.
|
||||
|
||||
@; TODO: use a private-constructor here (single field, no need to use a
|
||||
@; structure with define-private-tagged).
|
||||
@CHUNK[<define-promise-type/first-step>
|
||||
(define-private-constructor node/promise-type
|
||||
(define-constructor node/promise-type #:private
|
||||
(Promise node/with-promises))]
|
||||
@CHUNK[<define-with-promises>
|
||||
(define-structure node/with-promises
|
||||
(define-plain-structure node/with-promises
|
||||
[field <field/with-promises-type>] …)]
|
||||
|
||||
@CHUNK[<field/with-promises-type>
|
||||
|
|
@ -599,6 +595,7 @@ library. We replace all occurrences of a @tc[node] name with its
|
|||
|
||||
@chunk[<define-field/incomplete-type>
|
||||
(define-type field/incomplete-type <field/incomplete-type>)]
|
||||
|
||||
@chunk[<field/incomplete-type>
|
||||
(tmpl-replace-in-type field-type
|
||||
[node node/placeholder-type] …)]
|
||||
|
|
@ -766,11 +763,9 @@ We will be able to use this type expander in function types, for example:
|
|||
x)
|
||||
(check-equal?:
|
||||
(let* ([v1 (car
|
||||
(structure-get (force (Tagged-value g))
|
||||
streets))]
|
||||
(uniform-get g streets))]
|
||||
[v2 (ann (type-example v1) (gr Street))]
|
||||
[v3 (structure-get (force (Tagged-value v2))
|
||||
sname)])
|
||||
[v3 (uniform-get v2 sname)])
|
||||
v3)
|
||||
: String
|
||||
"Ada Street")]
|
||||
|
|
@ -791,8 +786,7 @@ We will be able to use this type expander in function types, for example:
|
|||
"fold-queues.lp2.rkt"
|
||||
"rewrite-type.lp2.rkt"
|
||||
"../lib/low.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"adt.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"meta-struct.rkt")
|
||||
|
|
@ -815,27 +809,8 @@ not match the one from @tc[typed/racket]
|
|||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
(only-in "../lib/low.rkt" cars cdrs check-equal?:)
|
||||
(only-in "structure.lp2.rkt" structure-get)
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
typed/rackunit
|
||||
;;DEBUG:
|
||||
(for-syntax syntax/parse
|
||||
racket/syntax
|
||||
syntax/parse/experimental/template
|
||||
racket/sequence
|
||||
racket/pretty
|
||||
"rewrite-type.lp2.rkt"
|
||||
(submod "../lib/low.rkt" untyped)
|
||||
"meta-struct.rkt")
|
||||
racket/splicing
|
||||
"fold-queues.lp2.rkt"
|
||||
"rewrite-type.lp2.rkt"
|
||||
"../lib/low.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"meta-struct.rkt")
|
||||
(only-in "adt.lp2.rkt" uniform-get)
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
|
||||
(provide g)
|
||||
<use-example>
|
||||
|
|
|
|||
|
|
@ -160,3 +160,11 @@
|
|||
(constructor . Number)
|
||||
(constructor . String)
|
||||
(constructor . Number)
|
||||
(constructor . c1)
|
||||
(constructor . c2)
|
||||
(constructor . c3)
|
||||
(constructor . wrapped-structure)
|
||||
(constructor . structure)
|
||||
(constructor . structure)
|
||||
(constructor . wstructure)
|
||||
(constructor . wstructure)
|
||||
|
|
|
|||
|
|
@ -519,7 +519,17 @@ functions is undefined.
|
|||
[((~literal quote) a)
|
||||
#'(inst values 'a acc-type)]
|
||||
[x:id
|
||||
#'(inst values x acc-type)]))]
|
||||
#'(inst values x acc-type)]
|
||||
[_
|
||||
(raise-syntax-error 'recursive-replace-4
|
||||
(format (string-append "Syntax-parse failed\n"
|
||||
" ~a\n"
|
||||
" expanded to ~a")
|
||||
(syntax->datum type)
|
||||
(syntax->datum (expand-type type)))
|
||||
`(recursive-replace-4 ,(current-replacement))
|
||||
#f
|
||||
(list type))]))]
|
||||
|
||||
@subsection{Union types}
|
||||
|
||||
|
|
@ -648,8 +658,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
|
|||
(only-in "../type-expander/type-expander.lp2.rkt"
|
||||
expand-type)
|
||||
"meta-struct.rkt")
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../lib/low.rkt")
|
||||
|
|
@ -683,8 +691,6 @@ These metafunctions just extract the arguments for @tc[replace-in-type] and
|
|||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
typed/rackunit
|
||||
"structure.lp2.rkt"
|
||||
"variant.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -32,8 +32,9 @@ for a structure.
|
|||
. structure-type)
|
||||
(quasitemplate
|
||||
(constructor tag (?? (?@ #:with-struct with-struct))
|
||||
#,(syntax/loc #'structure-type
|
||||
(structure . structure-type)))))]
|
||||
(Promise
|
||||
#,(syntax/loc #'structure-type
|
||||
(structure . structure-type))))))]
|
||||
|
||||
@subsection{@racket[match-expander]}
|
||||
|
||||
|
|
@ -42,8 +43,10 @@ for a structure.
|
|||
. structure-pat)
|
||||
(quasitemplate
|
||||
(constructor tag (?? (?@ #:with-struct with-struct))
|
||||
#,(syntax/loc #'structure-pat
|
||||
(structure . structure-pat)))))]
|
||||
(? promise?
|
||||
(app force
|
||||
#,(syntax/loc #'structure-pat
|
||||
(structure . structure-pat)))))))]
|
||||
|
||||
@subsection{@racket[instance creation]}
|
||||
|
||||
|
|
@ -62,30 +65,39 @@ for a structure.
|
|||
(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] …)))))))
|
||||
(quasitemplate <make-instance-with-types>)
|
||||
(quasitemplate <make-instance-infer>)))
|
||||
(if (attribute sa.value)
|
||||
#'(c sa.value …)
|
||||
#'c))]
|
||||
|
||||
@subsection{@racket[predicate]}
|
||||
@CHUNK[<make-instance-with-types>
|
||||
(λ ([sa.field/arg : sa.type] …)
|
||||
: (constructor tag (?? (?@ #:with-struct with-struct))
|
||||
(Promise
|
||||
#,(syntax/loc #'fields
|
||||
(structure [sa.field sa.type] …))))
|
||||
(constructor tag (?? (?@ #:with-struct with-struct))
|
||||
#,(syntax/loc #'fields
|
||||
(delay
|
||||
(structure #:instance
|
||||
[sa.field : sa.type sa.field/arg]
|
||||
…)))))]
|
||||
|
||||
|
||||
@CHUNK[<make-instance-infer>
|
||||
(λ #:∀ (sa.field/TTemp …) ([sa.field/arg : sa.field/TTemp] …)
|
||||
: (constructor tag (?? (?@ #:with-struct with-struct))
|
||||
(Promise
|
||||
#,(syntax/loc #'fields
|
||||
(structure [sa.field sa.field/TTemp] …))))
|
||||
(constructor tag (?? (?@ #:with-struct with-struct))
|
||||
#,(syntax/loc #'fields
|
||||
(delay
|
||||
(structure #:instance
|
||||
[sa.field sa.field/arg] …)))))]
|
||||
|
||||
@subsection{Predicate}
|
||||
|
||||
@CHUNK[<tagged-top?>
|
||||
(define-multi-id TaggedTop?
|
||||
|
|
|
|||
78
graph-lib/graph/uniform-get.lp2.rkt
Normal file
78
graph-lib/graph/uniform-get.lp2.rkt
Normal file
|
|
@ -0,0 +1,78 @@
|
|||
#lang scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
|
||||
@title[#:style manual-doc-style]{Algebaraic Data Types: @racket[uniform-get]}
|
||||
|
||||
@(table-of-contents)
|
||||
|
||||
@section{Introduction}
|
||||
|
||||
@section{Wrapped structures}
|
||||
|
||||
@chunk[<wrapped-structure>
|
||||
;; Pre-declare the tag.
|
||||
(let ()
|
||||
(tagged #:instance wstructure)
|
||||
(void))
|
||||
|
||||
(define-multi-id wrapped-structure
|
||||
#:type-expander
|
||||
(λ/syntax-parse (_ . rest)
|
||||
#'(tagged wstructure (structure . rest)))
|
||||
#:match-expander
|
||||
(λ/syntax-parse (_ . rest)
|
||||
#'(tagged wstructure (structure . rest)))
|
||||
#:call
|
||||
(λ/syntax-parse (_ . rest)
|
||||
#'(tagged wstructure (structure . rest))))
|
||||
|
||||
(define-type-expander (wrapped-structure-supertype stx)
|
||||
(syntax-case stx ()
|
||||
[(_ . rest)
|
||||
#'(constructor wstructure
|
||||
(Promise
|
||||
(structure-supertype . rest)))]))]
|
||||
|
||||
@section{@racket[uniform-get]}
|
||||
|
||||
@racket[uniform-get] operates on tagged structures. It
|
||||
retrieves the desired field from the structure.
|
||||
|
||||
@chunk[<uniform-get>
|
||||
(define-syntax-rule (uniform-get v field)
|
||||
(structure-get (force (constructor-values v)) 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))
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"constructor.lp2.rkt"
|
||||
"tagged.lp2.rkt"
|
||||
"structure.lp2.rkt"
|
||||
"define-adt.lp2.rkt")
|
||||
|
||||
(provide wrapped-structure
|
||||
wrapped-structure-supertype
|
||||
uniform-get)
|
||||
|
||||
<wrapped-structure>
|
||||
<uniform-get>)
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
))]
|
||||
|
|
@ -1,330 +0,0 @@
|
|||
#lang scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
|
||||
@title[#:style manual-doc-style]{Variants}
|
||||
|
||||
@(table-of-contents)
|
||||
|
||||
@section{@racket[tagged]}
|
||||
|
||||
@section{@racket[define-tagged]}
|
||||
|
||||
@chunk[<define-tagged>
|
||||
(define-syntax/parse (define-tagged tag:id
|
||||
(~maybe #:? tag?)
|
||||
[field type] …)
|
||||
(define/with-syntax (pat …) (generate-temporaries #'(field …)))
|
||||
(define/with-syntax (value …) (generate-temporaries #'(field …)))
|
||||
(define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
|
||||
(template
|
||||
(begin
|
||||
(define-multi-id tag
|
||||
#:type-expand-once
|
||||
(tagged tag [field type] …)
|
||||
#:match-expander
|
||||
(λ/syntax-parse (_ pat …)
|
||||
#'(tagged tag [field pat] …))
|
||||
#:call
|
||||
(λ/syntax-parse (_ value …)
|
||||
#'(tagged tag #:instance [field value] …)))
|
||||
(: (?? tag? default-tag?) (→ Any Boolean))
|
||||
(define ((?? tag? default-tag?) x)
|
||||
(and (Tagged-predicate? tag x)
|
||||
((structure? field …) (Tagged-value x)))))))]
|
||||
|
||||
@chunk[<test-define-tagged>
|
||||
(define-tagged tagged-s1)
|
||||
(define-tagged tagged-s2 [f Fixnum] [g String])
|
||||
(define-tagged tagged-s3 [g String] [f Fixnum])
|
||||
(define-tagged tagged-s4 [f Fixnum] [g String])
|
||||
|
||||
(check-equal?: (match (ann (tagged-s1) (tagged tagged-s1))
|
||||
[(tagged-s1) #t])
|
||||
#t)
|
||||
|
||||
(check-equal?: (match (ann (tagged-s2 99 "z") tagged-s2)
|
||||
[(tagged-s2 f g) (cons g f)])
|
||||
'("z" . 99))
|
||||
|
||||
(let ()
|
||||
(check-equal?: (match (ann (tagged-s2 99 "in-let") tagged-s2)
|
||||
[(tagged-s2 f g) (cons g f)])
|
||||
'("in-let" . 99)))
|
||||
|
||||
(define (test-match val)
|
||||
(match val
|
||||
[(tagged-s2 x y) (list 'found-s2 y x)]
|
||||
[(tagged-s3 x y) (list 'found-s3 y x)]
|
||||
[(tagged-s4 x y) (list 'found-s4 y x)]))
|
||||
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s2 2 "flob")
|
||||
(tagged tagged-s2 [f Fixnum] [g String])))
|
||||
'(found-s2 "flob" 2))
|
||||
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s3 "flob" 2)
|
||||
(tagged tagged-s3 [g String] [f Fixnum])))
|
||||
'(found-s3 2 "flob"))
|
||||
|
||||
;; g and f are inverted in the “ann”
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s4 2 "flob")
|
||||
(tagged tagged-s4 [g String] [f Fixnum])))
|
||||
'(found-s4 "flob" 2))
|
||||
|
||||
(define (test-match-verbose val)
|
||||
(match val
|
||||
[(tagged tagged-s2 g [f y]) (list 'found-s2 g y)]
|
||||
[(tagged tagged-s3 [g y] f) (list 'found-s2 f y)]
|
||||
[(tagged tagged-s4 [f y] g) (list 'found-s2 g y)]))
|
||||
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s2 3 "flob")
|
||||
(tagged tagged-s2 [f Fixnum] [g String])))
|
||||
'(found-s2 "flob" 3))
|
||||
|
||||
;; g and f are inverted in the “ann”
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s3 "flob" 3)
|
||||
(tagged tagged-s3 [f Fixnum] [g String])))
|
||||
'(found-s3 3 "flob"))
|
||||
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s4 3 "flob")
|
||||
(tagged tagged-s4 [f Fixnum] [g String])))
|
||||
'(found-s4 "flob" 3))
|
||||
|
||||
(check-not-equal?: (tagged-s2 4 "flob")
|
||||
(tagged-s3 "flob" 4))
|
||||
(check-not-equal?: (tagged-s2 4 "flob")
|
||||
(tagged-s4 4 "flob"))]
|
||||
|
||||
@section{Uninterned tags}
|
||||
|
||||
We wish to be able to declare tags only visible to the
|
||||
creator, unlike the ones above which are visible
|
||||
everywhere.
|
||||
|
||||
We will define two flavours: one where uninterned tags
|
||||
inherit the interned tag, os that the interned @tc[tag] is a
|
||||
supertype of the uninterned @tc[tag] (but not the converse),
|
||||
and a second, which we will call private tags, where the
|
||||
private tag inherits directly from @tc[Tagged], the base
|
||||
structure described in section @secref{variant|supertype},
|
||||
and is therefore unrelated to the interned @tc[tag] (nor to
|
||||
the uninterned @tc[tag] either).
|
||||
|
||||
@; TODO: this should be integrated a bit better with other function, for example
|
||||
@; Tagged-predicate? (provided as Tagged?) is likely to not work on uninterned
|
||||
@; tags.
|
||||
|
||||
@chunk[<define-uninterned-tagged>
|
||||
(define-syntax/parse
|
||||
(define-private-tagged tag:id
|
||||
(~maybe #:? tag?)
|
||||
. (~and structure-type
|
||||
([field (~optional (~and C :colon)) type] …)))
|
||||
(define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
|
||||
(define-temp-ids "~a/struct" tag)
|
||||
(define-temp-ids "~a/arg" (field …))
|
||||
(define-temp-ids "~a/pat" (field …))
|
||||
(template
|
||||
(begin
|
||||
(struct (T) tag/struct Tagged ()) ; Private
|
||||
;(struct (T) tag/struct interned ()) ; Uninterned
|
||||
(define-multi-id tag
|
||||
#:type-expand-once
|
||||
(tag/struct (structure . structure-type))
|
||||
#:match-expander
|
||||
(λ/syntax-parse (_ . (~and structure-pat
|
||||
((~and field/pat :expr) …)))
|
||||
(quasitemplate
|
||||
(and (? (make-predicate (tag/struct Any)))
|
||||
(app Tagged-value
|
||||
#,(syntax/loc #'structure-pat
|
||||
(structure [field field/pat] …))))))
|
||||
#:call
|
||||
(λ/syntax-parse (_ . (~and args ((~and field/arg :expr) …)))
|
||||
(quasitemplate
|
||||
(tag/struct #,(syntax/loc #'args
|
||||
(structure #:instance
|
||||
[field : type field/arg] …))))))
|
||||
;; TODO: the return type is not precise enough, it should be:
|
||||
;; #:+ (tag/struct (structure Any …))
|
||||
;; #:- (! (tag/struct (structure Any …)))
|
||||
(: (?? tag? default-tag?) (→ Any Boolean :
|
||||
#:+ (tag/struct Any)))
|
||||
(define ((?? tag? default-tag?) x)
|
||||
(and ((make-predicate (tag/struct Any)) x)
|
||||
((structure? field …) (Tagged-value x)))))))]
|
||||
|
||||
@chunk[<define-uninterned-constructor>
|
||||
(define-syntax/parse
|
||||
(define-private-constructor tag:id
|
||||
(~maybe #:? tag?)
|
||||
T:expr …)
|
||||
(define/with-syntax default-tag? (format-id #'tag "~a?" #'tag))
|
||||
(define-temp-ids "~a/struct" tag)
|
||||
(define-temp-ids "~a/arg" (T …))
|
||||
(define-temp-ids "~a/pat" (T …))
|
||||
(define/syntax-parse (~or ([T₀:expr arg₀ pat₀])
|
||||
([Tᵢ:expr argᵢ patᵢ] …))
|
||||
#'([T T/arg T/pat] …))
|
||||
(template
|
||||
(begin
|
||||
(struct (X) tag/struct Tagged ()) ; Private
|
||||
;(struct (X) tag/struct interned ()) ; Uninterned
|
||||
(define-multi-id tag
|
||||
#:type-expand-once
|
||||
(tag/struct (?? T₀ (List Tᵢ …)))
|
||||
#:match-expander
|
||||
(λ/syntax-parse (_ . (~and pats (?? ((~and pat₀ :expr))
|
||||
((~and patᵢ :expr) …))))
|
||||
(quasitemplate
|
||||
(and (? (make-predicate (tag/struct Any)))
|
||||
(app Tagged-value
|
||||
#,(syntax/loc #'pats
|
||||
(?? pat₀ (list patᵢ …)))))))
|
||||
#:call
|
||||
(λ/syntax-parse (_ . (~and args (?? ((~and arg₀ :expr))
|
||||
((~and argᵢ :expr) …))))
|
||||
(quasitemplate
|
||||
(tag/struct #,(syntax/loc #'args
|
||||
(?? arg₀ (list argᵢ …)))))))
|
||||
(: (?? tag? default-tag?) (→ Any Boolean : (tag/struct Any)))
|
||||
(define ((?? tag? default-tag?) x)
|
||||
((make-predicate (tag/struct Any)) x)))))]
|
||||
|
||||
@chunk[<test-uninterned-tagged>
|
||||
(define-syntax-rule (defp make mt)
|
||||
(begin
|
||||
(define-private-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-private-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-not-equal?: (make) (txyz 1 "b"))
|
||||
(check-equal?: (match (make)
|
||||
((txyz x y) (list 'out y x))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mt (txyz 1 "b"))
|
||||
#f)]
|
||||
|
||||
@chunk[<test-uninterned-constructor>
|
||||
(define-syntax-rule (defpc makec mtc)
|
||||
(begin
|
||||
(define-private-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-private-constructor cxyz #:? cxyz? Number String)
|
||||
|
||||
(check-equal?: (match (makec)
|
||||
((constructor cxyz e f) (list 'out f e))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mtc (constructor cxyz 1 "b"))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mtc (makec))
|
||||
'(macro "b" 1))
|
||||
|
||||
(check-not-equal?: (makec) (cxyz 1 "b"))
|
||||
(check-equal?: (match (makec)
|
||||
((cxyz e f) (list 'out f e))
|
||||
(_ #f))
|
||||
#f)
|
||||
|
||||
(check-equal?: (mtc (cxyz 1 "b"))
|
||||
#f)]
|
||||
|
||||
@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"
|
||||
"structure.lp2.rkt")
|
||||
(provide (rename-out [Tagged-predicate? Tagged?]
|
||||
[Tagged-type TaggedTop])
|
||||
Tagged-value
|
||||
constructor
|
||||
define-variant
|
||||
define-private-tagged
|
||||
define-private-constructor)
|
||||
|
||||
<variant-supertype>
|
||||
<remember-tags>
|
||||
<named-sorted-tags>
|
||||
<declare-all-tags>
|
||||
<tag-name→stx-name>
|
||||
|
||||
<predicate>
|
||||
<constructor>
|
||||
<define-variant>
|
||||
<tagged>
|
||||
<define-tagged>
|
||||
<define-uninterned-tagged>
|
||||
<define-uninterned-constructor>
|
||||
|
||||
(module+ test-helpers
|
||||
#;(provide Tagged-value)))
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
(submod ".." main test-helpers)
|
||||
typed/rackunit
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
|
||||
<test-constructor>
|
||||
<test-define-variant>
|
||||
<test-tagged>
|
||||
<test-define-tagged>
|
||||
<test-uninterned-tagged>
|
||||
<test-uninterned-constructor>))]
|
||||
61
graph-lib/graph/variant.lp2.rkt.old
Normal file
61
graph-lib/graph/variant.lp2.rkt.old
Normal file
|
|
@ -0,0 +1,61 @@
|
|||
#lang scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
|
||||
@section{Uninterned tags}
|
||||
|
||||
@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"
|
||||
"structure.lp2.rkt")
|
||||
(provide (rename-out [Tagged-predicate? Tagged?]
|
||||
[Tagged-type TaggedTop])
|
||||
Tagged-value
|
||||
constructor
|
||||
define-variant
|
||||
define-private-tagged
|
||||
define-private-constructor)
|
||||
|
||||
<variant-supertype>
|
||||
<remember-tags>
|
||||
<named-sorted-tags>
|
||||
<declare-all-tags>
|
||||
<tag-name→stx-name>
|
||||
|
||||
<predicate>
|
||||
<constructor>
|
||||
<define-variant>
|
||||
<tagged>
|
||||
<define-tagged>
|
||||
<define-uninterned-tagged>
|
||||
<define-uninterned-constructor>
|
||||
|
||||
(module+ test-helpers
|
||||
#;(provide Tagged-value)))
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
(submod ".." main test-helpers)
|
||||
typed/rackunit
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt")
|
||||
|
||||
<test-constructor>
|
||||
<test-define-variant>
|
||||
<test-tagged>
|
||||
<test-define-tagged>
|
||||
<test-uninterned-tagged>
|
||||
<test-uninterned-constructor>))]
|
||||
|
|
@ -10,8 +10,7 @@
|
|||
(r/p "lib/low.rkt"
|
||||
"type-expander/multi-id.lp2.rkt"
|
||||
"type-expander/type-expander.lp2.rkt"
|
||||
"graph/structure.lp2.rkt"
|
||||
"graph/variant.lp2.rkt"
|
||||
"graph/adt.lp2.rkt"
|
||||
"graph/graph.lp2.rkt"
|
||||
"graph/get.lp2.rkt"
|
||||
"graph/map.rkt"
|
||||
|
|
|
|||
|
|
@ -18,7 +18,9 @@ In section @secref{doc/example|foo} we present, blah blah.
|
|||
|
||||
@subsection[#:tag "doc/example|foo"]{My subsection}
|
||||
|
||||
@$${\frac{2x}{x^2}}
|
||||
@$${\frac{\href{//jsmaniac.github.io}{2x}}{\class{some-css-class}{x^2}}}
|
||||
|
||||
|
||||
@(colorize (filled-ellipse 30 15) "blue")
|
||||
@; Line comment
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@
|
|||
|
||||
(require "type-expander/type-expander.lp2.rkt")
|
||||
(require "type-expander/multi-id.lp2.rkt")
|
||||
(require "graph/variant.lp2.rkt")
|
||||
(require "graph/adt.lp2.rkt")
|
||||
|#
|
||||
|
||||
#|
|
||||
|
|
@ -109,7 +109,7 @@
|
|||
(module m typed/racket
|
||||
(provide ma)
|
||||
(require "type-expander/type-expander.lp2.rkt")
|
||||
(require "graph/variant.lp2.rkt")
|
||||
(require "graph/adt.lp2.rkt")
|
||||
|
||||
;(let ()
|
||||
;(define-tagged ma (fav String))
|
||||
|
|
|
|||
|
|
@ -83,6 +83,8 @@ else.
|
|||
|
||||
@chunk[<apply-type-expander>
|
||||
(define (apply-type-expander type-expander-stx stx)
|
||||
(displayln type-expander-stx)
|
||||
(displayln (syntax->datum type-expander-stx))
|
||||
(let ([type-expander (syntax-local-value type-expander-stx)])
|
||||
(((get-prop:type-expander-value type-expander) type-expander) stx)))]
|
||||
|
||||
|
|
@ -133,9 +135,15 @@ else.
|
|||
. args) ;; TODO: test
|
||||
#:with expanded-once
|
||||
#'(nested-application.expanded-once . args))
|
||||
(pattern (~datum ~>)
|
||||
(pattern (~and xxx (~datum ~>))
|
||||
#:with expanded-once #'()
|
||||
#:when (displayln (format "dict = ~a" (dict->list env)))
|
||||
#:when (display (format "dict =\n "))
|
||||
#:when (displayln (dict->list env))
|
||||
#:when (displayln #'xxx)
|
||||
#:when (newline)
|
||||
#:when (pretty-write (map syntax-debug-info
|
||||
(map car (dict->list env))))
|
||||
#:when (pretty-write (syntax-debug-info #'xxx))
|
||||
#:when #f))
|
||||
|
||||
(define-syntax-class fa (pattern (~or (~literal ∀) (~literal All))))
|
||||
|
|
@ -155,7 +163,8 @@ else.
|
|||
#,(expand-type #'T (bind-type-vars #'(TVar ...) env)))]
|
||||
[((~literal Rec) R:id T:expr)
|
||||
#`(Rec R #,(expand-type #'T (bind-type-vars #'(R) env)))]
|
||||
[((~datum Let) [V:id E:id] T:expr);; TODO: ~literal instead of ~datum
|
||||
[((~commit (~datum Let)) [V:id E:id] T:expr)
|
||||
;; TODO: ~literal instead of ~datum
|
||||
;; TODO: ~commit when we find Let, so that syntax errors are not
|
||||
;; interpreted as an arbitrary call.
|
||||
;; TODO : for now we only allow aliasing (which means E is an id),
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user