From 32d7d75e605f45c62878b18f7d12ac231dc16226 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Georges=20Dup=C3=A9ron?= Date: Mon, 5 Sep 2016 01:26:06 +0200 Subject: [PATCH] Added support and test for parent structs --- main.rkt | 12 ++--- scribblings/typed-struct-props.scrbl | 5 ++- test/test-child.rkt | 65 ++++++++++++++++++++++++++++ test/test-parent.rkt | 64 +++++++++++++++++++++++++++ 4 files changed, 140 insertions(+), 6 deletions(-) create mode 100644 test/test-child.rkt create mode 100644 test/test-parent.rkt diff --git a/main.rkt b/main.rkt index 9a36b46..1ae023b 100644 --- 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 index 49443d4..b4f7fa5 100644 --- 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 new file mode 100644 index 0000000..ee7aebf --- /dev/null +++ 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 new file mode 100644 index 0000000..09dda9d --- /dev/null +++ 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)))