Fixed FB case 117 Make variant use structs, instead of tagged lists.
This commit is contained in:
Georges Dupéron
parent
5c7e49bebb
commit
7233cb85e9
44
graph-lib/graph/__DEBUG_variant.rkt
Normal file
44
graph-lib/graph/__DEBUG_variant.rkt
Normal file
|
|
@ -0,0 +1,44 @@
|
|||
#lang scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
|
||||
@title[#:style manual-doc-style]{Variants}
|
||||
|
||||
@(table-of-contents)
|
||||
|
||||
@section{Introduction}
|
||||
|
||||
@chunk[<mainbody>
|
||||
(constructor de1 2 "y")
|
||||
(constructor de2 2 "y")
|
||||
(constructor de3 2 "y")]
|
||||
|
||||
@chunk[<testbody>
|
||||
;; check-equal?: and ann (for the value part only, not for the type part)
|
||||
;; these break the error reporting mechanism, and we only have
|
||||
;; "please-recompile: unbound identifier in module".
|
||||
(check-equal?: (ann (constructor dh1 2 "y")
|
||||
(constructor dh1 Number String))
|
||||
(constructor dh1 2 "y"))
|
||||
|
||||
(ann (constructor dk1 2 "y")
|
||||
(constructor dk1 Number String))]
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
(module main typed/racket
|
||||
(require (for-syntax racket/list)
|
||||
"variant.lp2.rkt")
|
||||
<mainbody>)
|
||||
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main))
|
||||
|
||||
(module* test typed/racket
|
||||
(require (submod "..")
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
typed/rackunit
|
||||
"variant.lp2.rkt")
|
||||
|
||||
<testbody>))]
|
||||
138
graph-lib/graph/problems2.rkt
Normal file
138
graph-lib/graph/problems2.rkt
Normal file
|
|
@ -0,0 +1,138 @@
|
|||
#lang typed/racket
|
||||
|
||||
(require typed/rackunit)
|
||||
|
||||
;; tagged
|
||||
(begin
|
||||
;; Base struct for all tagged values
|
||||
(struct (B) tagged ([value : B]))
|
||||
|
||||
;; (define-tagged a T)
|
||||
;; Use tag-a just for match and (get …)
|
||||
(struct (B) tag-a tagged ()) ;; "remember" this one
|
||||
;; (define-tagged #:uninterned a T)
|
||||
(struct (B) tag-a-1 tag-a ()) ;; do not "rembmer" the #:uninterned ones
|
||||
;; (define-tagged #:uninterned a T)
|
||||
(struct (B) tag-a-2 tag-a ())
|
||||
;; (define-tagged #:uninterned a T)
|
||||
(struct (B) tag-a-3 tag-a ())
|
||||
;; (define-tagged b T)
|
||||
(struct (B) tag-b tagged ())
|
||||
|
||||
;; instanciation:
|
||||
(tag-a "ice")
|
||||
|
||||
(define-syntax-rule (define-pred name? tag?)
|
||||
(define-match-expander name?
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ v)
|
||||
#'(and (? tag?) (app tagged-value v))]))))
|
||||
|
||||
(define-pred tagged-a-1? tag-a-1?)
|
||||
(define-pred tagged-a-2? tag-a-2?)
|
||||
(define-pred tagged-a? tag-a?)
|
||||
(define-pred tagged-b? tag-b?)
|
||||
|
||||
(check-true (tag-a? (tag-a "water")))
|
||||
(check-true (tag-a-1? (tag-a-1 "fire")))
|
||||
(check-true (tag-a-1? (tag-a-1 "air")))
|
||||
(check-false (tag-a-1? (tag-a-2 "earth")))
|
||||
(check-false (tag-a-1? (tag-a "salt")))
|
||||
(check-false (tag-b? (tag-a "mercury")))
|
||||
(check-false (tag-b? (tag-a-1 "alchemy")))
|
||||
|
||||
(λ ([x : (U (tag-a-1 String)
|
||||
(tag-a-2 Number)
|
||||
(tag-b Symbol))])
|
||||
: (U Number String)
|
||||
;; Match should expand to this:
|
||||
(match x
|
||||
[(tagged-a? v) v]
|
||||
[(tagged-b? v) (symbol->string v)]))
|
||||
|
||||
(λ ([x : (U (tag-a-1 String)
|
||||
(tag-a-2 String)
|
||||
(tag-a String)
|
||||
(tag-b Symbol))])
|
||||
: String
|
||||
;; Match should expand to this
|
||||
(match x
|
||||
[(tagged-a-1? v) (string-append v "-1")]
|
||||
[(tagged-a-2? v) (string-append v "-2")]
|
||||
[(tagged-a? v) (string-append v "-base")]
|
||||
[(tagged-b? v) (symbol->string v)])))
|
||||
|
||||
;; struct
|
||||
(begin
|
||||
;; The structs seem to work well the way they are currently defined (using
|
||||
;; "remember" to know all the structs with a given field).
|
||||
|
||||
;; (define-struct [x : Number] [y : String])
|
||||
(struct (X Y) structure+x+y ([x : X] [y : Y])) ;; "remember"
|
||||
(define-type structure+x=number+y=string (structure+x+y Number String))
|
||||
|
||||
;; (define-struct [x : Number] [y : String] [z : Symbol])
|
||||
(struct (X Y Z) structure+x+y+z ([x : X] [y : Y] [z : Z])) ;; "remember"
|
||||
(define-type structure+x=number+y=string+z=symbol
|
||||
(structure+x+y+z Number String Symbol))
|
||||
|
||||
;; (define-struct [z : Symbol])
|
||||
(struct (Z) structure+z ([z : Z])) ;; "remember"
|
||||
(define-type structure+z=symbol (structure+z Symbol))
|
||||
|
||||
;; (define-struct [x : Symbol])
|
||||
(struct (X) structure+x ([x : X])) ;; "remember"
|
||||
(define-type structure+x=symbol (structure+x Symbol))
|
||||
|
||||
;; (has-get [x Number])
|
||||
(define-type (has-get+x X) (U (structure+x X)
|
||||
(structure+x+y X Any)
|
||||
(structure+x+y+z X Any Any)))
|
||||
(define-type has-get+x=number (has-get+x Number))
|
||||
|
||||
;; (has-get [y Number])
|
||||
(define-type (has-get+y Y) (U (structure+x+y Any Y)
|
||||
(structure+x+y+z Any Y Any)))
|
||||
(define-type has-get+y=number (has-get+y Number))
|
||||
|
||||
;; (has-get [z Number])
|
||||
(define-type (has-get+z Z) (U (structure+z Z)
|
||||
(structure+x+y+z Any Any Z)))
|
||||
(define-type has-get+z=number (has-get+z Number))
|
||||
|
||||
;; (get v x)
|
||||
(define get-x
|
||||
(λ #:∀ (X) ([s : (has-get+x X)]) : X
|
||||
(cond
|
||||
[(structure+x? s) (structure+x-x s)]
|
||||
[(structure+x+y? s) (structure+x+y-x s)]
|
||||
[(structure+x+y+z? s) (structure+x+y+z-x s)])))
|
||||
|
||||
;; (get v y)
|
||||
(define get-y
|
||||
(λ #:∀ (Y) ([s : (has-get+y Y)]) : Y
|
||||
(cond
|
||||
[(structure+x+y? s) (structure+x+y-y s)]
|
||||
[(structure+x+y+z? s) (structure+x+y+z-y s)])))
|
||||
|
||||
;; (get v z)
|
||||
(define get-z
|
||||
(λ #:∀ (Z) ([s : (has-get+z Z)]) : Z
|
||||
(cond
|
||||
[(structure+z? s) (structure+z-z s)]
|
||||
[(structure+x+y+z? s) (structure+x+y+z-z s)]))))
|
||||
|
||||
;; graph
|
||||
(begin
|
||||
;; define-graph
|
||||
(define-type g-test (tag-a-1 (structure+x+y String g-test)))
|
||||
(define-type g (tag-a-2 (structure+x+y+z String g Number)))
|
||||
;; pass:
|
||||
(λ ([root-node : (U g g-test)])
|
||||
(ann (match root-node
|
||||
[(tagged-a-1? s) (string-length (get-x s))]
|
||||
[(tagged-a-2? s) (get-z s)])
|
||||
Number)
|
||||
(cons (get-x (tagged-value root-node))
|
||||
(get-y (tagged-value root-node)))))
|
||||
154
graph-lib/graph/remember-lib.rkt
Normal file
154
graph-lib/graph/remember-lib.rkt
Normal file
|
|
@ -0,0 +1,154 @@
|
|||
#lang scribble/lp2
|
||||
@(require "../lib/doc.rkt")
|
||||
@doc-lib-setup
|
||||
|
||||
@title[#:style manual-doc-style]{Implementation of structures}
|
||||
|
||||
@(table-of-contents)
|
||||
|
||||
@section{@racket[define-structure]}
|
||||
|
||||
The @tc[remember-all] for-syntax function below memorizes its arguments across
|
||||
compilations, and adds them to the file “@code{remember.rkt}”:
|
||||
|
||||
@CHUNK[<remember-all>
|
||||
(require "remember.rkt")
|
||||
|
||||
(define (check-remember-all category value)
|
||||
(let ([datum-value (syntax->datum (datum->syntax #f value))])
|
||||
(if (not (member (cons category datum-value) all-remembered-list))
|
||||
(let ((file-name (build-path (this-expression-source-directory)
|
||||
"remember.rkt")))
|
||||
;; Add the missing field names to all-fields.rkt
|
||||
(with-output-file [port file-name] #:exists 'append
|
||||
(writeln (cons category datum-value) port))
|
||||
#f)
|
||||
#t)))]
|
||||
|
||||
@CHUNK[<remember-all-errors>
|
||||
(define (remember-all-errors id fallback stx)
|
||||
;<remember-all-hard-error>
|
||||
#`(#,id #,(for/list ([cause `(,stx ,fallback)])
|
||||
(syntax/loc cause delayed-error-please-recompile))))
|
||||
|
||||
(define remember-err-id-list '())
|
||||
|
||||
(define (remember-all-errors2 placeholder cause-stx)
|
||||
(let ((file-name (build-path (this-expression-source-directory)
|
||||
"remember.rkt")))
|
||||
(set! remember-err-id-list
|
||||
(cons cause-stx remember-err-id-list))
|
||||
(syntax-local-lift-module-end-declaration
|
||||
#`(remember-all-hard-error #,file-name))
|
||||
placeholder))]
|
||||
|
||||
@CHUNK[<remember-all-hard-error>
|
||||
(define-syntax (remember-all-hard-error stx)
|
||||
(syntax-case stx ()
|
||||
([whole-stx file-name]
|
||||
(raise-syntax-error
|
||||
'remember-all
|
||||
(format (~a "I added the identifiers ~a to my remembered list in"
|
||||
" ~a . Please recompile now.")
|
||||
(string-join (stx-map identifier->string
|
||||
remember-err-id-list)
|
||||
", ")
|
||||
(syntax->datum #'file-name))
|
||||
#f
|
||||
#f
|
||||
remember-err-id-list))))]
|
||||
|
||||
We can, during subsequent compilations, retrieve the list of already-memorized
|
||||
fields for a given tag.
|
||||
|
||||
@CHUNK[<get-remembered>
|
||||
(define (get-remembered category)
|
||||
(cdr (or (assoc category all-remembered-alist) '(_))))]
|
||||
|
||||
If we start with an empty “@code{remember.rkt}” file, it will throw an error at
|
||||
each call with a not-yet-remembered value. In order to avoid that, we use the
|
||||
macro @tc[(delayed-error-please-recompile)], which expands to an undefined
|
||||
identifier @code{please-recompile}. That error is caught later, and gives a
|
||||
chance to more calls to @tc[remember-all] to be executed during macro-expansion.
|
||||
We define @tc[delayed-error-please-recompile] in a submodule, to minimize the
|
||||
chances that we could write a definition for that identifier.
|
||||
|
||||
The @tc[delayed-error-please-recompile] macro has to be
|
||||
declared in a @tc[typed/racket] module so that it can be
|
||||
included in @tc[typed/racket] modules too.
|
||||
|
||||
@itemlist[
|
||||
@item{TODO: do we really need this? It is going to trigger
|
||||
an error after all!}
|
||||
@item{TODO: could we instead use
|
||||
@racket[(syntax-local-lift-module-end)] to push a macro
|
||||
throwing a @racket[raise-syntax-error] right to the end of
|
||||
the module? We could this way memorize all failed
|
||||
querries, and highlight them using
|
||||
@racket[raise-syntax-error].}]
|
||||
|
||||
@CHUNK[<delayed-error-please-recompile>
|
||||
(begin
|
||||
(module m-please-recompile typed/racket
|
||||
(define-syntax (delayed-error-please-recompile stx)
|
||||
#'please-recompile)
|
||||
(provide delayed-error-please-recompile))
|
||||
|
||||
(require (for-template 'm-please-recompile)))]
|
||||
|
||||
Due to a bug in scribble, the above has to be wrapped in a
|
||||
@tc[begin] form, otherwises the @tc[require] statement can't
|
||||
access the previously declared module.
|
||||
|
||||
The functions above are easier to define in a
|
||||
@tc[begin-for-syntax] environment, as
|
||||
@tc[remember-all-errors2] refers to the
|
||||
@tc[remember-all-hard-error] macro, in the template
|
||||
@tc[(syntax-local-lift-module-end-declaration
|
||||
#`(remember-all-hard-error …))], and that macro
|
||||
accesses mutable @tc[remember-err-id-list] and
|
||||
@tc[remember-err-stx-list]. It is therefore much simpler to
|
||||
define everything in the same module, in a
|
||||
@tc[begin-for-syntax] block except the macro which will be
|
||||
declared using @tc[define-syntax].
|
||||
|
||||
@chunk[<for-syntax-declarations>
|
||||
(require mzlib/etc
|
||||
(submod "../lib/low.rkt" untyped)
|
||||
(for-syntax mzlib/etc
|
||||
(submod "../lib/low.rkt" untyped)
|
||||
racket/string
|
||||
racket/format))
|
||||
(begin-for-syntax
|
||||
(provide check-remember-all
|
||||
remember-all-errors
|
||||
get-remembered
|
||||
remember-all-errors2)
|
||||
|
||||
<delayed-error-please-recompile>
|
||||
<remember-all>
|
||||
<remember-all-errors>
|
||||
<get-remembered>)
|
||||
;; remember-all-hard-error is a define-syntax.
|
||||
<remember-all-hard-error>]
|
||||
|
||||
We would however like to be able to
|
||||
@racket[(require "remember-lib.lp2.rkt")] and have the
|
||||
bindings it provides available at the same meta-level. We
|
||||
therefore define the bindings above in a separate submodule,
|
||||
@racket[require] it @tc[for-template] which has the efect of
|
||||
shifting the meta-level of all the bindings one level down,
|
||||
and re-provide the bindings which are now at meta-level @tc[0].
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
(module for-syntax-declarations racket
|
||||
<for-syntax-declarations>)
|
||||
(module main racket
|
||||
(require (for-template (submod ".." for-syntax-declarations)))
|
||||
(provide check-remember-all
|
||||
remember-all-errors
|
||||
get-remembered
|
||||
remember-all-errors2))
|
||||
(require 'main)
|
||||
(provide (all-from-out 'main)))]
|
||||
|
|
@ -100,3 +100,48 @@
|
|||
(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)
|
||||
(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)
|
||||
|
|
|
|||
|
|
@ -630,8 +630,7 @@ And one each for @tc[fold-instance] and @tc[replace-in-instance2]:
|
|||
(syntax-parse stx
|
||||
#:context `(tmpl-replace-in-instance-8 ,(current-replacement))
|
||||
[(_ type:expr [from to pred? fun] …)
|
||||
#`#,(replace-in-instance2 #'type #'([from to pred? fun] …))]
|
||||
[_ (error (format "~a" `(tmpl-replace-in-instance-8 ,(continuation-mark-set->context (current-continuation-marks)) ,(syntax->datum (current-replacement)))))])))]
|
||||
#`#,(replace-in-instance2 #'type #'([from to pred? fun] …))])))]
|
||||
|
||||
These metafunctions just extract the arguments for @tc[replace-in-type] and
|
||||
@tc[replace-in-instance2], and pass them to these functions.
|
||||
|
|
|
|||
|
|
@ -181,18 +181,18 @@ Test predicate:
|
|||
;; 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))
|
||||
(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-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)))
|
||||
'other)
|
||||
(check-occurrence-typing (ann (st2 "j" 2) (U Number st st3)))
|
||||
'other)
|
||||
(check-equal?
|
||||
(check-occurrence-typing (ann 9 (U Number st st3)))
|
||||
'other)|#]
|
||||
(check-occurrence-typing (ann 9 (U Number st st3)))
|
||||
'other)|#]
|
||||
|
||||
@section{Pre-declaring structs}
|
||||
|
||||
|
|
@ -225,9 +225,9 @@ have access to all the types we care about, and fill the rest with @tc[∀] type
|
|||
(define-for-syntax (check-remember-fields fields)
|
||||
(check-remember-all 'structure (sort-fields fields)))]
|
||||
|
||||
Since get-field is a macro, it should not care about the type of the field(s),
|
||||
and the code it expands to should be a @tc[cond] which only tests the field part
|
||||
of the structure.
|
||||
Since @tc[get-field] is a macro, it should not care about the type of the
|
||||
field(s), and the code it expands to should be a @tc[cond] which only tests the
|
||||
field part of the structure.
|
||||
|
||||
@CHUNK[<declare-all-structs>
|
||||
(define-syntax/parse (declare-all-structs fields→stx-name-alist:id
|
||||
|
|
@ -426,6 +426,15 @@ The fields in @tc[fields→stx-name-alist] are already sorted.
|
|||
: 'val-c
|
||||
'val-c)]
|
||||
|
||||
@subsection{Predicate}
|
||||
|
||||
@chunk[<structure?>
|
||||
(define-syntax/parse (structure? field …)
|
||||
(if (check-remember-fields #'(field ...))
|
||||
(meta-struct-predicate (fields→stx-name #'(field ...))
|
||||
#:srcloc stx)
|
||||
(remember-all-errors #'list stx #'(field ...))))]
|
||||
|
||||
@subsection{Match-expander}
|
||||
|
||||
@chunk[<syntax-class-for-match>
|
||||
|
|
@ -520,65 +529,11 @@ instead of needing an extra recompilation.
|
|||
In order to be able to access elements in the list as deep as they can be, we
|
||||
need to know the length of the longest structure used in the whole program.
|
||||
|
||||
Knowing what structures exist and what elements they contain can only help, so
|
||||
we'll remember that instead.
|
||||
|
||||
The @tc[remember-all] for-syntax function below memorizes its arguments across
|
||||
compilations, and adds them to the file “@code{remember.rkt}”:
|
||||
|
||||
@CHUNK[<remember-all>
|
||||
(require (for-syntax "remember.rkt"))
|
||||
|
||||
(define-for-syntax (check-remember-all category value)
|
||||
(let ([datum-value (syntax->datum (datum->syntax #f value))])
|
||||
(if (not (member (cons category datum-value) all-remembered-list))
|
||||
(let ((file-name (build-path (this-expression-source-directory)
|
||||
"remember.rkt")))
|
||||
;; Add the missing field names to all-fields.rkt
|
||||
(with-output-file [port file-name] #:exists 'append
|
||||
(writeln (cons category datum-value) port))
|
||||
#f)
|
||||
#t)))
|
||||
|
||||
(define-for-syntax (remember-all-errors id fallback stx-list)
|
||||
;<remember-all-hard-error>
|
||||
#`(#,id #,(for/list ([cause `(,@(syntax->list stx-list) ,fallback)])
|
||||
(syntax/loc cause delayed-error-please-recompile))))]
|
||||
|
||||
@CHUNK[<remember-all-hard-error>
|
||||
(raise-syntax-error
|
||||
(car (syntax->datum stx))
|
||||
(format "The fields ~a were added to ~a. Please recompile now."
|
||||
(string-join (map symbol->string missing) ", ")
|
||||
file-name)
|
||||
#f
|
||||
#f
|
||||
(filter (λ (f) (not (member (syntax->datum f) all-fields)))
|
||||
(syntax->list fields)))]
|
||||
|
||||
We can, during subsequent compilations, retrieve the list of already-memorized
|
||||
fields for a given tag.
|
||||
|
||||
@CHUNK[<get-remembered>
|
||||
(define-for-syntax (get-remembered category)
|
||||
(cdr (or (assoc category all-remembered-alist) '(_))))]
|
||||
|
||||
If we start with an empty “@code{remember.rkt}” file, it will throw an error at
|
||||
each call with a not-yet-remembered value. In order to avoid that, we use the
|
||||
macro @tc[(delayed-error-please-recompile)], which expands to an undefined
|
||||
identifier @code{please-recompile}. That error is caught later, and gives a
|
||||
chance to more calls to @tc[remember-all] to be executed during macro-expansion.
|
||||
We define @tc[delayed-error-please-recompile] in a submodule, to minimize the
|
||||
chances that we could write a definition for that identifier.
|
||||
|
||||
@CHUNK[<delayed-error-please-recompile>
|
||||
(begin-for-syntax
|
||||
(module m-please-recompile typed/racket
|
||||
(define-syntax (delayed-error-please-recompile stx)
|
||||
#'please-recompile)
|
||||
(provide delayed-error-please-recompile))
|
||||
|
||||
(require 'm-please-recompile))]
|
||||
Knowing what structures exist and what elements they
|
||||
contain can only help, so we'll remember that instead, using
|
||||
the @tc[remember-all] for-syntax function which memorizes
|
||||
its arguments across compilations, and adds them to the file
|
||||
“@code{remember.rkt}”.
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
|
|
@ -589,13 +544,13 @@ chances that we could write a definition for that identifier.
|
|||
racket/syntax
|
||||
syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
mzlib/etc
|
||||
racket/struct-info
|
||||
racket/sequence
|
||||
;; in-syntax on older versions:
|
||||
;;;unstable/sequence
|
||||
(submod "../lib/low.rkt" untyped)
|
||||
"meta-struct.rkt")
|
||||
"meta-struct.rkt"
|
||||
"remember-lib.rkt")
|
||||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"../type-expander/multi-id.lp2.rkt")
|
||||
|
|
@ -605,13 +560,12 @@ chances that we could write a definition for that identifier.
|
|||
λstructure-get
|
||||
structure
|
||||
structure-supertype
|
||||
structure-supertype*)
|
||||
structure-supertype*
|
||||
structure?)
|
||||
|
||||
(begin-for-syntax
|
||||
(provide structure-args-stx-class))
|
||||
|
||||
<remember-all>
|
||||
<get-remembered>
|
||||
<check-remember-fields>
|
||||
|
||||
<named-sorted-structures>
|
||||
|
|
@ -620,7 +574,6 @@ chances that we could write a definition for that identifier.
|
|||
<declare-all-structs>
|
||||
<fields→stx-name>
|
||||
<make-structure-constructor>
|
||||
<delayed-error-please-recompile>
|
||||
|
||||
<fields→supertypes>
|
||||
<get-field>
|
||||
|
|
@ -631,6 +584,8 @@ chances that we could write a definition for that identifier.
|
|||
<match-expander>
|
||||
<type-expander>
|
||||
|
||||
<structure?>
|
||||
|
||||
<structure>
|
||||
<define-structure>)
|
||||
|
||||
|
|
@ -642,7 +597,7 @@ chances that we could write a definition for that identifier.
|
|||
"../lib/low.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
typed/rackunit)
|
||||
|
||||
|
||||
<test-make-structure-constructor>
|
||||
<test-get-field>
|
||||
<test-match-expander>
|
||||
|
|
|
|||
|
|
@ -13,18 +13,122 @@ 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}]
|
||||
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.
|
||||
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{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 variant as a @tc[list], with the tag symbol in the first element.
|
||||
We can't use a @tc[vector], because these are mutable in @tc[typed/racket], and
|
||||
occurrence typing can't work properly on mutable data structures (yet).
|
||||
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
|
||||
|
|
@ -33,41 +137,72 @@ occurrence typing can't work properly on mutable data structures (yet).
|
|||
#:call <make-instance>)]
|
||||
|
||||
@chunk[<test-constructor>
|
||||
(check-equal? (ann (constructor a 1 "x")
|
||||
(constructor a Number String))
|
||||
(list 'a 1 "x"))
|
||||
(check-equal? (ann (constructor b)
|
||||
(constructor b))
|
||||
(list 'b))
|
||||
(check-equal? (ann (constructor c 2 "y")
|
||||
(constructor c Number String))
|
||||
(constructor c 2 "y"))
|
||||
(check-not-equal? (constructor d 2 "y")
|
||||
(constructor d 2 "y" 'z))
|
||||
(check-not-equal? (constructor e 2 "y")
|
||||
(constructor F 2 "y"))]
|
||||
(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 type:expr ...)
|
||||
#'(List 'tag type ...))]
|
||||
@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 pat:expr ...)
|
||||
#'(list 'tag pat ...))]
|
||||
(λ/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/with-syntax (T ...) (generate-temporaries #'(value ...)))
|
||||
#'((λ #:∀ (T ...) ([arg : T] ...) : (List 'tag T ...)
|
||||
(list 'tag arg ...))
|
||||
value ...))]
|
||||
@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]}
|
||||
|
||||
|
|
@ -77,42 +212,53 @@ 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 ...] ...
|
||||
@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 …) …))
|
||||
(template
|
||||
(begin
|
||||
(define-type name (U (constructor tag type ...) ...))
|
||||
;; TODO: for now, we don't check properly, it could be any list with
|
||||
;; that symbol as the first element.
|
||||
(define ((?? name? default-name?) [x : Any])
|
||||
(match x
|
||||
[(constructor tag pat …) #t]
|
||||
…
|
||||
[_ #f])))))]
|
||||
(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))]
|
||||
(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
|
||||
@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.
|
||||
|
|
@ -131,31 +277,33 @@ number of name collisions.
|
|||
(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)))
|
||||
(~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 : 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]
|
||||
[sa.field : sa.type
|
||||
sa.field/arg]
|
||||
…))))
|
||||
#`(λ #:∀ (sa.field/TTemp …) ([sa.field : sa.field/TTemp] …)
|
||||
#`(λ #:∀ (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] …))))))
|
||||
[sa.field sa.field/arg] …))))))
|
||||
(if (attribute sa.value)
|
||||
#'(c sa.value …)
|
||||
#'c)))]
|
||||
|
|
@ -164,46 +312,49 @@ number of name collisions.
|
|||
(define-multi-id any-tagged
|
||||
#:type-expander
|
||||
(λ/syntax-parse (_ . structure-type)
|
||||
#'(List Symbol (structure . 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)
|
||||
#`(list (? symbol? tag-pat:id) #,(syntax/loc #'structure-pat
|
||||
(structure . 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"))]
|
||||
(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>
|
||||
(define-syntax/parse (define-tagged tag:id [field type] ...
|
||||
(define-syntax/parse (define-tagged tag:id [field type] …
|
||||
(~optional #:type-noexpand)
|
||||
(~maybe #:? tag?))
|
||||
(define/with-syntax (pat ...) (generate-temporaries #'(field ...)))
|
||||
(define/with-syntax (value ...) (generate-temporaries #'(field ...)))
|
||||
(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] ...)
|
||||
(tagged tag [field type] …)
|
||||
#:match-expander
|
||||
(λ/syntax-parse (_ pat ...)
|
||||
#'(tagged tag [field pat] ...))
|
||||
(λ/syntax-parse (_ pat …)
|
||||
#'(tagged tag [field pat] …))
|
||||
#:call
|
||||
(λ/syntax-parse (_ value ...)
|
||||
#'(tagged tag #:instance [field value] ...)))
|
||||
(: (?? tag? default-tag?) (→ Any Any))
|
||||
(λ/syntax-parse (_ value …)
|
||||
#'(tagged tag #:instance [field value] …)))
|
||||
(: (?? tag? default-tag?) (→ Any Boolean))
|
||||
(define ((?? tag? default-tag?) x)
|
||||
(match x
|
||||
[(tagged tag [field _] …) #t]
|
||||
[_ #f])))))]
|
||||
(and (Tagged-predicate? tag x)
|
||||
((structure? field …) (Tagged-value x)))))))]
|
||||
|
||||
@chunk[<test-define-tagged>
|
||||
(define-tagged tagged-s1)
|
||||
|
|
@ -211,18 +362,18 @@ number of name collisions.
|
|||
(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-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))
|
||||
(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)))
|
||||
(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
|
||||
|
|
@ -230,18 +381,18 @@ number of name collisions.
|
|||
[(tagged-s3 x y) (list 'found-s3 y x)]
|
||||
[(tagged-s4 x y) (list 'found-s4 y x)]))
|
||||
|
||||
(check-equal?
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s2 2 "flob")
|
||||
(tagged tagged-s2 [f Fixnum] [g String])))
|
||||
'(found-s2 "flob" 2))
|
||||
|
||||
(check-equal?
|
||||
(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?
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s4 2 "flob")
|
||||
(tagged tagged-s4 [g String] [f Fixnum])))
|
||||
'(found-s4 "flob" 2))
|
||||
|
|
@ -252,33 +403,34 @@ number of name collisions.
|
|||
[(tagged tagged-s3 [g y] f) (list 'found-s2 f y)]
|
||||
[(tagged tagged-s4 [f y] g) (list 'found-s2 g y)]))
|
||||
|
||||
(check-equal?
|
||||
(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?
|
||||
(check-equal?:
|
||||
(test-match (ann (tagged-s3 "flob" 3)
|
||||
(tagged tagged-s3 [f Fixnum] [g String])))
|
||||
'(found-s3 3 "flob"))
|
||||
|
||||
(check-equal?
|
||||
(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"))]
|
||||
(check-not-equal?: (tagged-s2 4 "flob")
|
||||
(tagged-s3 "flob" 4))
|
||||
(check-not-equal?: (tagged-s2 4 "flob")
|
||||
(tagged-s4 4 "flob"))]
|
||||
|
||||
@section{Conclusion}
|
||||
|
||||
@chunk[<*>
|
||||
(begin
|
||||
(module main typed/racket
|
||||
(require (for-syntax syntax/parse
|
||||
(require (for-syntax racket/list
|
||||
syntax/parse
|
||||
syntax/parse/experimental/template
|
||||
racket/syntax
|
||||
(submod "../lib/low.rkt" untyped))
|
||||
|
|
@ -286,22 +438,35 @@ number of name collisions.
|
|||
"../type-expander/multi-id.lp2.rkt"
|
||||
"../type-expander/type-expander.lp2.rkt"
|
||||
"structure.lp2.rkt")
|
||||
(provide constructor
|
||||
(provide (rename-out [Tagged-predicate? Tagged?]
|
||||
[Tagged-type TaggedTop])
|
||||
constructor
|
||||
define-variant
|
||||
tagged
|
||||
define-tagged
|
||||
any-tagged)
|
||||
|
||||
<variant-supertype>
|
||||
<remember-tags>
|
||||
<named-sorted-tags>
|
||||
<declare-all-tags>
|
||||
<tag-name→stx-name>
|
||||
|
||||
<predicate>
|
||||
<constructor>
|
||||
<define-variant>
|
||||
<tagged>
|
||||
<define-tagged>)
|
||||
<define-tagged>
|
||||
|
||||
(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")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user