Implemented and documented struct/props.

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

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

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.}]}

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

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

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")
+

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)

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.

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

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

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>")
+

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