Work in progress for implementing (structure) so that it is both a hybrid function and empty struct, but actually it can't be passed to polymorphic functions (like map, …), so it's probably better to just add an optional #:instance or #:constructor argument to clarify.
This commit is contained in:
Georges Dupéron
parent
8a398ae5a3
commit
9de841d95f
|
|
@ -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)
|
||||
|
||||
|#
|
||||
|
|
@ -38,3 +38,5 @@
|
|||
(structure faa fab fav)
|
||||
(structure fba fbv)
|
||||
(structure fav)
|
||||
(structure a)
|
||||
(structure a)
|
||||
|
|
|
|||
|
|
@ -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))))]
|
||||
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user