diff --git a/graph/graph/__DEBUG_graph__.rkt b/graph/graph/__DEBUG_graph__.rkt
index bc275db8..a77cac58 100644
--- a/graph/graph/__DEBUG_graph__.rkt
+++ b/graph/graph/__DEBUG_graph__.rkt
@@ -1,5 +1,19 @@
#lang debug typed/racket
+(require "structure.lp2.rkt")
+(require "../type-expander/type-expander.lp2.rkt")
+(require "../lib/low.rkt")
+
+(define-structure st [a Number] [b String])
+(check-equal:? (st 1 "b") (structure [a 1] [b "b"]))
+(check-equal:? (st 1 "b") (structure [a : Number 1] [b : String "b"]))
+(check-equal:? (st 1 "b") ((structure [a : Number] [b : String]) 1 "b"))
+(check-equal:? (st 1 "b") ((structure [a] [b]) 1 "b"))
+(check-equal:? (st 1 "b") ((structure a b) 1 "b"))
+(check-equal:? (st 1 "b") ((structure [a] b) 1 "b"))
+
+
+#|
(require (submod "graph3.lp2.rkt" test))
(require "../lib/low.rkt")
(require racket/list)
@@ -34,3 +48,5 @@
x))
(forceall 5 g)
+
+|#
\ No newline at end of file
diff --git a/graph/graph/remember.rkt b/graph/graph/remember.rkt
index 168c8fd8..3807ba91 100644
--- a/graph/graph/remember.rkt
+++ b/graph/graph/remember.rkt
@@ -38,3 +38,5 @@
(structure faa fab fav)
(structure fba fbv)
(structure fav)
+(structure a)
+(structure a)
diff --git a/graph/graph/structure.lp2.rkt b/graph/graph/structure.lp2.rkt
index 9ac54a3c..3ff518ea 100644
--- a/graph/graph/structure.lp2.rkt
+++ b/graph/graph/structure.lp2.rkt
@@ -12,12 +12,116 @@ Structures are represented using regular racket @tc[struct]s, see
@seclink["type-system|structures"]{the overview document}.
@;secref["structures" #:doc "type-system.scrbl"].
+When called, @tc[structure] accepts several syntaxes:
+@tc[(structure [field] …)], which returns a constructor with @tc[∀] types for,
+@tc[(structure [field value] …)], which returns an instance, inferring the type
+of the fields, @tc[(structure [field : type] …)], which returns a constructor
+with the given types, or @tc[(structure [field : type value] …)], which returns
+an instance using the given types. the types have to be all provided, or not
+given at all, but a mix of typed and @tc[∀] is not allowed for now (rationale:
+since typed/racket currently doesn't support named instantiation of polymorphic
+types, it wouldn't be clear what fields the remaining type parameters affect).
+
+@;{(begin-for-syntax
+ (define-syntax-class field-descriptor
+ (pattern
+ (~or field:id
+ [field:id (~maybe (~lit :) type:expr) (~maybe value:expr)]))))}
+
@chunk[<structure>
(define-multi-id structure
#:type-expander structure-type-expander
#:match-expander structure-match-expander
- #:call (λ/syntax-parse (_ [field value] ...)
- #'((make-structure-constructor field ...) value ...)))]
+ #:call (λ (stx)
+ (syntax-parse stx
+ [(_) <hybrid-empty>]
+ [(_ (~or (~seq (~or-bug [field:id] field:id) …)
+ (~seq [field:id (~lit :) type:expr] …)
+ (~seq [field:id value:expr] …)
+ (~seq [field:id (~lit :) type:expr value:expr] …)))
+ (define/with-syntax c
+ #'(make-structure-constructor field …))
+ (define/with-syntax ct
+ (if (and (attribute type) (not (stx-null? #'(type …))))
+ #'(inst c type …)
+ #'c))
+ (template (?? (ct value …) ct))])))]
+
+@subsection[#:tag "structure|hybrid-empty"]{Hybrid constructor / instance for
+ the empty structure}
+
+A call to @tc[(structure)] with no field, is ambiguous: it could return a
+constructor function, or an instance. We use @tc[define-struct/exec] to make it
+behave like both.
+
+@CHUNK[<declare-hybrid-empty>
+ (struct empty/noexec-type ())
+
+ (define-struct/exec (empty/exec-type empty)
+ ()
+ [(λ _ empty-instance) : (→ Any empty)])
+
+ (define empty-instance (empty/exec-type))]
+
+@CHUNK[<test-hybrid-empty>
+ (check-equal:? empty-instance : empty empty-instance)
+ (check-equal:? empty-instance : empty (empty-instance))
+ (check-equal:? (empty-instance) : empty empty-instance)
+ (check-equal:? (empty-instance) : empty (empty-instance))]
+
+@CHUNK[<test-hybrid-empty-2>
+ (check-equal:? (structure) (structure))
+ (check-equal:? (structure) ((structure)))
+ (check-equal:? ((structure)) (structure))
+ (check-equal:? ((structure)) ((structure)))]
+
+@chunk[<test-structure>
+ (let ()
+ (define-structure empty-st)
+ (define-structure stA [a Number])
+ (check-equal:? (empty-st) ((structure)))
+ (check-not-equal:? (empty-st) (structure [a 1]))
+ (check-not-equal:? (structure) (structure [a 1]))
+ (check-not-equal:? (empty-st) (stA 1))
+ (check-not-equal:? (structure) (stA 1)))
+ #;(let ()
+ (define-structure st [a Number] [b String])
+ (define-structure stA [a Number])
+ (define-structure stABC [a Number] [b String] [c Number])
+ (define st1 (st 1 "b"))
+ (check-equal:? st1 (structure [a 1] [b "b"]))
+ (check-equal:? st1 (structure [a : Number 1] [b : String "b"]))
+ (check-equal:? st1 ((structure [a : Number] [b : String]) 1 "b"))
+ (check-equal:? st1 ((structure [a] [b]) 1 "b"))
+ (check-equal:? st1 ((structure a b) 1 "b"))
+ (check-equal:? st1 ((structure [a] b) 1 "b"))
+
+ (define st2 (st 2 "b"))
+ (check-not-equal:? st2 st1)
+ (check-not-equal:? st2 (structure [a 1] [b "b"]))
+ (check-not-equal:? st2 (structure [a : Number 1] [b : String "b"]))
+ (check-not-equal:? st2 ((structure [a : Number] [b : String]) 1 "b"))
+ (check-not-equal:? st2 ((structure [a] [b]) 1 "b"))
+ (check-not-equal:? st2 ((structure a b) 1 "b"))
+ (check-not-equal:? st2 ((structure [a] b) 1 "b"))
+
+ (define sta (stA 1))
+ (check-not-equal:? sta st1)
+ (check-not-equal:? sta (structure [a 1] [b "b"]))
+ (check-not-equal:? sta (structure [a : Number 1] [b : String "b"]))
+ (check-not-equal:? sta ((structure [a : Number] [b : String]) 1 "b"))
+ (check-not-equal:? sta ((structure [a] [b]) 1 "b"))
+ (check-not-equal:? sta ((structure a b) 1 "b"))
+ (check-not-equal:? sta ((structure [a] b) 1 "b"))
+
+ (define st3 (stABC 1 "b" 3))
+ (check-not-equal:? st3 st1)
+ (check-not-equal:? st3 (structure [a 1] [b "b"]))
+ (check-not-equal:? st3 (structure [a : Number 1] [b : String "b"]))
+ (check-not-equal:? st3 ((structure [a : Number] [b : String]) 1 "b"))
+ (check-not-equal:? st3 ((structure [a] [b]) 1 "b"))
+ (check-not-equal:? st3 ((structure a b) 1 "b"))
+ (check-not-equal:? st3 ((structure [a] b) 1 "b")))]
@chunk[<define-structure>
(define-syntax (define-structure stx)
@@ -34,16 +138,20 @@ Structures are represented using regular racket @tc[struct]s, see
(syntax-case stx2 ()
[(_ pat ...) #'(structure [field pat] ...)]))
#:else
- (inst (make-structure-constructor field ...) type ...))]))]
+ (if (not (stx-null? #'(type …)))
+ #'(inst (make-structure-constructor field ...) type ...)
+ #'(make-structure-constructor field ...)))]))]
@chunk[<test-define-structure>
+ (define-structure empty-st)
(define-structure st [a Number] [b String])
(define-structure st2 [b String] [a Number])]
Test constructor:
@chunk[<test-define-structure>
+ (check-equal:? (empty-st) : empty-st (empty-st))
(check-equal:? (get (st 1 "b") b) : String "b")
(check-equal:? (get (st2 "a" 2) b) : String "a")]
@@ -139,10 +247,18 @@ one low-level @tc[struct] is generated for them.
@CHUNK[<named-sorted-structures>
(define-for-syntax named-sorted-structures
(for/list ([s (remove-duplicates (map (λ (s) (sort s symbol<?))
- (get-remembered 'structure)))]
+ <all-remembered-structs+empty>))]
[i (in-naturals)])
`(,(string->symbol (format "struct-~a" i)) . ,s)))]
+We add the empty struct (with no fields) to the list of remembered structs as a
+special case, because we need it to define the hybrid instance/constructor in
+section @secref{structure|hybrid-empty}.
+
+@chunk[<all-remembered-structs+empty>
+ (cons '()
+ (get-remembered 'structure))]
+
We will also need utility functions to sort the fields when querying this
associative list.
@@ -175,8 +291,8 @@ be used to make @tc[structure] instances like this:
@chunk[<test-make-structure-constructor>
(check-equal? (begin ((make-structure-constructor a b c) 1 "b" #t)
- #t)
- #t)]
+ 'it-works)
+ 'it-works)]
To create such an instance, we use the underlying @tc[struct]'s constructor.
First, we need to check if the list of fields was already remembered, in which
@@ -332,8 +448,8 @@ instead of needing an extra recompilation.
(let ()
(define/with-syntax ([sorted-field sorted-type] ...)
(sort-car-fields #'((field type) ...)))
- (if (null? (syntax->list #'(sorted-type ...)))
- (fields→stx-name #'(field ...))
+ (if (stx-null? #'(sorted-type ...))
+ (fields→stx-name #'(field …)) ; #'(field …) is empty here.
#`(#,(fields→stx-name #'(field ...)) sorted-type ...)))
(remember-all-errors #'U stx #'(field ...)))]))]
@@ -417,6 +533,7 @@ chances that we could write a definition for that identifier.
(require (for-syntax racket
racket/syntax
syntax/parse
+ syntax/parse/experimental/template
mzlib/etc
racket/struct-info
syntax/stx
@@ -441,6 +558,9 @@ chances that we could write a definition for that identifier.
<sort-fields>
<declare-all-structs>
<fields→stx-name>
+ <declare-hybrid-empty>
+ (require typed/rackunit)
+ <test-hybrid-empty>
<make-structure-constructor>
<delayed-error-please-recompile>
@@ -468,7 +588,9 @@ chances that we could write a definition for that identifier.
<test-get-field>
<test-match-expander>
<test-type-expander>
+ <test-structure>
<test-define-structure>
+ <test-hybrid-empty-2>
(require (submod ".." doc))))]
diff --git a/graph/lib/low.rkt b/graph/lib/low.rkt
index ee39d822..64fb6d9d 100644
--- a/graph/lib/low.rkt
+++ b/graph/lib/low.rkt
@@ -91,12 +91,51 @@
(require 'mb)
(check-equal? require-provide-foo 7))
-;; ==== low/define-syntax-parse.rkt ====
+;; ==== low/syntax-parse.rkt ====
(require syntax/parse
- syntax/parse/define)
+ syntax/parse/define
+ (for-syntax racket/syntax))
(provide define-syntax/parse
- λ/syntax-parse)
+ λ/syntax-parse
+ ~maybe
+ ~lit
+ ~or-bug)
+
+(define-syntax ~maybe
+ (pattern-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(~maybe pat ...)
+ (datum->syntax #'~maybe
+ #'(~optional (~seq pat ...)))]))))
+
+;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in:
+;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)])
+(define-syntax ~or-bug
+ (pattern-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(~or-bug pat ...)
+ (let ()
+ (define (s stx) (datum->syntax #'~or-bug stx))
+ ;(define/with-syntax ~~and (datum->syntax #'~or-bug #'~and))
+ ;(define/with-syntax ~~parse (datum->syntax #'~or-bug #'~parse))
+ ;(define/with-syntax ~~or (datum->syntax #'~or-bug #'~parse))
+ #;#'(~~and x (~~parse (~~or pat ...) #'x))
+ #`(#,(s #'~and) x (#,(s #'~parse) #,(s #'(~or pat ...)) #'x))
+ )]))))
+
+(define-syntax ~lit
+ (pattern-expander
+ (λ (stx)
+ (syntax-case stx ()
+ [(~lit lit)
+ (datum->syntax #'~lit
+ #'(~literal lit))]
+ [(~lit lit …)
+ (datum->syntax #'lit
+ #'(~seq (~literal lit)))]))))
(begin-for-syntax
(require (for-syntax racket/base
@@ -132,7 +171,8 @@
syntax/parse/experimental/template)
typed/rackunit)
-(provide check-equal:?)
+(provide check-equal:?
+ check-not-equal:?)
;; TODO: this won't expand types in the ann.
@@ -140,7 +180,15 @@
(check-equal:? actual
(~optional (~seq (~datum :) type))
expected)
- (template (check-equal? (?? (ann actual type) actual) expected)))
+ (template (check-equal? (?? (ann actual type) actual)
+ (?? (ann expected type) expected))))
+
+(define-syntax/parse
+ (check-not-equal:? actual
+ (~optional (~seq (~datum :) type))
+ expected)
+ (template (check-not-equal? (?? (ann actual type) actual)
+ (?? (ann expected type) expected))))
;; ==== low/typed-fixnum.rkt ===
@@ -637,14 +685,14 @@
(define/with-syntax pat
(format-id #'base.id (syntax-e #'format) #'base.id))
(define/with-syntax pat-dotted ((attribute base.make-dotted) #'pat))
-
+
(define/with-syntax format-temp-ids*
((attribute base.wrap) #'(compose car (curry format-temp-ids format))
(λ (x deepest?)
(if deepest?
x
#`(curry stx-map #,x)))))
-
+
(syntax-cons-property
(template (begin (define/with-syntax pat-dotted
(format-temp-ids* #'base))
diff --git a/graph/type-expander/multi-id.lp2.rkt b/graph/type-expander/multi-id.lp2.rkt
index 1a6c866e..8c1f8643 100644
--- a/graph/type-expander/multi-id.lp2.rkt
+++ b/graph/type-expander/multi-id.lp2.rkt
@@ -14,16 +14,21 @@ TODO: maybe we should cache @tc[p-else] and @tc[p-get].
'self
(format "can't set ~a" (syntax->datum #'self)))]
-@chunk[<stx-class-kw-else>
+@CHUNK[<stx-class-kw-else>
(define-splicing-syntax-class kw-else
+ #:attributes (p-just-set! p-just-call p-just-id)
(pattern (~seq #:mutable-else p-else)
#:with p-just-set! #'#'(set! p-else . rest)
#:with p-just-call #'#'(p-else . rest)
#:with p-just-id #'#'p-else)
(pattern (~seq #:else p-else)
#:with p-just-set! <fail-set!>
- #:with p-just-call #'#'(p-else . rest)
- #:with p-just-id #'#'p-else))]
+ #:with p-just-call #'#`(#,p-else . rest)
+ #:with p-just-id #'p-else)
+ (pattern (~seq #:mutable-else-id p-else-id)
+ #:with (:kw-else) #'(#:mutable-else #'p-else-id))
+ (pattern (~seq #:else-id p-else-id)
+ #:with (:kw-else) #'(#:else #'p-else-id)))]
@chunk[<stx-class-kw-set!+call+id>
(define-splicing-syntax-class kw-set!+call+id
@@ -31,6 +36,10 @@ TODO: maybe we should cache @tc[p-else] and @tc[p-get].
(~optional (~or (~seq #:call p-user-call:expr)
(~seq #:call-id p-user-call-id:id)))
(~optional (~seq #:id p-user-id:expr)))
+ ; TODO: add #:macro with prop:procedure, see
+ ; file:///usr/local/racket-6.3.0.4/doc/syntax/stxparse-patter
+ ; ns.html?q=~optional#%28def._%28%28lib._syntax%2Fparse..rkt%
+ ; 29._prop~3apattern-expander%29%29
#:attr p-just-set!
(and (attribute p-user-set!) #'(p-user-set! stx))
#:attr p-just-call
@@ -129,6 +138,31 @@ to configure).
Test with @tc[#:else]:
+@chunk[<test-multi-id>
+ (define-multi-id bar-id
+ #:type-expander
+ (λ (stx) #'(List `,(Repeat 'x 2) Number))
+ #:match-expander
+ (λ (stx) #'(cons _ _))
+ #:custom-write
+ (λ (self port mode) (display "custom-write for foo" port))
+ #:else-id p1)
+
+ (check-equal? (ann (ann '((x x) 79) bar)
+ (List (List 'x 'x) Number))
+ '((x x) 79))
+
+ ;(set! bar 'bad)
+
+ (let ([test-match (λ (val) (match val [(bar-id) #t] [_ #f]))])
+ (check-equal? (test-match '(a . b)) #t)
+ (check-equal? (test-match #(1 2 3)) #f))
+
+ (let ([f-bar-id bar-id])
+ (check-equal? (f-bar-id 6) 7))
+ (check-equal? (bar-id 6) 7)
+ (check-equal? (map bar-id '(1 5 3 4 2)) '(2 6 4 5 3))]
+
@chunk[<test-multi-id>
(define-multi-id bar
#:type-expander
@@ -137,7 +171,7 @@ Test with @tc[#:else]:
(λ (stx) #'(cons _ _))
#:custom-write
(λ (self port mode) (display "custom-write for foo" port))
- #:else p1)
+ #:else #'p1)
(check-equal? (ann (ann '((x x) 79) bar)
(List (List 'x 'x) Number))
diff --git a/graph/type-expander/type-expander.lp2.rkt b/graph/type-expander/type-expander.lp2.rkt
index c7efc146..709ba9fa 100644
--- a/graph/type-expander/type-expander.lp2.rkt
+++ b/graph/type-expander/type-expander.lp2.rkt
@@ -40,9 +40,9 @@ contain the expander procedure, or directly an expander procedure.
[else
(raise-argument-error
'prop:type-expander-guard
- (~a "an exact non-negative integer designating a field index "
- "within the structure that should contain a procedure of "
- "arity 1, or a procedure of arity 1.")
+ (~a "a procedure of arity 1, or an exact non-negative integer "
+ "designating a field index within the structure that "
+ "should contain a procedure of arity 1.")
val)]))]
If the value is a field index, it should be within bounds. The
@@ -269,7 +269,7 @@ ususal @code{#'()} and @code{#`()}. In order to expand types and bind type
variables in the result, we define two template metafunctions:
@chunk[<template-metafunctions>
- (define-template-metafunction (template-expand-type stx)
+ (define-template-metafunction (tmpl-expand-type stx)
(syntax-parse stx
[(_ () t) (expand-type #'t)]
[(_ tvars t) (expand-type (bind-type-vars #'tvars #'t))]))]
@@ -329,7 +329,7 @@ them.
(~optional default:expr)])
#:with tvars tvars
#:with (expanded ...)
- (template (kw [id (?@ : (template-expand-type tvars type))
+ (template (kw [id (?@ : (tmpl-expand-type tvars type))
(?? default)]))))
(define-splicing-syntax-class (new-mand-formal tvars)
@@ -339,7 +339,7 @@ them.
(pattern [id:id :colon type:expr]
#:with tvars tvars
#:with (expanded ...)
- (template ([id : (template-expand-type tvars type)])))
+ (template ([id : (tmpl-expand-type tvars type)])))
(pattern (~var kw (new-kw-formal tvars))
#:with (expanded ...) #'(kw.expanded ...)))
@@ -348,7 +348,7 @@ them.
(pattern [id:id (~optional (~seq :colon type:expr)) default:expr]
#:with tvars tvars
#:with (expanded ...)
- (template ([id (?@ : (template-expand-type tvars type))
+ (template ([id (?@ : (tmpl-expand-type tvars type))
default])))
(pattern (~var kw (new-kw-formal tvars))
#:with (expanded ...) #'(kw.expanded ...)))
@@ -363,8 +363,8 @@ them.
(~seq (~datum ...) bound:expr)))
#:with tvars tvars
#:with expanded
- (template (rest : (template-expand-type tvars type)
- (?? x* (?@ (... ...) (template-expand-type
+ (template (rest : (tmpl-expand-type tvars type)
+ (?? x* (?@ (... ...) (tmpl-expand-type
tvars bound)))))))
(define-syntax-class (new-lambda-formals tvars)
@@ -394,7 +394,7 @@ them.
#:with tvars tvars
#:with expanded
(template (name
- (?? (?@ : (template-expand-type tvars type)))))))
+ (?? (?@ : (tmpl-expand-type tvars type)))))))
(define-syntax-class (new-name-or-parenthesised-annotated-name tvars)
(pattern name:id
@@ -402,7 +402,7 @@ them.
(pattern [id:id :colon type:expr]
#:with tvars tvars
#:with expanded
- (template [id : (template-expand-type tvars type)])))]
+ (template [id : (tmpl-expand-type tvars type)])))]
@subsection{@racket[define-type]}
@@ -412,7 +412,7 @@ them.
[(_ (~or name:id (name:id TVar ...)) type . rest)
(template
(define-type (?? (name TVar ...) name)
- (template-expand-type (?? (TVar ...) ()) type)
+ (tmpl-expand-type (?? (TVar ...) ()) type)
. rest))]))]
@chunk[<test-define-type>
@@ -437,7 +437,7 @@ them.
e ...)
(template
(define (?@ . tvars) (?? v formals.expanded)
- (?? (?@ : (template-expand-type tvars.vars type)))
+ (?? (?@ : (tmpl-expand-type tvars.vars type)))
e ...))]))]
@CHUNK[<test-define>
@@ -471,7 +471,7 @@ them.
(~optional (~seq :colon ret-type))
e ...)
(template (lambda (?@ . tvars) args.expanded
- (?? (?@ : (template-expand-type tvars.vars ret-type)))
+ (?? (?@ : (tmpl-expand-type tvars.vars ret-type)))
e ...))]))]
@CHUNK[<test-lambda>
@@ -495,8 +495,12 @@ them.
(~and name+parent (~or name:id [name:id parent:id]))
([field:id :colon type:expr] ...)
. rest)
- (template (struct (?? tvars.maybe) name+parent
- ([field : (template-expand-type tvars.vars type)] ...)
+ (displayln #'(tvars= tvars
+ name+parent= name+parent
+ field...= field ...
+ rest= rest))
+ (template (struct (?? tvars.maybe) name (?? parent)
+ ([field : (tmpl-expand-type tvars.vars type)] ...)
. rest))]))]
@chunk[<test-struct>
@@ -507,6 +511,11 @@ them.
(struct s4 () #:transparent)
(struct (A B) s5 ([x : A] [y : B]) #:transparent)
(struct (A B) s6 () #:transparent)
+ (struct (s7 s2) ([z : String]) #:transparent)
+ (struct (A) (s8 s3) ([z : A]) #:transparent)
+ (struct (A B C) (s9 s5) ([z : C]) #:transparent)
+ (struct (A B C) (s10 s2) ([z : C]) #:transparent)
+ (struct (A B C) (s11 s5) ([z : C]))
(check (λ (a b) (not (equal? a b))) (s0) (s0))
(check-equal? (s1-x (s1 123)) 123)
@@ -518,13 +527,119 @@ them.
(check-equal? (s5-x (s5 6 7)) 6)
(check-equal? (s5-y (s5 6 7)) 7)
(check-equal? (s5 6 7) (s5 6 7))
- (check-equal? (s6) (s6))]
+ (check-equal? ((inst s5 Number String) 6 "g") (s5 6 "g"))
+ (check-equal? (s6) (s6))
+ (check-equal? ((inst s6 Number String)) (s6))
+
+ ;(check-equal? (s7-x (s7 -1 -2 "c") -1))
+ ;(check-equal? (s7-y (s7 -1 -2 "c") -2))
+ (check-equal? (s7-z (s7 -1 -2 "c")) "c")
+ (check-equal? (s2-x (s7 -1 -2 "c")) -1)
+ (check-equal? (s2-y (s7 -1 -2 "c")) -2)
+ (check-not-equal? (s7 -1 -2 "c") (s7 -1 -2 "c"))
+ (check-not-exn (λ () (ann (s7 -1 -2 "c") s2)))
+ (check-true (s2? (s7 -1 -2 "c")))
+
+ ;(check-equal? (s8-x (s8 -1 -2 "c") -1))
+ ;(check-equal? (s8-y (s8 -1 -2 "c") -2))
+ (check-equal? (s8-z (s8 -1 -2 "c")) "c")
+ (check-equal? (s3-x (s8 -1 -2 "c")) -1)
+ (check-equal? (s3-y (s8 -1 -2 "c")) -2)
+ (check-equal? (s8 -1 -2 "c") (s8 -1 -2 "c"))
+ (check-equal? ((inst s8 String) -1 -2 "c") (s8 -1 -2 "c"))
+ (check-not-exn (λ () (ann ((inst s8 String) -1 -2 "c") s3)))
+ (check-true (s3? ((inst s8 String) -1 -2 "c")))
+
+ ;(check-equal? (s9-x (s9 8 9 10)) 8)
+ ;(check-equal? (s9-y (s9 8 9 10)) 9)
+ (check-equal? (s9-z (s9 8 9 10)) 10)
+ (check-equal? (s5-x (s9 8 9 10)) 8)
+ (check-equal? (s5-y (s9 8 9 10)) 9)
+ (check-equal? (s9 8 9 10) (s9 8 9 10))
+ ;(check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j");;;;;;;;;;;;;;
+ ; (Struct s5))));;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ (check-not-exn (λ () (ann ((inst s9 Number Symbol String) 8 'i "j")
+ (s5 Number Symbol))))
+ (check-true (s5? ((inst s9 Number Symbol String) -1 'i "j")))
+ (check-not-equal? (s10 11 12 13) (s10 11 12 13))
+ (check-not-equal? (s11 14 15 16) (s11 14 15 16))]
+
+@subsection{@racket[define-struct/exec]}
+
+@chunk[<define-struct/exec>
+ (define-syntax (new-define-struct/exec stx)
+ (syntax-parse stx
+ [(_ (~and name+parent (~or name:id [name:id parent:id]))
+ ([field:id (~maybe :colon type:expr)] ...)
+ [proc :colon proc-type])
+ (template (define-struct/exec name+parent
+ ([field (?? (?@ : (tmpl-expand-type () type)))] ...)
+ [proc : (tmpl-expand-type () proc-type)]))]))]
+
+@chunk[<test-define-struct/exec>
+ (define-struct/exec se0 ()
+ ;[(λ (self v) (cons self v)) : (∀ (A) (→ se0 A (Pairof se0 A)))])
+ [(λ (self v) (cons self v)) : (→ se0 Any (Pairof se0 Any))])
+ (define-struct/exec se1 ([x : Number])
+ ;[(λ (self v) (cons self v)) : (∀ (A) (→ se0 A (Pairof se0 A)))])
+ [(λ (self v) (cons self v)) : (→ se1 Any (Pairof se1 Any))])
+ (define-struct/exec se2 ([x : Number] [y : Number])
+ [(λ (self v) (cons self v)) : (→ se2 Any (Pairof se2 Any))])
+ (define-struct/exec (se3 se2) ([z : String])
+ [(λ (self v w) (list self v w))
+ ;: (∀ (A B) (→ se3 A B (List se2 A B)))])
+ : (→ se3 Any Any (List se2 Any Any))])
+ (define-struct/exec (se4 se2) ([z : String])
+ [(λ (self v w) (list self v w))
+ ;: (∀ (A B) (→ se4 A B (List se2 A B)))])
+ : (→ se4 Any (→ Number Number) (List se2 Any (→ Number Number)))])
+
+ (check (λ (a b) (not (equal? a b))) (se0) (se0))
+ (check-equal? (cdr ((se0) 'a)) 'a)
+ (check-not-exn (λ () (ann (car ((se0) 'a)) se0)))
+ (check-true (se0? (car ((se0) 'a))))
+
+ (check (λ (a b) (not (equal? a b))) (se1 123) (se1 123))
+ (check-equal? (se1-x (se1 123)) 123)
+ (check-equal? (se1-x (car ((se1 123) 'b))) 123)
+ (check-equal? (cdr ((se1 123) 'b)) 'b)
+ (check-not-exn (λ () (ann (car ((se1 123) 'b)) se1)))
+ (check-true (se1? (car ((se1 123) 'b))))
+
+ (check (λ (a b) (not (equal? a b))) (se2 2 3) (se2 2 3))
+ (check-equal? (se2-x (se2 2 3)) 2)
+ (check-equal? (se2-y (se2 2 3)) 3)
+ (check-equal? (se2-x (car ((se2 2 3) 'c))) 2)
+ (check-equal? (se2-y (car ((se2 2 3) 'c))) 3)
+ (check-equal? (cdr ((se2 2 3) 'c)) 'c)
+ (check-not-exn (λ () (ann (car ((se2 2 3) 'c)) se2)))
+ (check-true (se2? (car ((se2 2 3) 'c))))
+
+ (check (λ (a b) (not (equal? a b))) (se3 4 5 "f") (se3 4 5 "f"))
+ (check-equal? (se2-x (se3 4 5 "f")) 4)
+ (check-equal? (se2-y (se3 4 5 "f")) 5)
+ (check-equal? (se3-z (se3 4 5 "f")) "f")
+ (check-equal? (se2-x (car ((se3 4 5 "f") 'd 'e))) 2)
+ (check-equal? (se2-y (car ((se3 4 5 "f") 'd 'e))) 3)
+ (check-equal? (let ([ret : Any (car ((se3 4 5 "f") 'd 'e))])
+ (if (se3? ret)
+ (se3-z ret)
+ "wrong type!"))
+ "f")
+ (check-equal? (cadr ((se3 4 5 "f") 'd 'e)) 'd)
+ (check-equal? (caddr ((se3 4 5 "f") 'd 'e)) 'e)
+ (check-equal? ((caddr ((se4 4 5 "f") 'd (λ ([x : Number]) (* x 2)))) 123)
+ 246)
+ (check-not-exn (λ () (ann (car ((se3 4 5 "f") 'd 'e)) se2)))
+ (check-not-exn (λ () (ann (car ((se3 4 5 "f") 'd 'e)) se3)))
+ (check-true (se2? (car ((se2 2 3) 'd))))
+ (check-true (se3? (car ((se2 2 3) 'e))))]
@subsection{@racket[ann]}
@chunk[<ann>
(define-syntax/parse (new-ann value:expr (~optional :colon) type:expr)
- (template (ann value (template-expand-type () type))))]
+ (template (ann value (tmpl-expand-type () type))))]
@chunk[<test-ann>
(let ()
@@ -543,8 +658,8 @@ them.
(define-syntax/parse (new-inst v
(~optional :colon) t ...
(~optional (~seq last (~datum ...) b:id)))
- (template (inst v (template-expand-type () t) ...
- (?? (?@ (template-expand-type () last)
+ (template (inst v (tmpl-expand-type () t) ...
+ (?? (?@ (tmpl-expand-type () last)
(... ...) b)))))]
@chunk[<test-inst>
@@ -577,8 +692,8 @@ them.
e:expr] ...)
. rest)
(template
- (let (?? (?@ loop (?? (?@ : (template-expand-type tvars.vars
- return-type)))))
+ (let (?? (?@ loop (?? (?@ : (tmpl-expand-type tvars.vars
+ return-type)))))
(?@ . tvars)
([(?@ . name.expanded) e] ...)
. rest)))]
@@ -664,7 +779,7 @@ them.
@chunk[<make-predicate>
(define-syntax/parse (new-make-predicate type:expr)
- (template (make-predicate (template-expand-type () type))))]
+ (template (make-predicate (tmpl-expand-type () type))))]
@chunk[<test-make-predicate>
(let ()
@@ -781,7 +896,7 @@ yet.
do:
with-handlers
define-struct/exec:
- define-struct/exec)]
+ #|define-struct/exec|#)]
@section{Future work}
@@ -863,7 +978,8 @@ We can finally define the overloaded forms, as well as the extra
(require (for-syntax racket
racket/syntax
syntax/parse
- syntax/parse/experimental/template)
+ syntax/parse/experimental/template
+ "../lib/low-untyped.rkt")
"../lib/low.rkt")
(require (submod ".." expander))
@@ -880,6 +996,7 @@ We can finally define the overloaded forms, as well as the extra
[new-lambda lambda]
[new-lambda λ]
[new-struct struct]
+ [new-define-struct/exec define-struct/exec]
[new-ann ann]
[new-inst inst]
[new-let let]
@@ -897,6 +1014,7 @@ We can finally define the overloaded forms, as well as the extra
<define>
<lambda>
<struct>
+ <define-struct/exec>
<ann>
<inst>
<let>
@@ -921,6 +1039,7 @@ And, last but not least, we will add a @tc[test] module.
<test-define>
<test-lambda>
<test-struct>
+ <test-define-struct/exec>
<test-ann>
<test-inst>
<test-let>