suzanne.soy/typed-struct-props
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added support and test for parent structs

Browse Source
This commit is contained in:
Georges Dupéron 2016-09-05 01:26:06 +02:00
parent 4df27aabdb
commit 32d7d75e60
4 changed files with 140 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
main.rkt
View File

@ -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)

5
scribblings/typed-struct-props.scrbl
View File

@ -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))]

65
test/test-child.rkt Normal file
View File

@ -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)))

64
test/test-parent.rkt Normal file
View File

@ -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)))