commit 32d7d75e605f45c62878b18f7d12ac231dc16226
parent 4df27aabdbf0304ec877217e7f797842a60de181
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Mon, 5 Sep 2016 01:26:06 +0200
Added support and test for parent structs
Diffstat:
4 files changed, 140 insertions(+), 6 deletions(-)
diff --git a/main.rkt b/main.rkt
@@ -13,13 +13,14 @@
(define-syntax struct/props
(syntax-parser
- [(_ (~optional (~and polymorphic (T ...)))
- name
- (~and fields ([field (~literal :) type] ...))
+ [(_ (~optional (~and polymorphic (T:id ...)))
+ name:id
+ (~optional parent:id)
+ (~and fields ([field:id (~literal :) type] ...))
(~or
(~optional (~and transparent #:transparent))
- (~optional (~seq #:property (~literal prop:custom-write) custom-write))
- (~optional (~seq #:property (~literal prop:equal+hash) equal+hash)))
+ (~optional (~seq #:property (~literal prop:custom-write) custom-write:expr))
+ (~optional (~seq #:property (~literal prop:equal+hash) equal+hash:expr)))
...)
(define poly? (and (attribute polymorphic) (not (stx-null? #'(T ...)))))
@@ -73,6 +74,7 @@
(struct #,@(when-attr polymorphic (T ...))
name
+ #,@(when-attr parent parent)
fields
#,@(when-attr transparent #:transparent)
#,@(when-attr custom-write #:property prop:custom-write printer)
diff --git a/scribblings/typed-struct-props.scrbl b/scribblings/typed-struct-props.scrbl
@@ -8,10 +8,13 @@
@defmodule[typed-struct-props]
@defform[#:literals (: prop:custom-write prop:equal+hash)
- (struct/props maybe-type-vars name ([field : type] ...) options ...)
+ (struct/props maybe-type-vars name maybe-parent ([field : type] ...)
+ options ...)
#:grammar
[(maybe-type-vars (code:line)
(v ...))
+ (maybe-parent (code:line)
+ parent-id)
(options #:transparent
(code:line #:property prop:custom-write custom-write)
(code:line #:property prop:equal+hash equal+hash))]
diff --git a/test/test-child.rkt b/test/test-child.rkt
@@ -0,0 +1,65 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+(define-syntax (test-not-equal? stx)
+ (syntax-case stx ()
+ [(_ name v1 v2)
+ (syntax/loc stx
+ (test-false name (equal? v1 v2)))]))
+
+(struct foo-parent ([f : Number]) #:transparent)
+
+(struct/props (A) foo foo-parent ([g : A]) #:transparent
+ #:property prop:equal+hash (list (λ (a b rec) #f)
+ (λ (a rec) 42)
+ (λ (a rec) 43)))
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo 12 "b") (foo String))))
+
+(test-equal? "The structure's constructor and accessor for a field declared by
+ the parent work properly"
+ (ann (foo-parent-f (foo 12 "b")) Number)
+ 12)
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-g (foo 12 "b")) String)
+ "b")
+
+(test-false "The equal? function supplied to #:equal+hash is used"
+ (equal? (foo 0 "b") (foo 0 "b")))
+
+(test-equal? "The equal-hash-code function supplied to #:equal+hash is used"
+ (equal-hash-code (foo 34 "c"))
+ (equal-hash-code (foo 56 "d")))
+
+(test-equal?
+ "The equal-secondary hash-code function supplied to #:equal+hash is used"
+ (equal-secondary-hash-code (foo 78 'e))
+ (equal-secondary-hash-code (foo 90 'f)))
+
+
+
+
+(test-not-exn "The parent structure's constructor and type work properly"
+ (λ () (ann (foo-parent 12) foo-parent)
+ (void)))
+
+(test-equal? "The parent structure's constructor and accessor work properly"
+ (ann (foo-parent-f (foo-parent 12)) Number)
+ 12)
+
+(test-true "The equal? function supplied to #:equal+hash is not used in the
+ parent"
+ (equal? (foo-parent 0) (foo-parent 0)))
+
+(test-not-equal? "The equal-hash-code function supplied to #:equal+hash is not
+ used in the parent"
+ (equal-hash-code (foo-parent 34))
+ (equal-hash-code (foo-parent 56)))
+
+(test-not-equal? "The equal-secondary hash-code function supplied to
+ #:equal+hash is not used in the parent"
+ (equal-secondary-hash-code (foo-parent 78))
+ (equal-secondary-hash-code (foo-parent 90)))
diff --git a/test/test-parent.rkt b/test/test-parent.rkt
@@ -0,0 +1,64 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+(define-syntax (test-not-equal? stx)
+ (syntax-case stx ()
+ [(_ name v1 v2)
+ (syntax/loc stx
+ (test-false name (equal? v1 v2)))]))
+
+(struct/props (A) foo-parent ([f : A]) #:transparent
+ #:property prop:equal+hash (list (λ (a b rec) #f)
+ (λ (a rec) 42)
+ (λ (a rec) 43)))
+
+(struct (A) foo foo-parent ([g : Number]) #:transparent)
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo "b" 12 ) (foo String))))
+
+(test-equal? "The structure's constructor and accessor for a field declared by
+ the parent work properly"
+ (ann (foo-parent-f (foo "b" 12)) String)
+ "b")
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-g (foo "b" 12)) Number)
+ 12)
+
+(test-false "The equal? function supplied to #:equal+hash is used"
+ (equal? (foo "b" 0) (foo "b" 0)))
+
+(test-equal? "The equal-hash-code function supplied to #:equal+hash is used"
+ (equal-hash-code (foo "c" 34))
+ (equal-hash-code (foo "d" 56)))
+
+(test-equal? "The equal-secondary hash-code function supplied to #:equal+hash is
+ used"
+ (equal-secondary-hash-code (foo 'e 78))
+ (equal-secondary-hash-code (foo 'f 90)))
+
+
+
+
+(test-not-exn "The parent structure's constructor and type work properly"
+ (λ () (ann (foo-parent "b") (foo-parent String))
+ (void)))
+
+(test-equal? "The parent structure's constructor and accessor work properly"
+ (ann (foo-parent-f (foo-parent "b")) String)
+ "b")
+
+(test-false "The equal? function supplied to #:equal+hash is used in the parent"
+ (equal? (foo-parent 0) (foo-parent 0)))
+
+(test-equal? "The equal-hash-code function supplied to #:equal+hash is used in
+ the parent"
+ (equal-hash-code (foo-parent 34))
+ (equal-hash-code (foo-parent 56)))
+
+(test-equal? "The equal-secondary hash-code function supplied to #:equal+hash is
+ used in the parent"
+ (equal-secondary-hash-code (foo-parent 78))
+ (equal-secondary-hash-code (foo-parent 90)))
