diff --git a/info.rkt b/info.rkt index 762bda3..8c88a9e 100644 --- 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 index 216dcac..9a36b46 100644 --- 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 <> -;; To uninstall: -;; $ raco pkg remove <> -;; To view documentation: -;; $ raco docs <> -;; -;; 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 index b413814..c4d2988 100644 --- 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 new file mode 100644 index 0000000..b8a8806 --- /dev/null +++ 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 new file mode 100644 index 0000000..7706cf1 --- /dev/null +++ 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 new file mode 100644 index 0000000..edb52ea --- /dev/null +++ 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 new file mode 100644 index 0000000..d37bbff --- /dev/null +++ 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 new file mode 100644 index 0000000..b2ac285 --- /dev/null +++ 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 new file mode 100644 index 0000000..f0070d1 --- /dev/null +++ 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 "#" (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-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)) + "#") + +(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 new file mode 100644 index 0000000..8276303 --- /dev/null +++ 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 "#" (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-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)) + "#") + +(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 new file mode 100644 index 0000000..e51f72b --- /dev/null +++ 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 "#" (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)) + "#") + diff --git a/test/test-write.rkt b/test/test-write.rkt new file mode 100644 index 0000000..8b93feb --- /dev/null +++ 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 "#" (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)) + "#") \ No newline at end of file