Implemented in library: check-equal?-classes:, which tests that elements in the same class are equal?, and elements in distinct classes are not equal?, as well as repeat-stx, which solves the (syntax-parse #'((1 2 3) (x y)) [([a b …] …) #'([(a b) …] …)) problem.
This commit is contained in:
Georges Dupéron
parent
9de841d95f
commit
1455f37350
|
|
@ -1,9 +1,12 @@
|
|||
#lang debug typed/racket
|
||||
|
||||
(require "structure.lp2.rkt")
|
||||
(require "../type-expander/type-expander.lp2.rkt")
|
||||
;(require "structure.lp2.rkt")
|
||||
;(require "variant.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"]))
|
||||
|
|
@ -12,6 +15,12 @@
|
|||
(check-equal:? (st 1 "b") ((structure a b) 1 "b"))
|
||||
(check-equal:? (st 1 "b") ((structure [a] b) 1 "b"))
|
||||
|
||||
((tagged t a b c) 1 'b "c")
|
||||
((tagged t a [b] c) 1 'b "c")
|
||||
((tagged t [a] [b] [c]) 1 'b "c")
|
||||
((tagged t [a : Number] [b : Symbol] [c : String]) 1 'b "c")
|
||||
(tagged t [a : Number 1] [b : Symbol 'b] [c : String "c"])
|
||||
(tagged t [a 1] [b 'b] [c "c"])
|
||||
|
||||
#|
|
||||
(require (submod "graph3.lp2.rkt" test))
|
||||
|
|
@ -49,4 +58,5 @@
|
|||
|
||||
(forceall 5 g)
|
||||
|
||||
|#
|
||||
|#
|
||||
|
|
@ -39,4 +39,4 @@
|
|||
(structure fba fbv)
|
||||
(structure fav)
|
||||
(structure a)
|
||||
(structure a)
|
||||
(structure a)
|
||||
|
|
@ -28,62 +28,51 @@ types, it wouldn't be clear what fields the remaining type parameters affect).
|
|||
(~or field:id
|
||||
[field:id (~maybe (~lit :) type:expr) (~maybe value:expr)]))))}
|
||||
|
||||
A call to @tc[(structure)] with no field, is ambiguous: it could return a
|
||||
constructor function, or an instance. We added two optional keywords,
|
||||
@tc[#:instance] and @tc[#:constructor], to disambiguate. They can also be used
|
||||
when fields with or without values are provided, so that macros don't need to
|
||||
handle the empty structure as a special case.
|
||||
|
||||
@chunk[<structure-args-stx-class>
|
||||
(define-splicing-syntax-class structure-args-stx-class
|
||||
(pattern
|
||||
(~or (~seq #:instance (~parse (field … value …) #'()))
|
||||
(~seq #:constructor (~parse (field …) #'()))
|
||||
(~seq (~maybe #:constructor ~!)
|
||||
(~or (~seq (~or-bug [field:id] field:id) …+)
|
||||
(~seq [field:id (~and C (~lit :)) type:expr] …+)))
|
||||
(~seq (~maybe #:instance ~!)
|
||||
(~or (~seq [field:id value:expr] …+)
|
||||
(~seq [field:id (~and C (~lit :)) type:expr
|
||||
value:expr] …+))))))]
|
||||
|
||||
@chunk[<structure>
|
||||
(begin-for-syntax <structure-args-stx-class>)
|
||||
|
||||
(define-multi-id structure
|
||||
#:type-expander structure-type-expander
|
||||
#:match-expander structure-match-expander
|
||||
#: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)))]
|
||||
#:call
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(_ :structure-args-stx-class)
|
||||
(define/with-syntax c #'(make-structure-constructor field …))
|
||||
(define/with-syntax ct (template (?? (inst c type …) c)))
|
||||
(syntax-property
|
||||
(template (?? (ct value …) ct))
|
||||
'disappeared-use (stx-map syntax-local-introduce
|
||||
(template ((?? (?@ (C …)))))))])))]
|
||||
|
||||
@chunk[<test-structure>
|
||||
(let ()
|
||||
(define-structure empty-st)
|
||||
(define-structure stA [a Number])
|
||||
(check-equal:? (empty-st) ((structure)))
|
||||
(check-equal:? (empty-st) ((structure #:constructor)))
|
||||
(check-not-equal:? (empty-st) (structure [a 1]))
|
||||
(check-not-equal:? (structure) (structure [a 1]))
|
||||
(check-not-equal:? (structure #:constructor) (structure [a 1]))
|
||||
(check-not-equal:? (empty-st) (stA 1))
|
||||
(check-not-equal:? (structure) (stA 1)))
|
||||
(check-not-equal:? (structure #:constructor) (stA 1)))
|
||||
#;(let ()
|
||||
(define-structure st [a Number] [b String])
|
||||
(define-structure stA [a Number])
|
||||
|
|
@ -247,18 +236,10 @@ 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<?))
|
||||
<all-remembered-structs+empty>))]
|
||||
(get-remembered 'structure)))]
|
||||
[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.
|
||||
|
||||
|
|
@ -306,9 +287,8 @@ should succeed.
|
|||
(let ()
|
||||
(define/with-syntax (sorted-field ...)
|
||||
(sort-fields #'(field ...)))
|
||||
(define/with-syntax (TTemp ...)
|
||||
(generate-temporaries #'(field ...)))
|
||||
#`(λ #:∀ (TTemp ...) ([field : TTemp] ...)
|
||||
(define-temp-ids "~a/TTemp" (field …))
|
||||
#`(λ #:∀ (field/TTemp …) ([field : field/TTemp] …)
|
||||
(#,(fields→stx-name #'(field ...)) sorted-field ...)))
|
||||
(remember-all-errors #'list stx #'(field ...))))]
|
||||
|
||||
|
|
@ -443,13 +423,20 @@ instead of needing an extra recompilation.
|
|||
@CHUNK[<type-expander>
|
||||
(define-for-syntax (structure-type-expander stx)
|
||||
(syntax-parse stx
|
||||
[(_ [field type] ...)
|
||||
[(_ (~or-bug [field:id] field:id) …)
|
||||
(if (check-remember-fields #'(field ...))
|
||||
(let ()
|
||||
(define/with-syntax (sorted-field …)
|
||||
(sort-fields #'(field …)))
|
||||
(fields→stx-name #'(field …)))
|
||||
(remember-all-errors #'U stx #'(field ...)))]
|
||||
[(_ (~seq [field:id type:expr] …))
|
||||
(if (check-remember-fields #'(field ...))
|
||||
(let ()
|
||||
(define/with-syntax ([sorted-field sorted-type] ...)
|
||||
(sort-car-fields #'((field type) ...)))
|
||||
(if (stx-null? #'(sorted-type ...))
|
||||
(fields→stx-name #'(field …)) ; #'(field …) is empty here.
|
||||
(fields→stx-name #'()) ; #'(field …) is empty here.
|
||||
#`(#,(fields→stx-name #'(field ...)) sorted-type ...)))
|
||||
(remember-all-errors #'U stx #'(field ...)))]))]
|
||||
|
||||
|
|
@ -549,6 +536,9 @@ chances that we could write a definition for that identifier.
|
|||
get
|
||||
structure)
|
||||
|
||||
(begin-for-syntax
|
||||
(provide structure-args-stx-class))
|
||||
|
||||
<remember-all>
|
||||
<get-remembered>
|
||||
<check-remember-fields>
|
||||
|
|
@ -558,9 +548,6 @@ 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>
|
||||
|
||||
|
|
@ -590,7 +577,6 @@ chances that we could write a definition for that identifier.
|
|||
<test-type-expander>
|
||||
<test-structure>
|
||||
<test-define-structure>
|
||||
<test-hybrid-empty-2>
|
||||
|
||||
(require (submod ".." doc))))]
|
||||
|
||||
|
|
|
|||
|
|
@ -117,10 +117,34 @@ number of name collisions.
|
|||
(λ/syntax-parse (_ tag:id . structure-pat)
|
||||
#`(constructor tag #,(syntax/loc #'structure-pat
|
||||
(structure . structure-pat))))
|
||||
#:call
|
||||
(λ/syntax-parse (_ tag:id . structure-field-value)
|
||||
#`(constructor tag #,(syntax/loc #'structure-field-value
|
||||
(structure . structure-field-value)))))]
|
||||
#:call ;; TODO: clean this up a bit, and explain it.
|
||||
(λ/syntax-parse
|
||||
(~and (_ (~and (~seq disambiguate …) (~or (~seq #:instance)
|
||||
(~seq #:constructor)
|
||||
(~seq)))
|
||||
tag:id . fields)
|
||||
(~parse (sa:structure-args-stx-class)
|
||||
#'(disambiguate … . fields)))
|
||||
(define-temp-ids "~a/TTemp" (sa.field …))
|
||||
(define/with-syntax c
|
||||
(if (attribute sa.type)
|
||||
#`(λ ([sa.field : 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/TTemp …) ([sa.field : 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] …))))))
|
||||
(if (attribute sa.value)
|
||||
#'(c sa.value …)
|
||||
#'c)))]
|
||||
|
||||
@chunk[<test-tagged>
|
||||
(check-equal? (match (ann (tagged foo [x "o"] [y 3] [z 'z])
|
||||
|
|
@ -146,7 +170,7 @@ number of name collisions.
|
|||
#'(tagged tag [field pat] ...))
|
||||
#:call
|
||||
(λ/syntax-parse (_ value ...)
|
||||
#'(tagged tag [field value] ...))))]
|
||||
#'(tagged tag #:instance [field value] ...))))]
|
||||
|
||||
@chunk[<test-define-tagged>
|
||||
(define-tagged tagged-s1)
|
||||
|
|
|
|||
|
|
@ -10,11 +10,19 @@
|
|||
(provide half-typed-module typed/untyped-prefix define-modules)
|
||||
|
||||
;; half-typed-module
|
||||
(define-syntax-rule (typed-module m typed-language untyped-language . body)
|
||||
(module m typed-language . body))
|
||||
(define-syntax-rule (typed-module m t u typed-language untyped-language . body)
|
||||
(begin
|
||||
(module m typed-language
|
||||
(module t typed-language . body)
|
||||
(module u untyped-language . body)
|
||||
. body)))
|
||||
|
||||
(define-syntax-rule (untyped-module m typed-language untyped-language . body)
|
||||
(module m untyped-language . body))
|
||||
(define-syntax-rule (untyped-module m u typed-language untyped-language . body)
|
||||
(begin
|
||||
(module m untyped-language
|
||||
(module t typed-language . body)
|
||||
(module u untyped-language . body)
|
||||
. body)))
|
||||
|
||||
(define-typed/untyped-identifier half-typed-module typed-module untyped-module)
|
||||
|
||||
|
|
@ -92,74 +100,76 @@
|
|||
(check-equal? require-provide-foo 7))
|
||||
|
||||
;; ==== low/syntax-parse.rkt ====
|
||||
(require syntax/parse
|
||||
syntax/parse/define
|
||||
(for-syntax racket/syntax))
|
||||
|
||||
(provide define-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
|
||||
racket/stxparam)
|
||||
racket/stxparam)
|
||||
(define-modules ([no-submodule]
|
||||
[syntax-parse-extensions-untyped typed/racket/no-check])
|
||||
(require syntax/parse
|
||||
syntax/parse/define
|
||||
(for-syntax racket/base
|
||||
racket/syntax))
|
||||
|
||||
(provide stx)
|
||||
(provide define-syntax/parse
|
||||
λ/syntax-parse
|
||||
~maybe
|
||||
~lit
|
||||
~or-bug)
|
||||
|
||||
(define-syntax-parameter stx
|
||||
(lambda (stx)
|
||||
(raise-syntax-error (syntax-e stx)
|
||||
"Can only be used in define-syntax/parse"))))
|
||||
|
||||
(define-simple-macro (define-syntax/parse (name . args) . body)
|
||||
(define-syntax (name stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[(_ . args) . body]))))
|
||||
|
||||
(define-simple-macro (λ/syntax-parse args . body)
|
||||
(λ (stx2)
|
||||
;(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[args . body])));)
|
||||
(define-syntax ~maybe
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self pat ...)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
#`(#,(s #'~optional) (#,(s #'~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-parse stx
|
||||
[(self pat ...)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
#`(#,(s #'~and) x (#,(s #'~parse) (#,(s #'~or) pat ...) #'x))]))))
|
||||
|
||||
(define-syntax ~lit
|
||||
(pattern-expander
|
||||
(λ (stx)
|
||||
(syntax-parse stx
|
||||
[(self (~optional (~seq name:id (~literal ~))) lit)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(if (attribute name)
|
||||
#`(#,(s #'~and) name (#,(s #'~literal) lit))
|
||||
#`(#,(s #'~literal) lit))]
|
||||
[(self (~optional (~seq name:id (~literal ~))) lit …)
|
||||
(define (s stx) (datum->syntax #'self stx stx stx))
|
||||
(if (attribute name)
|
||||
#`(#,(s #'~and) name (#,(s #'~seq) (#,(s #'~literal) lit)))
|
||||
#`(#,(s #'~seq) (#,(s #'~literal) lit)))]))))
|
||||
|
||||
(begin-for-syntax
|
||||
(require (for-syntax racket/base
|
||||
racket/stxparam)
|
||||
racket/stxparam)
|
||||
|
||||
(provide stx)
|
||||
|
||||
(define-syntax-parameter stx
|
||||
(lambda (stx)
|
||||
(raise-syntax-error (syntax-e stx)
|
||||
"Can only be used in define-syntax/parse"))))
|
||||
|
||||
(define-simple-macro (define-syntax/parse (name . args) body0 . body)
|
||||
(define-syntax (name stx2)
|
||||
(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[(_ . args) body0 . body]))))
|
||||
|
||||
(define-simple-macro (λ/syntax-parse args . body)
|
||||
(λ (stx2)
|
||||
;(syntax-parameterize ([stx (make-rename-transformer #'stx2)])
|
||||
(syntax-parse stx2
|
||||
[args . body]))))
|
||||
|
||||
;; If you include this as a file, you need to do:
|
||||
;(begin-for-syntax (provide stx))
|
||||
|
|
@ -220,6 +230,7 @@
|
|||
sixth-value seventh-value eighth-value ninth-value tenth-value
|
||||
∘
|
||||
…
|
||||
…+
|
||||
stx-list
|
||||
stx-e
|
||||
stx-pair
|
||||
|
|
@ -240,7 +251,9 @@
|
|||
|
||||
(require (only-in racket
|
||||
[compose ∘]
|
||||
[... …]))
|
||||
[... …])
|
||||
(only-in syntax/parse
|
||||
[...+ …+]))
|
||||
|
||||
(require (for-syntax syntax/parse syntax/parse/experimental/template))
|
||||
|
||||
|
|
@ -437,7 +450,7 @@
|
|||
([x : (Listof Number) (in-heads '(1 2 3 4 5))]) x)
|
||||
'((1) (1 2) (1 2 3) (1 2 3 4) (1 2 3 4 5))))
|
||||
|
||||
;; Can't write the type of on-split, because typed/racket doesn't allow writing
|
||||
;; Can't write the type of in-split, because typed/racket doesn't allow writing
|
||||
;; (Sequenceof A B), just (Sequenceof A).
|
||||
;; in-parallel's type has access to the multi-valued version of Sequenceof,
|
||||
;; though, so we let typed/racket propagate the inferred type.
|
||||
|
|
@ -998,4 +1011,186 @@
|
|||
[(_ expr )]))
|
||||
|#
|
||||
|
||||
;; ==== low/repeat-stx.rkt ===
|
||||
|
||||
(define-modules ([no-submodule] [repeat-stx-untyped typed/racket/no-check])
|
||||
(require syntax/stx
|
||||
(for-syntax racket/base
|
||||
racket/syntax
|
||||
syntax/parse))
|
||||
|
||||
(provide repeat-stx)
|
||||
|
||||
(define-for-syntax (repeat-stx-2 stx)
|
||||
(syntax-parse stx
|
||||
[(a:id b:id)
|
||||
#'(λ _ a)]
|
||||
[(a:id (b:expr (~literal ...)))
|
||||
#`(λ (bs) (stx-map #,(repeat-stx-2 #'(a b)) bs))]))
|
||||
|
||||
(define-for-syntax (repeat-stx-1 stx)
|
||||
(syntax-parse stx
|
||||
[(a:id b:expr)
|
||||
#`(λ (a bs) (#,(repeat-stx-2 #'(a b)) bs))]
|
||||
[((a:expr (~literal ...)) (b:expr (~literal ...)))
|
||||
#`(λ (s1 s2) (stx-map #,(repeat-stx-1 #'(a b)) s1 s2))]))
|
||||
|
||||
(define-syntax (repeat-stx stx)
|
||||
(syntax-parse stx
|
||||
[(_ a:expr b:expr)
|
||||
#`(#,(repeat-stx-1 #'(a b)) #'a #'b)])))
|
||||
|
||||
(module repeat-stx-test racket
|
||||
(require (submod ".." repeat-stx-untyped))
|
||||
(require syntax/parse
|
||||
rackunit)
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 2)
|
||||
[(a b)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a b)))])
|
||||
1)
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 2 3)
|
||||
[(a b ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a (b ...))))])
|
||||
'(1 1))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 (2 3) (uu vv ww) (xx yy))
|
||||
[(a (b ...) ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a ((b ...) ...))))])
|
||||
'((1 1) (1 1 1) (1 1)))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(1 ((2) (3 3)) ((uu) (vv vv) (ww ww ww)) ((xx) (yy)))
|
||||
[(a ((b ...) ...) ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx a (((b ...) ...) ...))))])
|
||||
'(((1) (1 1)) ((1) (1 1) (1 1 1)) ((1) (1))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'([1 x] [2 y] [3 z])
|
||||
[([a b] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (b ...))))])
|
||||
'(1 2 3))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((1 2 3) (a b))
|
||||
[([a b ...] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) ((b ...) ...))))])
|
||||
'((1 1) (a)))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'(((1 2 3) (a b)) ((x y z t) (-1 -2)))
|
||||
[[[[a b ...] ...] ...]
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx ((a ...) ...) (((b ...) ...) ...))))])
|
||||
'(((1 1) (a)) ((x x x) (-1))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((f (1 2 3) (a b)) (g (x y z t) (-1 -2)))
|
||||
[[[a (b ...) ...] ...]
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (((b ...) ...) ...))))])
|
||||
'(((f f f) (f f)) ((g g g g) (g g))))
|
||||
|
||||
(check-equal?
|
||||
(syntax-parse #'((h () ()) (i () (x y z) ()))
|
||||
[([a (b ...) ...] ...)
|
||||
(syntax->datum
|
||||
(datum->syntax
|
||||
#'dummy
|
||||
(repeat-stx (a ...) (((b ...) ...) ...))))])
|
||||
'((() ()) (() (i i i) ()))))
|
||||
|
||||
(module+ test
|
||||
(require (submod ".." repeat-stx-test)))
|
||||
|
||||
;; ==== low/test-framework.rkt ====
|
||||
(require (for-syntax syntax/parse)
|
||||
(for-syntax (submod "." syntax-parse-extensions-untyped))
|
||||
(for-syntax (submod "." repeat-stx-untyped))
|
||||
typed/rackunit)
|
||||
|
||||
(provide check-equal?-classes
|
||||
check-equal?-classes:)
|
||||
|
||||
(: check-equal?-classes (∀ (A ...) (→ (Pairof String (Listof A)) ... Void)))
|
||||
(define (check-equal?-classes . classes)
|
||||
(for* ([(head tail) (in-split* classes)])
|
||||
(let ([this-class (sequence-ref tail 0)]
|
||||
[different-classes (in-sequences head (sequence-tail tail 1))])
|
||||
(for ([val (cdr this-class)])
|
||||
(for ([other-val (cdr this-class)])
|
||||
#;(displayln (format "Test ~a ∈ ~a = ~a ∈ ~a …"
|
||||
val
|
||||
this-class
|
||||
other-val
|
||||
this-class))
|
||||
(check-equal? val other-val
|
||||
(format "Test ~a ∈ ~a = ~a ∈ ~a failed."
|
||||
val
|
||||
this-class
|
||||
other-val
|
||||
this-class)))
|
||||
(for ([different-class different-classes])
|
||||
(for ([different-val (cdr different-class)])
|
||||
#;(displayln (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a …"
|
||||
val
|
||||
this-class
|
||||
different-val
|
||||
different-class
|
||||
(sequence->list different-classes)))
|
||||
(check-not-equal? val different-val
|
||||
(format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a failed."
|
||||
val
|
||||
this-class
|
||||
different-val
|
||||
different-class
|
||||
(sequence->list different-classes)))))))))
|
||||
|
||||
(define-syntax/parse (check-equal?-classes:
|
||||
(~seq [(~maybe #:name name:expr)
|
||||
(~maybe (~lit :) c-type)
|
||||
(~seq val (~maybe (~lit :) v-type)) …])
|
||||
…)
|
||||
(define/with-syntax ([a-val …] …)
|
||||
(template ([(?? (ann val v-type) val) …] …)))
|
||||
(define/with-syntax ([aa-val …] …)
|
||||
(let ()
|
||||
;; TODO: this is ugly, repeat-stx should handle missing stuff instead.
|
||||
(define/with-syntax (xx-c-type …) (template ((?? (c-type) ()) …)))
|
||||
(syntax-parse (repeat-stx (xx-c-type …) ([val …] …))
|
||||
[([((~optional c-type-rep)) …] …)
|
||||
(template ([(?? name "") (?? (ann a-val c-type-rep) a-val) …] …))])))
|
||||
(template
|
||||
(check-equal?-classes (list aa-val …) …)))
|
||||
|
||||
;; ==== low/typed-not-implemented-yet.rkt ====
|
||||
|
||||
(define-syntax-rule (? t) ((λ () : t (error "Not implemented yet"))))
|
||||
|
||||
;; ==== end ====
|
||||
|
|
@ -495,10 +495,6 @@ them.
|
|||
(~and name+parent (~or name:id [name:id parent:id]))
|
||||
([field:id :colon type:expr] ...)
|
||||
. rest)
|
||||
(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))]))]
|
||||
|
|
@ -631,7 +627,6 @@ them.
|
|||
(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))))]
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user