commit d7d8651efe67f3316f29b8939e230d59442b1ae8
parent 23f903c3bc14680f884815c69585a2b9b89ab2ee
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Sun, 4 Sep 2016 23:35:34 +0200
Implemented and documented struct/props.
Diffstat:
12 files changed, 452 insertions(+), 38 deletions(-)
diff --git a/info.rkt b/info.rkt
@@ -1,9 +1,18 @@
#lang info
(define collection "typed-struct-props")
(define deps '("base"
- "rackunit-lib"))
-(define build-deps '("scribble-lib" "racket-doc"))
-(define scribblings '(("scribblings/typed-struct-props.scrbl" ())))
-(define pkg-desc "Description Here")
+ "rackunit-lib"
+ "typed-racket-lib"
+ "typed-racket-more"))
+(define build-deps '("scribble-lib"
+ "racket-doc"
+ "typed-racket-doc"))
+(define scribblings
+ '(("scribblings/typed-struct-props.scrbl" () ("typed-racket"))))
+(define pkg-desc
+ (string-append "Makes a small subset of struct type properties available"
+ " in Typed/Racket. The API should hopefully stay"
+ " backward-compatible when Typed/Racket officially supports"
+ " (or rejects) structure type properties."))
(define version "0.0")
-(define pkg-authors '(georges))
+(define pkg-authors '("Georges Dupéron"))
diff --git a/main.rkt b/main.rkt
@@ -1,35 +1,80 @@
-#lang racket/base
+#lang typed/racket
-(module+ test
- (require rackunit))
+(provide struct/props)
-;; Notice
-;; To install (from within the package directory):
-;; $ raco pkg install
-;; To install (once uploaded to pkgs.racket-lang.org):
-;; $ raco pkg install <<name>>
-;; To uninstall:
-;; $ raco pkg remove <<name>>
-;; To view documentation:
-;; $ raco docs <<name>>
-;;
-;; For your convenience, we have included a LICENSE.txt file, which links to
-;; the GNU Lesser General Public License.
-;; If you would prefer to use a different license, replace LICENSE.txt with the
-;; desired license.
-;;
-;; Some users like to add a `private/` directory, place auxiliary files there,
-;; and require them in `main.rkt`.
-;;
-;; See the current version of the racket style guide here:
-;; http://docs.racket-lang.org/style/index.html
+(require (for-syntax racket/syntax
+ racket/function
+ syntax/parse
+ syntax/stx))
-;; Code here
+(begin-for-syntax
+ (define-syntax-rule (when-attr name . rest)
+ (if (attribute name) #`rest #'())))
-(module+ test
- ;; Tests to be run with raco test
- )
+(define-syntax struct/props
+ (syntax-parser
+ [(_ (~optional (~and polymorphic (T ...)))
+ name
+ (~and fields ([field (~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)))
+ ...)
+ (define poly? (and (attribute polymorphic) (not (stx-null? #'(T ...)))))
+
+ (define maybe-∀
+ (if poly?
+ (λ (result-stx) #`(∀ (T ...) #,result-stx))
+ (λ (result-stx) result-stx)))
+
+ (define/with-syntax (T2 ...)
+ (if poly?
+ (stx-map (λ (t) (format-id #'here "~a-2" t)) #'(T ...))
+ #'(_unused)))
+ (define maybe-∀2
+ (if poly?
+ (λ (result-stx) #`(∀ (T ... T2 ...) #,result-stx))
+ (λ (result-stx) result-stx)))
+
+ (define/with-syntax ins
+ (if poly? #'(name T ...) #'name))
+
+ (define/with-syntax ins2
+ (if poly? #'(name T2 ...) #'name))
+
+ #`(begin
+ #,@(when-attr custom-write
+ (: printer #,(maybe-∀ #'(→ ins Output-Port (U #t #f 0 1) Any)))
+ (define printer custom-write))
+ #,@(if (attribute equal+hash)
+ (let ()
+ (define/with-syntax equal+hash-ann
+ (syntax-parse #'equal+hash
+ [((~and list (~literal list)) equal? hash1 hash2)
+ #`(list (ann equal?
+ #,(maybe-∀2
+ #'(→ ins ins2 (→ Any Any Boolean) Any)))
+ (ann hash1
+ #,(maybe-∀
+ #'(→ ins (→ Any Integer) Integer)))
+ (ann hash2
+ #,(maybe-∀
+ #'(→ ins (→ Any Integer) Integer))))]
+ [expr:expr #'expr]))
+ #`((: eq+h (List #,(maybe-∀2
+ #'(→ ins ins2 (→ Any Any Boolean) Any))
+ #,(maybe-∀
+ #'(→ ins (→ Any Integer) Integer))
+ #,(maybe-∀
+ #'(→ ins (→ Any Integer) Integer))))
+ (define eq+h equal+hash-ann)))
+ #'())
+
+ (struct #,@(when-attr polymorphic (T ...))
+ name
+ fields
+ #,@(when-attr transparent #:transparent)
+ #,@(when-attr custom-write #:property prop:custom-write printer)
+ #,@(when-attr equal+hash #:property prop:equal+hash eq+h)))]))
-(module+ main
- ;; Main entry point, executed when run with the `racket` executable or DrRacket.
- )
diff --git a/scribblings/typed-struct-props.scrbl b/scribblings/typed-struct-props.scrbl
@@ -2,9 +2,62 @@
@require[@for-label[typed-struct-props
racket/base]]
-@title{typed-struct-props}
-@author{georges}
+@title{Struct type properties for Typed/Racket}
+@author[@author+email["Georges Dupéron" "georges.duperon@gmail.com"]]
@defmodule[typed-struct-props]
-Package Description Here
+@defform[#:literals (: prop:custom-write )
+ (struct/props maybe-type-vars name ([field : type] ...) options ...)
+ #:grammar
+ [(maybe-type-vars (code:line)
+ (v ...))
+ (options #:transparent
+ (code:line #:property prop:custom-write custom-write)
+ (code:line #:equal+hash equal+hash))]
+ #:contracts ([custom-write
+ (∀ (v ...)
+ (→ (name v ...)
+ Output-Port
+ (U #t #f 0 1)
+ Any))]
+ [equal+hash
+ (List (∀ (v ... |v'| ...)
+ (→ (name v ...)
+ (name |v'| ...)
+ (→ Any Any Boolean)
+ Any))
+ (∀ (v ...)
+ (→ (name v ...)
+ (→ Any Integer)
+ Integer))
+ (∀ (v ...)
+ (→ (name v ...)
+ (→ Any Integer)
+ Integer)))])]{
+ This form defines a @racketmodname[typed/racket] struct type, and accepts a
+ small subset of @racketmodname[racket]'s struct type properties.
+
+ It implements these struct type properties in a type-safe manner: the current
+ implementation in @racketmodname[typed/racket] does not properly type-check
+ functions and values used as struct type properties. This library declares the
+ user-provided functions outside of the struct definition, with the type given
+ above (e.g.
+ @racket[(∀ (v ...) (→ (name v ...) Output-Port (U #t #f 0 1) Any))] for the
+ argument of the @racket[prop:custom-write] property), to ensure that these
+ functions and values are properly checked.
+
+ The API should (hopefully) stay backward-compatible when Typed/Racket
+ officially supports (or rejects) structure type properties. In other words:
+ @itemlist[
+ @item{If @racketmodname[typed/racket] eventually implements the same interface
+ as the one provided by this library, then we will update this library so
+ that it simply re-provide @racket[struct] renamed as @racket[struct/props].}
+ @item{If @racketmodname[typed/racket] eventually implements some type-safe
+ struct type properties, then we will update this library will so that it
+ translates back to @racketmodname[typed/racket]'s implementation, as much as
+ possible.}
+ @item{If @racketmodname[typed/racket] eventually disallows struct type
+ properties, then we will update this library so that it uses some
+ @racketmodname[typed/racket/unsafe] tricks to still make them available, if
+ it can be done.}]}
+\ No newline at end of file
diff --git a/test/test-equal+hash-poly.rkt b/test/test-equal+hash-poly.rkt
@@ -0,0 +1,34 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props (A) foo ([f : A]) #:transparent
+ #:property prop:equal+hash (list (λ (a b rec) #f)
+ (λ (a rec) 42)
+ (λ (a rec) 43)))
+
+(struct/props (A) bar ([f : A]) #:transparent)
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo "b") (foo String))))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo "b")) String)
+ "b")
+
+(test-begin
+ (test-false "The equal? function supplied to #:equal+hash is used"
+ (equal? (foo 0) (foo 0)))
+
+ (test-true "When unspecified, the default implementation of equal? is used"
+ (equal? (bar 0) (bar 0))))
+
+(test-equal? "The equal-hash-code function supplied to #:equal+hash is used"
+ (equal-hash-code (foo "d"))
+ (equal-hash-code (foo "e")))
+
+(test-equal?
+ "The equal-secondary hash-code function supplied to #:equal+hash is used"
+ (equal-secondary-hash-code (foo 'f))
+ (equal-secondary-hash-code (foo 'g)))
diff --git a/test/test-equal+hash.rkt b/test/test-equal+hash.rkt
@@ -0,0 +1,34 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props foo ([f : Number]) #:transparent
+ #:property prop:equal+hash (list (λ (a b rec) #f)
+ (λ (a rec) 42)
+ (λ (a rec) 43)))
+
+(struct/props bar ([f : Number]) #:transparent)
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo 12) foo)))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo 12)) Number)
+ 12)
+
+(test-begin
+ (test-false "The equal? function supplied to #:equal+hash is used"
+ (equal? (foo 0) (foo 0)))
+
+ (test-true "When unspecified, the default implementation of equal? is used"
+ (equal? (bar 0) (bar 0))))
+
+(test-equal? "The equal-hash-code function supplied to #:equal+hash is used"
+ (equal-hash-code (foo 34))
+ (equal-hash-code (foo 56)))
+
+(test-equal?
+ "The equal-secondary hash-code function supplied to #:equal+hash is used"
+ (equal-secondary-hash-code (foo 78))
+ (equal-secondary-hash-code (foo 90)))
diff --git a/test/test-none-poly.rkt b/test/test-none-poly.rkt
@@ -0,0 +1,14 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props (A) foo ([f : A]) #:transparent)
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo "b") (foo String))))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo "b")) String)
+ "b")
+
diff --git a/test/test-none.rkt b/test/test-none.rkt
@@ -0,0 +1,13 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props foo ([f : Number]) #:transparent)
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo 12) foo)))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo 12)) Number)
+ 12)
+\ No newline at end of file
diff --git a/test/test-poly.rkt b/test/test-poly.rkt
@@ -0,0 +1,75 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props (A) foo1 ([f : A] [g : A]) #:transparent
+ #:property prop:custom-write
+ (λ (this out mode)
+ (write (ann (list (foo1-f this)
+ (foo1-g this))
+ (Listof A))
+ out)))
+
+(struct/props (A) foo2 ([f : A] [g : A]) #:transparent
+ #:property prop:equal+hash
+ (list (λ (a b rec)
+ ;; We can access the A ... here, but not the A' ...
+ (ann (list (foo2-f a)
+ (foo2-g a))
+ (Listof A))
+ #f)
+ (λ (a rec)
+ ;; Type inference works, despite the lambda being in a
+ ;; list, because we detect the special case where a list
+ ;; is immediately constructed.
+ (ann (list (foo2-f a)
+ (foo2-g a))
+ (Listof A))
+ 42)
+ (λ (a rec)
+ ;; Type inference works, despite the lambda being in a
+ ;; list, because we detect the special case where a list
+ ;; is immediately constructed.
+ (ann (list (foo2-f a)
+ (foo2-g a))
+ (Listof A))
+ 43)))
+
+(struct/props (A) foo3 ([f : A] [g : A]) #:transparent
+ #:property prop:custom-write
+ (λ #:∀ (X) ([this : (foo3 X)] out mode)
+ (write (ann (list (foo3-f this)
+ (foo3-g this))
+ (Listof X))
+ out)))
+
+(struct/props (A) foo4 ([f : A] [g : A]) #:transparent
+ #:property prop:equal+hash
+ (list (λ #:∀ (Y YY) ([a : (foo4 Y)] [b : (foo4 YY)] rec)
+ ;; We can access the A ... here, but not the A' ...
+ (ann (list (foo4-f a)
+ (foo4-g a))
+ (Listof Y))
+ (ann (list (foo4-f b)
+ (foo4-g b))
+ (Listof YY))
+ #f)
+ (λ #:∀ (Z) ([a : (foo4 Z)] rec)
+ ;; Type inference works, despite the lambda being in a
+ ;; list, because we detect the special case where a list
+ ;; is immediately constructed.
+ (ann (list (foo4-f a)
+ (foo4-g a))
+ (Listof Z))
+ 42)
+ (λ #:∀ (W) ([a : (foo4 W)] rec)
+ ;; Type inference works, despite the lambda being in a
+ ;; list, because we detect the special case where a list
+ ;; is immediately constructed.
+ (ann (list (foo4-f a)
+ (foo4-g a))
+ (Listof W))
+ 43)))
+
+;; TODO: write some negative tests.
+\ No newline at end of file
diff --git a/test/test-write+equal+hash-poly.rkt b/test/test-write+equal+hash-poly.rkt
@@ -0,0 +1,45 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props (A) foo ([f : A]) #:transparent
+ #:property prop:custom-write
+ (λ (this out mode)
+ (fprintf out "#<an-instance ~a>" (foo-f this)))
+ #:property prop:equal+hash
+ (list (λ (a b rec) #f)
+ (λ (a rec) 42)
+ (λ (a rec) 43)))
+
+(struct/props (A) bar ([f : A]) #:transparent
+ #:property prop:custom-write
+ (λ (this out mode)
+ (fprintf out "#<bar-instance ~a>" (bar-f this))))
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo "b") (foo String))))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo "b")) String)
+ "b")
+
+(test-equal? "The prop:custom-write is taken into account"
+ (format "~a" (foo 1))
+ "#<an-instance 1>")
+
+(test-begin
+ (test-false "The equal? function supplied to #:equal+hash is used"
+ (equal? (foo 0) (foo 0)))
+
+ (test-true "When unspecified, the default implementation of equal? is used"
+ (equal? (bar 0) (bar 0))))
+
+(test-equal? "The equal-hash-code function supplied to #:equal+hash is used"
+ (equal-hash-code (foo "d"))
+ (equal-hash-code (foo "e")))
+
+(test-equal?
+ "The equal-secondary hash-code function supplied to #:equal+hash is used"
+ (equal-secondary-hash-code (foo 'f))
+ (equal-secondary-hash-code (foo 'g)))
+\ No newline at end of file
diff --git a/test/test-write+equal+hash.rkt b/test/test-write+equal+hash.rkt
@@ -0,0 +1,45 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props foo ([f : Number]) #:transparent
+ #:property prop:custom-write
+ (λ (this out mode)
+ (fprintf out "#<an-instance ~a>" (foo-f this)))
+ #:property prop:equal+hash
+ (list (λ (a b rec) #f)
+ (λ (a rec) 42)
+ (λ (a rec) 43)))
+
+(struct/props bar ([f : Number]) #:transparent
+ #:property prop:custom-write
+ (λ (this out mode)
+ (fprintf out "#<bar-instance ~a>" (bar-f this))))
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo 12) foo)))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo 12)) Number)
+ 12)
+
+(test-equal? "The prop:custom-write is taken into account"
+ (format "~a" (foo 1))
+ "#<an-instance 1>")
+
+(test-begin
+ (test-false "The equal? function supplied to #:equal+hash is used"
+ (equal? (foo 0) (foo 0)))
+
+ (test-true "When unspecified, the default implementation of equal? is used"
+ (equal? (bar 0) (bar 0))))
+
+(test-equal? "The equal-hash-code function supplied to #:equal+hash is used"
+ (equal-hash-code (foo 34))
+ (equal-hash-code (foo 56)))
+
+(test-equal?
+ "The equal-secondary hash-code function supplied to #:equal+hash is used"
+ (equal-secondary-hash-code (foo 78))
+ (equal-secondary-hash-code (foo 90)))
+\ No newline at end of file
diff --git a/test/test-write-poly.rkt b/test/test-write-poly.rkt
@@ -0,0 +1,21 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props (A) foo ([f : A]) #:transparent
+ #:property prop:custom-write
+ (λ (this out mode)
+ (fprintf out "#<an-instance ~a>" (foo-f this))))
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo "b") (foo String))))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo "b")) String)
+ "b")
+
+(test-equal? "The prop:custom-write is taken into account"
+ (format "~a" (foo 1))
+ "#<an-instance 1>")
+
diff --git a/test/test-write.rkt b/test/test-write.rkt
@@ -0,0 +1,20 @@
+#lang typed/racket
+
+(require typed-struct-props
+ typed/rackunit)
+
+(struct/props foo ([f : Number]) #:transparent
+ #:property prop:custom-write
+ (λ (this out mode)
+ (fprintf out "#<f2-instance ~a>" (foo-f this))))
+
+(test-not-exn "The structure's constructor and type work properly"
+ (λ () (ann (foo 12) foo)))
+
+(test-equal? "The structure's constructor and accessor work properly"
+ (ann (foo-f (foo 12)) Number)
+ 12)
+
+(test-equal? "The prop:custom-write is taken into account"
+ (format "~a" (foo 1))
+ "#<f2-instance 1>")
+\ No newline at end of file
