commit 1c0fa751d6a8b06e46f663bd468e6ea0d48fcdf2
parent 8a7d487e1446aa69ba96ab3cef6cc44da2c3cde6
Author: Stephen Chang <stchang@ccs.neu.edu>
Date: Thu, 13 Oct 2016 15:20:30 -0400
split out a define-binding-type from define-type-constructor
- document #:arg-variances and variances; #:arr
- fixes #36
- start to split type constructor macro into (not working yet)
- ty-: expands to expanded type representation
- ty: performs kindchecking and expands to ty-
- this makes it easier for programmers to implement their own kind
system, but still get some turnstile conveniences like pat expanders
Diffstat:
18 files changed, 337 insertions(+), 107 deletions(-)
diff --git a/macrotypes/examples/exist.rkt b/macrotypes/examples/exist.rkt
@@ -11,7 +11,7 @@
(provide ∃ pack open)
-(define-type-constructor ∃ #:bvs = 1)
+(define-binding-type ∃ #:bvs = 1)
(define-typed-syntax pack
[(_ (τ:type e) as ∃τ:type)
diff --git a/macrotypes/examples/fomega.rkt b/macrotypes/examples/fomega.rkt
@@ -53,7 +53,7 @@
(define-kind-constructor ⇒ #:arity >= 1)
(define-kind-constructor ∀★ #:arity >= 0)
-(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★)
+(define-binding-type ∀ #:bvs >= 0 #:arr ∀★)
;; alternative: normalize before type=?
; but then also need to normalize in current-promote
diff --git a/macrotypes/examples/fomega2.rkt b/macrotypes/examples/fomega2.rkt
@@ -44,7 +44,7 @@
(define-base-kind ★)
(define-kind-constructor ∀★ #:arity >= 0)
-(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★)
+(define-binding-type ∀ #:bvs >= 0 #:arr ∀★)
;; alternative: normalize before type=?
; but then also need to normalize in current-promote
diff --git a/macrotypes/examples/stlc+rec-iso.rkt b/macrotypes/examples/stlc+rec-iso.rkt
@@ -14,7 +14,7 @@
(provide μ unfld fld)
-(define-type-constructor μ #:bvs = 1)
+(define-binding-type μ #:bvs = 1)
(define-typed-syntax unfld
[(_ τ:type-ann e)
diff --git a/macrotypes/examples/sysf.rkt b/macrotypes/examples/sysf.rkt
@@ -11,7 +11,7 @@
(provide (type-out ∀) Λ inst)
-(define-type-constructor ∀ #:bvs >= 0)
+(define-binding-type ∀)
(define-typed-syntax Λ
[(_ (tv:id ...) e)
diff --git a/macrotypes/examples/tests/general-tests.rkt b/macrotypes/examples/tests/general-tests.rkt
@@ -0,0 +1,36 @@
+#lang racket
+
+(module+ test
+ (require "../../typecheck.rkt"
+ "rackunit-typechecking.rkt")
+
+ ;; check ordering of type constructor args
+ (check-stx-err
+ (define-type-constructor #:a)
+ #:with-msg "expected identifier")
+ (check-stx-err
+ (define-type-constructor name #:a)
+ #:with-msg "expected one of these literals")
+
+ (define-type-constructor -> #:arity > 0)
+ (define-binding-type mu #:arity = 1 #:bvs = 1)
+ (define-binding-type forall #:bvs = 1 #:arity = 1)
+ (define-binding-type exist #:no-attach-kind #:bvs = 1 #:arity = 1)
+ (define-binding-type exist2 #:bvs = 1 #:arity = 1 #:no-attach-kind)
+ (define-binding-type exist3 #:bvs = 1 #:no-attach-kind #:arity = 1)
+
+ (check-stx-err
+ (define-binding-type exist4 #:bvs = 1 #:no-attach- #:arity = 1)
+ #:with-msg "expected one of these literals")
+
+ (define-type-constructor exist5)
+ (define-binding-type exist7)
+
+
+ (check-stx-err
+ (define-binding-type exist6 #:bvs 1)
+ #:with-msg "expected more terms")
+ (check-stx-err
+ (define-binding-type exist6 #:bvs = 1 #:bvs = 1)
+ #:with-msg "bad syntax") ; TODO: how to improve this?
+)
diff --git a/macrotypes/examples/tests/run-all-tests.rkt b/macrotypes/examples/tests/run-all-tests.rkt
@@ -1,5 +1,8 @@
#lang racket
+;; gen
+(require "general-tests.rkt")
+
;; stlc and extensions
(require "stlc-tests.rkt")
(require "stlc+lit-tests.rkt")
diff --git a/macrotypes/examples/tests/stlc+lit-tests.rkt b/macrotypes/examples/tests/stlc+lit-tests.rkt
@@ -59,4 +59,3 @@
(typecheck-fail (λ ([x : 1]) x) #:with-msg "not a valid type")
(typecheck-fail (λ ([x : (+ 1 2)]) x) #:with-msg "not a valid type")
(typecheck-fail (λ ([x : (λ ([y : Int]) y)]) x) #:with-msg "not a valid type")
-
diff --git a/macrotypes/typecheck.rkt b/macrotypes/typecheck.rkt
@@ -61,7 +61,9 @@
(begin-for-syntax
(define (mk-? id) (format-id id "~a?" id))
+ (define (mk-- id) (format-id id "~a-" id))
(define (mk-~ id) (format-id id "~~~a" id))
+ (define (mk-#% id) (format-id id "#%~a" id))
(define-for-syntax (mk-? id) (format-id id "~a?" id))
(define-for-syntax (mk-~ id) (format-id id "~~~a" id))
;; drop-file-ext : String -> String
@@ -597,95 +599,199 @@
(define-syntax define-basic-checked-id-stx
(syntax-parser #:datum-literals (:)
[(_ τ:id : kind)
- #:with #%tag (format-id #'kind "#%~a" #'kind)
#:with τ? (mk-? #'τ)
- #:with τ-internal (generate-temporary #'τ)
#:with τ-expander (mk-~ #'τ)
+ #:with τ-internal (generate-temporary #'τ)
#`(begin
(begin-for-syntax
(define (τ? t)
(syntax-parse t
- [((~literal #%plain-app) (~literal τ-internal)) #t][_ #f]))
- (define (inferτ+erase e)
- (syntax-parse (infer+erase e) #:context e
- [(e- e_τ)
- #:fail-unless (τ? #'e_τ)
- (format
- "~a (~a:~a): Expected expression ~v to have type ~a, got: ~a"
- (syntax-source e) (syntax-line e) (syntax-column e)
- (syntax->datum e) (type->str #'τ) (type->str #'e_τ))
- #'e-]))
+ [((~literal #%plain-app) (~literal τ-internal)) #t]
+ [_ #f]))
(define-syntax τ-expander
(pattern-expander
(syntax-parser
- [ty:id #'((~literal #%plain-app) (~literal τ-internal))]
- [(_ . rst) #'(((~literal #%plain-app) (~literal τ-internal)) . rst)]))))
+ [:id #'((~literal #%plain-app) (~literal τ-internal))]
+ ; - this case used by ⇑, TODO: remove this case?
+ ; - but it's also needed when matching a list of types,
+ ; e.g., in stlc+sub (~Nat τ)
+ [(_ . rst)
+ #'(((~literal #%plain-app) (~literal τ-internal)) . rst)]))))
(define τ-internal
(λ () (raise (exn:fail:type:runtime
(format "~a: Cannot use ~a at run time" 'τ 'kind)
(current-continuation-marks)))))
(define-syntax τ
(syntax-parser
- [(~var _ id)
+ [:id
(add-orig
(assign-type
- (syntax/loc this-syntax (τ-internal)) #'#%tag) #'τ)])))]))
+ (syntax/loc this-syntax (τ-internal))
+ #'kind)
+ #'τ)])))]))
-; I use identifiers "τ" and "kind" but this form is not restricted to them.
-; E.g., τ can be #'★ and kind can be #'#%kind (★'s type)
+;; The def uses pattern vars "τ" and "kind" but this form is not restricted to
+;; only types and kinds, eg, τ can be #'★ and kind can be #'#%kind (★'s type)
(define-syntax (define-basic-checked-stx stx)
(syntax-parse stx #:datum-literals (:)
[(_ τ:id : kind
- (~optional
- (~seq #:arity op n:exact-nonnegative-integer)
- #:defaults ([op #'=] [n #'1]))
- (~optional (~seq #:bvs (~and (~parse has-bvs? #'#t) bvs-op)
- bvs-n:exact-nonnegative-integer)
- #:defaults ([bvs-op #'=][bvs-n #'0]))
- (~optional (~seq #:arr (~and (~parse has-annotations? #'#t) tycon))
- #:defaults ([tycon #'void]))
- (~optional (~seq #:arg-variances arg-variances-stx:expr)
- #:defaults ([arg-variances-stx
- #`(λ (stx-id) (for/list ([arg (in-list (stx->list (stx-cdr stx-id)))])
- invariant))]))
- (~optional (~seq #:extra-info extra-info)
- #:defaults ([extra-info #'void])))
- #:with #%kind (format-id #'kind "#%~a" #'kind)
+ (~or
+ (~optional (~and #:no-attach-kind (~parse no-attach-kind? #'#t)))
+ (~optional
+ (~seq #:arity op n:exact-nonnegative-integer)
+ #:defaults ([op #'=] [n #'1]))
+ (~optional (~seq #:arg-variances arg-variances-stx:expr)
+ #:defaults ([arg-variances-stx
+ #`(λ (stx-id)
+ (for/list ([arg (in-list (stx->list (stx-cdr stx-id)))])
+ invariant))]))
+ (~optional (~seq #:extra-info extra-info)
+ #:defaults ([extra-info #'void]))) ...)
+ #:with #%kind (mk-#% #'kind)
+ #:with τ? (mk-? #'τ)
+ #:with τ- (mk-- #'τ)
+ #:with τ-expander (mk-~ #'τ)
#:with τ-internal (generate-temporary #'τ)
+ #`(begin
+ (begin-for-syntax
+ (define-syntax τ-expander
+ (pattern-expander
+ (syntax-parser
+ [(_ . pat)
+ #:with expanded-τ (generate-temporary)
+ #'(~and expanded-τ
+ (~Any
+ (~literal/else τ-internal
+ (format "Expected ~a type, got: ~a"
+ 'τ (type->str #'expanded-τ))
+ #'expanded-τ)
+ . pat))])))
+ (define arg-variances arg-variances-stx)
+ (define (τ? t)
+ (syntax-parse t
+ [(~Any (~literal τ-internal) . _) #t]
+ [_ #f])))
+ (define τ-internal
+ (λ _ (raise (exn:fail:type:runtime
+ (format "~a: Cannot use ~a at run time" 'τ 'kind)
+ (current-continuation-marks)))))
+ ; τ- is an internal constructor:
+ ; - it does not validate inputs and does not attach a kind,
+ ; ie, it won't be recognized as a valid type unless a kind
+ ; system is implemented on top
+ ; - the τ constructor implements a default kind system but τ-
+ ; is available if the programmer wants to implement their own
+ (define-syntax (τ- stx)
+ (syntax-parse stx
+ [(_ . args)
+ #:with τ-internal* (add-arg-variances #'τ-internal (arg-variances #'(τ . args)))
+ (syntax/loc stx
+ (τ-internal* (λ () (#%expression extra-info) . args)))]))
+ ; this is the actual constructor
+ (define-syntax (τ stx)
+ (syntax-parse stx
+ [(_ . args)
+ #:fail-unless (op (stx-length #'args) n)
+ (format "wrong number of arguments, expected ~a ~a"
+ 'op 'n)
+ #:with ([arg- _] (... ...)) (infers+erase #'args)
+ ;; the args are validated on the next line, rather than above
+ ;; to ensure enough stx-parse progress so we get a proper err msg,
+ ;; ie, "invalid type" instead of "improper tycon usage"
+ #:with (~! (~var _ kind) (... ...)) #'(arg- (... ...))
+ (add-orig
+ (assign-type #'(τ- arg- (... ...)) #'#%kind)
+ stx)]
+ [_ ;; else fail with err msg
+ (type-error
+ #:src stx
+ #:msg
+ (string-append
+ "Improper usage of type constructor ~a: ~a, expected ~a ~a arguments")
+ #'τ stx #'op #'n)])))]))
+
+;; Form for defining *binding* types, kinds, etc.
+;; The def uses pattern vars "τ" and "kind" but this form is not restricted to
+;; only types and kinds, eg, τ can be #'★ and kind can be #'#%kind (★'s type)
+(define-syntax (define-binding-checked-stx stx)
+ (syntax-parse stx #:datum-literals (:)
+ [(_ τ:id : kind
+ (~or
+ (~optional (~and #:no-attach-kind (~parse no-attach-kind? #'#t)))
+ (~optional
+ (~seq #:arity op n:exact-nonnegative-integer)
+ #:defaults ([op #'=] [n #'1]))
+ (~optional
+ (~seq #:bvs bvs-op bvs-n:exact-nonnegative-integer)
+ #:defaults ([bvs-op #'>=][bvs-n #'0]))
+ (~optional
+ (~seq #:arr (~and kindcon (~parse has-annotations? #'#t)))
+ #:defaults ([kindcon #'void])) ; default kindcon should never be used
+ (~optional
+ (~seq #:arg-variances arg-variances-stx:expr)
+ #:defaults ([arg-variances-stx
+ #`(λ (stx-id)
+ (for/list ([arg (in-list (stx->list (stx-cdr stx-id)))])
+ invariant))]))
+ (~optional
+ (~seq #:extra-info extra-info)
+ #:defaults ([extra-info #'void]))) ...)
+ #:with #%kind (mk-#% #'kind)
#:with τ? (mk-? #'τ)
+ #:with τ- (mk-- #'τ)
#:with τ-expander (mk-~ #'τ)
+ #:with τ-internal (generate-temporary #'τ)
#`(begin
(begin-for-syntax
(define-syntax τ-expander
(pattern-expander
(syntax-parser
+ ; this case used by ⇑, TODO: remove this case?
+ ;; if has-annotations?
+ ;; - type has surface shape
+ ;; (τ ([tv : k] ...) body ...)
+ ;; - this case parses to pattern
+ ;; [([tv k] ...) (body ...)]
+ ;; if not has-annotations?
+ ;; - type has surface shape
+ ;; (τ (tv ...) body ...)
+ ;; - this case parses to pattern
+ ;; [(tv ...) (body ...)]
[(_ . pat:id)
#:with expanded-τ (generate-temporary)
- #:with tycon-expander (mk-~ #'tycon)
+ #:with kindcon-expander (mk-~ #'kindcon)
#'(~and expanded-τ
- (~Any/bvs (~literal/else τ-internal
- (format "Expected ~a type, got: ~a"
- 'τ (type->str #'expanded-τ))
- #'expanded-τ)
- (~and bvs (tv (... (... ...))))
- . rst)
- #,(if (attribute has-bvs?)
- (if (attribute has-annotations?)
- #'(~and (~parse (tycon-expander k (... (... ...))) (typeof #'expanded-τ))
- (~parse pat #'(([tv k] (... (... ...))) rst)))
- #'(~parse pat #'(bvs rst)))
- #'(~parse pat #'rst)))]
+ (~Any/bvs
+ (~literal/else τ-internal
+ (format "Expected ~a type, got: ~a"
+ 'τ (type->str #'expanded-τ))
+ #'expanded-τ)
+ (~and bvs (tv (... (... ...))))
+ . rst)
+ #,(if (attribute has-annotations?)
+ #'(~and
+ (~parse (kindcon-expander k (... (... ...)))
+ (typeof #'expanded-τ))
+ (~parse pat
+ #'[([tv k] (... (... ...))) rst]))
+ #'(~parse
+ pat
+ #'[bvs rst]))
+ )]
;; TODO: fix this to handle has-annotations?
- [(_ (~optional (~and (~fail #:unless #,(attribute has-bvs?)) bvs-pat)
- #:defaults ([bvs-pat #'()])) . pat)
+ ;; the difference with the first case is that here
+ ;; the body is ungrouped, ie,
+ ;; parses to pattern[(tv ...) . (body ...)]
+ [(_ bvs-pat . pat)
#:with expanded-τ (generate-temporary)
#'(~and expanded-τ
- (~Any/bvs (~literal/else τ-internal
- (format "Expected ~a type, got: ~a"
- 'τ (type->str #'expanded-τ))
- #'expanded-τ)
- bvs-pat
- . pat))])))
+ (~Any/bvs
+ (~literal/else τ-internal
+ (format "Expected ~a type, got: ~a"
+ 'τ (type->str #'expanded-τ))
+ #'expanded-τ)
+ bvs-pat
+ . pat))])))
(define arg-variances arg-variances-stx)
(define (τ? t)
(syntax-parse t
@@ -696,35 +802,45 @@
(λ _ (raise (exn:fail:type:runtime
(format "~a: Cannot use ~a at run time" 'τ 'kind)
(current-continuation-marks)))))
- ;; ; this is the actual constructor
+ ; τ- is an internal constructor:
+ ; - it does not validate inputs and does not attach a kind,
+ ; ie, it won't be recognized as a valid type unless a kind
+ ; system is implemented on top
+ ; - the τ constructor implements a default kind system but τ-
+ ; is available if the programmer wants to implement their own
+ (define-syntax (τ- stx)
+ (syntax-parse stx
+ [(_ bvs . args)
+ #:with τ-internal* (add-arg-variances
+ #'τ-internal
+ (arg-variances #'(τ- . args))) ; drop bvs
+ (syntax/loc stx
+ (τ-internal* (λ bvs (#%expression extra-info) . args)))]))
+ ; this is the actual constructor
(define-syntax (τ stx)
(syntax-parse stx
- [(_ (~optional (~and (~fail #:unless #,(attribute has-bvs?))
- (~or (bv:id (... ...))
- (~and (~fail #:unless #,(attribute has-annotations?))
- bvs+ann)))
- #:defaults ([(bv 1) null])) . args)
- #:with bvs (if #,(attribute has-annotations?)
- #'bvs+ann
- #'([bv : #%kind] (... ...)))
- ;#:declare bvs ctx ; can't assume kind-ctx is defined
- #:fail-unless (bvs-op (stx-length #'bvs) bvs-n)
- (format "wrong number of type vars, expected ~a ~a" 'bvs-op 'bvs-n)
+ [(_ (~or (bv:id (... ...))
+ (~and (~fail #:unless #,(attribute has-annotations?))
+ bvs+ann))
+ . args)
+ #:with bvs+ks (if #,(attribute has-annotations?)
+ #'bvs+ann
+ #'([bv : #%kind] (... ...)))
+ #:fail-unless (bvs-op (stx-length #'bvs+ks) bvs-n)
+ (format "wrong number of type vars, expected ~a ~a"
+ 'bvs-op 'bvs-n)
#:fail-unless (op (stx-length #'args) n)
- (format "wrong number of arguments, expected ~a ~a" 'op 'n)
- #:with (bvs- τs- _) (infers/ctx+erase #'bvs #'args)
- #:with (~! (~var _ kind) (... ...)) #'τs-
- #:with ([tv (~datum :) k_arg] (... ...)) #'bvs
- #:with k_result (if #,(attribute has-annotations?)
- #'(tycon k_arg (... ...))
- #'#%kind)
- #:with τ-internal* (add-arg-variances #'τ-internal (arg-variances stx))
- (add-orig
- (assign-type
- (syntax/loc stx
- (τ-internal* (λ bvs- (#%expression extra-info) . τs-)))
- #'k_result)
- #'(τ . args))]
+ (format "wrong number of arguments, expected ~a ~a"
+ 'op 'n)
+ #:with (bvs- τs- _) (infers/ctx+erase #'bvs+ks #'args)
+ #:with (~! (~var _ kind) (... ...)) #'τs-
+ #:with ([tv (~datum :) k_arg] (... ...)) #'bvs+ks
+ #:with k_result (if #,(attribute has-annotations?)
+ #'(kindcon k_arg (... ...))
+ #'#%kind)
+; #:with ty-out (expand/df #'(τ- bvs- . τs-))
+ #:with ty-out #'(τ- bvs- . τs-)
+ (add-orig (assign-type #'ty-out #'k_result) stx)]
;; else fail with err msg
[_
(type-error #:src stx
@@ -749,6 +865,8 @@
#:with define-base-name (format-id #'name "define-base-~a" #'name)
#:with define-base-names (format-id #'name "define-base-~as" #'name)
#:with define-name-cons (format-id #'name "define-~a-constructor" #'name)
+ #:with define-binding-name (format-id #'name "define-binding-~a" #'name)
+ #:with define-internal-name-cons (format-id #'name "define-internal-~a-constructor" #'name)
#:with name-ann (format-id #'name "~a-ann" #'name)
#:with name=? (format-id #'name "~a=?" #'name)
#:with names=? (format-id #'names "~a=?" #'names)
@@ -841,13 +959,26 @@
modes)]))))
(define-syntax define-base-name
(syntax-parser
- [(_ (~var x id) . rst) #'(define-basic-checked-id-stx x : name . rst)]))
+ [(_ (~var x id) (~datum :) k)
+ #'(define-basic-checked-id-stx x : k)]
+ [(_ (~var x id))
+ #'(define-basic-checked-id-stx x : #%tag)]))
(define-syntax define-base-names
(syntax-parser
- [(_ (~var x id) (... ...)) #'(begin (define-base-name x) (... ...))]))
+ [(_ (~var x id) (... ...))
+ #'(begin (define-base-name x) (... ...))]))
+ (define-syntax define-internal-name-cons
+ (syntax-parser
+ [(_ (~var x id) . rst)
+ #'(define-basic-checked-stx x : name #:no-attach-kind . rst)]))
(define-syntax define-name-cons
(syntax-parser
- [(_ (~var x id) . rst) #'(define-basic-checked-stx x : name . rst)])))]))
+ [(_ (~var x id) . rst)
+ #'(define-basic-checked-stx x : name . rst)]))
+ (define-syntax define-binding-name
+ (syntax-parser
+ [(_ (~var x id) . rst)
+ #'(define-binding-checked-stx x : name . rst)])))]))
;; pre-declare all type-related functions and forms
(define-syntax-category type)
@@ -894,8 +1025,8 @@
(define-syntax ~Any
(pattern-expander
(syntax-parser
- [(_ tycons x ...)
- #'(~Any/bvs tycons _ x ...)])))
+ [(_ tycons . rst)
+ #'(~Any/bvs tycons _ . rst)])))
(define-syntax ~literal/else
(pattern-expander
(syntax-parser
diff --git a/turnstile/examples/exist.rkt b/turnstile/examples/exist.rkt
@@ -11,7 +11,7 @@
(provide ∃ pack open)
-(define-type-constructor ∃ #:bvs = 1)
+(define-binding-type ∃ #:bvs = 1)
(define-typed-syntax (pack (τ:type e) as ∃τ:type) ≫
#:with (~∃ (τ_abstract) τ_body) #'∃τ.norm
diff --git a/turnstile/examples/fomega.rkt b/turnstile/examples/fomega.rkt
@@ -53,7 +53,7 @@
(define-kind-constructor ⇒ #:arity >= 1)
(define-kind-constructor ∀★ #:arity >= 0)
-(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★)
+(define-binding-type ∀ #:arr ∀★)
;; alternative: normalize before type=?
; but then also need to normalize in current-promote
diff --git a/turnstile/examples/fomega2.rkt b/turnstile/examples/fomega2.rkt
@@ -44,7 +44,7 @@
(define-base-kind ★)
(define-kind-constructor ∀★ #:arity >= 0)
-(define-type-constructor ∀ #:bvs >= 0 #:arr ∀★)
+(define-binding-type ∀ #:arr ∀★)
;; alternative: normalize before type=?
; but then also need to normalize in current-promote
diff --git a/turnstile/examples/infer.rkt b/turnstile/examples/infer.rkt
@@ -12,7 +12,7 @@
(provide → ∀ define define/rec λ #%app)
;; (Some [X ...] τ_body (Constraints (Constraint τ_1 τ_2) ...))
-(define-type-constructor Some #:arity = 2 #:bvs >= 0)
+(define-binding-type Some #:arity = 2)
(define-type-constructor Constraint #:arity = 2)
(define-type-constructor Constraints #:arity >= 0)
(define-syntax Cs
diff --git a/turnstile/examples/stlc+rec-iso.rkt b/turnstile/examples/stlc+rec-iso.rkt
@@ -14,7 +14,7 @@
(provide μ unfld fld)
-(define-type-constructor μ #:bvs = 1)
+(define-binding-type μ #:bvs = 1)
(define-typed-syntax (unfld τ:type-ann e) ≫
#:with (~μ (tv) τ_body) #'τ.norm
diff --git a/turnstile/examples/sysf.rkt b/turnstile/examples/sysf.rkt
@@ -11,7 +11,7 @@
(provide (type-out ∀) Λ inst)
-(define-type-constructor ∀ #:bvs >= 0)
+(define-binding-type ∀)
(define-typed-syntax (Λ (tv:id ...) e) ≫
[([tv ≫ tv- : #%type] ...) () ⊢ e ≫ e- ⇒ τ]
diff --git a/turnstile/examples/tests/rackunit-typechecking.rkt b/turnstile/examples/tests/rackunit-typechecking.rkt
@@ -1,7 +1,8 @@
#lang racket/base
(require (for-syntax rackunit syntax/srcloc) rackunit macrotypes/typecheck)
(provide check-type typecheck-fail check-not-type check-props check-runtime-exn
- check-equal/rand)
+ check-equal/rand
+ (rename-out [typecheck-fail check-stx-err]))
(begin-for-syntax
(define (add-esc s) (string-append "\\" s))
diff --git a/turnstile/examples/tests/rosette/run-all-rosette-tests.rkt b/turnstile/examples/tests/rosette/run-all-rosette-tests.rkt
@@ -1,5 +1,8 @@
#lang racket/base
(require "rosette-tests.rkt")
+(require "rosette2-tests.rkt")
+(require "rosette-guide-sec2-tests.rkt")
+(require "rosette-guide-sec3-tests.rkt")
(require "bv-tests.rkt")
;(require "bv-ref-tests.rkt")
; visit but dont instantiate, o.w. will get unsat
diff --git a/turnstile/scribblings/reference.scrbl b/turnstile/scribblings/reference.scrbl
@@ -145,28 +145,68 @@ Turnstile pre-declares @racket[(define-syntax-category type)], which in turn
@defform[(define-type-constructor name-id option ...)
#:grammar
([option (code:line #:arity op n)
- (code:line #:bvs op n)
- (code:line #:arr tycon)
(code:line #:arg-variances expr)
(code:line #:extra-info stx)])]{
- Defines a type constructor. Defining a type constructor @racket[τ] defines:
+ Defines a type constructor that does not bind type variables.
+ Defining a type constructor @racket[τ] defines:
@itemlist[@item{@racket[τ], a macro for constructing an instance of type
@racket[τ], with the specified arity.}
@item{@racket[τ?], a phase 1 predicate recognizing type @racket[τ].}
@item{@racket[~τ], a phase 1 @tech:pat-expander recognizing type @racket[τ].}]
- The @racket[#:arity] and @racket[#:bvs] arguments specify the valid shapes
+ The @racket[#:arity] argument specifies the valid shapes
for the type. For example
@racket[(define-type-constructor → #:arity >= 1)] defines an arrow type and
@racket[(define-type-constructor Pair #:arity = 2)] defines a pair type.
The default arity is @racket[= 1].
-
- Use the @racket[#:bvs] argument to define binding types, e.g.,
- @racket[(define-type-constructor ∀ #:arity = 1 #:bvs = 1)] defines a type
- with shape @racket[(∀ (X) τ)], where @racket[τ] may reference @racket[X].
+ The @racket[#:arg-variances] argument is a transformer converting a syntax
+ object of the type to a list of variances for the arguments to the type
+ constructor.
+
+ The possible variances are @racket[invariant], @racket[contravariant],
+ @racket[covariant], and @racket[irrelevant].
+
+ If @racket[#:arg-variances] is not specified, @racket[invariant] is used for
+ all positions.
+
+ Example:
+
+ @racketblock0[(define-type-constructor → #:arity >= 1
+ #:arg-variances
+ (λ (stx)
+ (syntax-parse stx
+ [(_ τ_in ... τ_out)
+ (append
+ (make-list (stx-length #'[τ_in ...]) contravariant)
+ (list covariant))])))]
+
The @racket[#:extra-info] argument is useful for attaching additional
metainformation to types, for example to implement pattern matching.}}
+ @item{
+ @defform[(define-binding-type name-id option ...)
+ #:grammar
+ ([option (code:line #:arity op n)
+ (code:line #:bvs op n)
+ (code:line #:arr kindcon)
+ (code:line #:arg-variances expr)
+ (code:line #:extra-info stx)])]{
+ Similar to @racket[define-type-constructor], except
+ @racket[define-binding-type] defines a type that binds type variables.
+ Defining a type constructor @racket[τ] defines:
+
+ The @racket[#:arity] and @racket[#:bvs] arguments specify the valid shapes
+ for the type. For example
+ @racket[(define-binding-type ∀ #:arity = 1 #:bvs = 1)] defines a type
+ with shape @racket[(∀ (X) τ)], where @racket[τ] may reference @racket[X].
+
+ The default @racket[#:arity] is @racket[= 1]
+ and the default @racket[#:bvs] is @racket[>= 0].
+
+ Use the @racket[#:arr] argument to define a type with kind annotations
+ on the type variables. The @racket[#:arr] argument is an "arrow" that "saves"
+ the annotations after a type is expanded and annotations are erased,
+ analogous to how → "saves" the type annotations on a lambda.}}
@item{
@defform[(type-out ty-id)]{
A @racket[provide]-spec that, given @racket[ty-id], provides @racket[ty-id],
@@ -182,7 +222,7 @@ equality, but includes alpha-equivalence.
(begin-for-syntax (displayln (type=? #'Int #'Int)))
(begin-for-syntax (displayln (type=? #'Int #'String)))
(define-type-constructor → #:arity > 0)
-(define-type-constructor ∀ #:arity = 1 #:bvs = 1)
+(define-binding-type ∀ #:arity = 1 #:bvs = 1)
(begin-for-syntax
(displayln
(type=? ((current-type-eval) #'(∀ (X) X))
@@ -327,6 +367,23 @@ Phase 1 function folding @racket[subst] over the given @racket[τs] and @racket[
@defform[(type-error #:src srx-stx #:msg msg args ...)]{
Phase 1 form that throws a type error using the specified information. @racket[msg] is a format string that references @racket[args].}
+@section{Subtyping}
+
+WARNING: very experimental
+
+Types defined with @racket[define-type-constructor] and
+@racket[define-binding-type] may specify variance information and subtyping
+languages may use this information to help compute the subtype relation.
+
+The possible variances are:
+@defthing[covariant variance?]
+@defthing[contravariant variance?]
+@defthing[invariant variance?]
+@defthing[irrelevant variance?]
+
+@defproc[(variance? [v any/c]) boolean/c]{
+ Predicate that recognizes the variance values.}
+
@section{Miscellaneous Syntax Object Functions}
These are all phase 1 functions.
