created fabUL-like langauge using lin + ext-stlc

closes #21

info.rkt

@@ -15,3 +15,4 @@
     "racket-doc"
     ))
 
+(define version "0.1")

macrotypes/examples/exist.rkt

@@ -67,8 +67,5 @@
      ;;
    #:with [e_packed- (~∃ (Y) τ_body)] (infer+erase #'e_packed)
    #:with τ_x (subst #'X #'Y #'τ_body)
-   #:with [(X-) (x-) (e-) (τ_e)]
-          (infer #'(e)
-                 #:tvctx #'([X : #%type])
-                 #:ctx   #`([x : τ_x]))
+   #:with [(_ x-) e- τ_e] (infer/ctx+erase #'(X [x : τ_x]) #'e)
    (⊢ (let- ([x- e_packed-]) e-) : τ_e)])

macrotypes/examples/fomega.rkt

@@ -1,50 +1,30 @@
 #lang s-exp macrotypes/typecheck
-(extends "sysf.rkt" #:except #%datum ∀ ~∀ ∀? Λ inst)
-(reuse String #%datum #:from "stlc+reco+var.rkt")
+(reuse λ #%app Int → + #:from "sysf.rkt")
+(reuse define-type-alias String #%datum #:from "stlc+reco+var.rkt")
 
 ;; System F_omega
-;; Type relation:
 ;; Types:
-;; - types from sysf.rkt
-;; - String from stlc+reco+var
+;; - redefine ∀
+;; - extend kind? and kind=? to include #%type
+;; - extend sysf with tyλ and tyapp
 ;; Terms:
-;; - extend ∀ Λ inst from sysf
-;; - add tyλ and tyapp
-;; - #%datum from stlc+reco+var
+;; - extend sysf with Λ inst
 
-(provide (for-syntax current-kind?)
-         define-type-alias
-         (type-out ★ ⇒ ∀★ ∀)
-         Λ inst tyλ tyapp)
+(provide (type-out ∀) (kind-out ★ ⇒ ∀★ ∀) Λ inst tyλ tyapp)
 
-(define-syntax-category kind)
+(define-syntax-category :: kind)
 
-; want #%type to be equiv to★
-; => edit current-kind? so existing #%type annotations (with no #%kind tag)
-;    are treated as kinds
-; <= define ★ as rename-transformer expanding to #%type
+;; want #%type to be equiv to ★
+;; => extend current-kind? to recognize #%type
+;; <= define ★ as rename-transformer expanding to #%type
 (begin-for-syntax
   (current-kind? (λ (k) (or (#%type? k) (kind? k))))
-  ;; Try to keep "type?" backward compatible with its uses so far,
-  ;; eg in the definition of λ or previous type constuctors.
-  ;; (However, this is not completely possible, eg define-type-alias)
-  ;; So now "type?" no longer validates types, rather it's a subset.
-  ;; But we no longer need type? to validate types, instead we can use 
-  ;; (kind? (typeof t))
-  (current-type? (λ (t)
-                   (define k (typeof t))
-                   #;(or (type? t) (★? (typeof t)) (∀★? (typeof t)))
-                   (and ((current-kind?) k) (not (⇒? k))))))
-
-; must override, to handle kinds
-(define-syntax define-type-alias
-  (syntax-parser
-    [(_ alias:id τ)
-     #:with (τ- k_τ) (infer+erase #'τ)
-     #:fail-unless ((current-kind?) #'k_τ)
-                   (format "not a valid type: ~a\n" (type->str #'τ))
-     #'(define-syntax alias 
-         (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))]))
+  ;; well-formed types, ie not types with ⇒ kind
+  (current-type? (λ (t) (define k (kindof t))
+                   (and k ((current-kind?) k) (not (⇒? k)))))
+  ;; any valid type (includes ⇒-kinded types)
+  (current-any-type? (λ (t) (define k (kindof t))
+                       (and k ((current-kind?) k)))))
 
 (begin-for-syntax
   (define ★? #%type?)
@@ -53,10 +33,10 @@
 (define-kind-constructor ⇒ #:arity >= 1)
 (define-kind-constructor ∀★ #:arity >= 0)
 
-(define-binding-type ∀ #:bvs >= 0 #:arr ∀★)
+(define-binding-type ∀ #:arr ∀★)
 
 ;; alternative: normalize before type=?
-; but then also need to normalize in current-promote
+;; but then also need to normalize in current-promote?
 (begin-for-syntax
   (define (normalize τ)
     (syntax-parse τ #:literals (#%plain-app #%plain-lambda)
@@ -83,44 +63,45 @@
   (define old-type=? (current-type=?))
   ; ty=? == syntax eq and syntax prop eq
   (define (type=? t1 t2)
-    (let ([k1 (typeof t1)][k2 (typeof t2)])
+    (let ([k1 (kindof t1)][k2 (kindof t2)])
       (and (or (and (not k1) (not k2))
-               (and k1 k2 ((current-type=?) k1 k2)))
+               (and k1 k2 ((current-kind=?) k1 k2)))
            (old-type=? t1 t2))))
-  (current-type=? type=?)
-  (current-typecheck-relation (current-type=?)))
+  (current-typecheck-relation type=?))
 
 (define-typed-syntax Λ
   [(_ bvs:kind-ctx e)
    #:with ((tv- ...) e- τ_e) (infer/ctx+erase #'bvs #'e)
-   (⊢ e- : (∀ ([tv- : bvs.kind] ...) τ_e))])
+   (⊢ e- : (∀ ([tv- :: bvs.kind] ...) τ_e))])
 
 (define-typed-syntax inst
-  [(_ e τ ...)
+  [(_ e τ:any-type ...)
    #:with [e- τ_e] (infer+erase #'e)
    #:with (~∀ (tv ...) τ_body) #'τ_e
-   #:with (~∀★ k ...) (typeof #'τ_e)
-   #:with ([τ- k_τ] ...) (infers+erase #'(τ ...))
-   #:fail-unless (typechecks? #'(k_τ ...) #'(k ...))
+   #:with (~∀★ k ...) (kindof #'τ_e)
+;   #:with ([τ- k_τ] ...) (infers+erase #'(τ ...) #:tag '::)
+   #:with (k_τ ...) (stx-map kindof #'(τ.norm ...))
+   #:fail-unless (kindchecks? #'(k_τ ...) #'(k ...))
                  (typecheck-fail-msg/multi 
                   #'(k ...) #'(k_τ ...) #'(τ ...))
-   #:with τ_inst (substs #'(τ- ...) #'(tv ...) #'τ_body)
+   #:with τ_inst (substs #'(τ.norm ...) #'(tv ...) #'τ_body)
    (⊢ e- : τ_inst)])
 
 ;; TODO: merge with regular λ and app?
 ;; - see fomega2.rkt
 (define-typed-syntax tyλ
   [(_ bvs:kind-ctx τ_body)
-   #:with (tvs- τ_body- k_body) (infer/ctx+erase #'bvs #'τ_body)
+   #:with (tvs- τ_body- k_body) (infer/ctx+erase #'bvs #'τ_body #:tag '::)
    #:fail-unless ((current-kind?) #'k_body)
                  (format "not a valid type: ~a\n" (type->str #'τ_body))
-   (⊢ (λ- tvs- τ_body-) : (⇒ bvs.kind ... k_body))])
+   (assign-kind #'(λ- tvs- τ_body-) #'(⇒ bvs.kind ... k_body))])
 
 (define-typed-syntax tyapp
   [(_ τ_fn τ_arg ...)
-   #:with [τ_fn- (k_in ... k_out)] (⇑ τ_fn as ⇒)
-   #:with ([τ_arg- k_arg] ...) (infers+erase #'(τ_arg ...))
-   #:fail-unless (typechecks? #'(k_arg ...) #'(k_in ...))
+;   #:with [τ_fn- (k_in ... k_out)] (⇑ τ_fn as ⇒)
+   #:with [τ_fn- (~⇒ k_in ... k_out)] (infer+erase #'τ_fn #:tag '::)
+   #:with ([τ_arg- k_arg] ...) (infers+erase #'(τ_arg ...) #:tag '::)
+   #:fail-unless (kindchecks? #'(k_arg ...) #'(k_in ...))
                  (string-append
                   (format 
                    "~a (~a:~a) Arguments to function ~a have wrong kinds(s), "
@@ -135,4 +116,4 @@
                   (format "Expected: ~a arguments with type(s): "
                           (stx-length #'(k_in ...)))
                   (string-join (stx-map type->str #'(k_in ...)) ", "))
-   (⊢ (#%app- τ_fn- τ_arg- ...) : k_out)])
+   (assign-kind #'(#%app- τ_fn- τ_arg- ...) #'k_out)])

macrotypes/examples/fomega2.rkt

@@ -1,8 +1,10 @@
 #lang s-exp macrotypes/typecheck
-(extends "sysf.rkt" #:except #%datum ∀ ~∀ ∀? Λ inst)
-(reuse String #%datum #:from "stlc+reco+var.rkt")
+(reuse Int + #:from "sysf.rkt")
+(require (prefix-in sysf: (only-in "sysf.rkt" →- → #%app λ))
+         (only-in "sysf.rkt" ~→ →?))
+(reuse define-type-alias String #%datum #:from "stlc+reco+var.rkt")
 
-; same as fomega.rkt except here λ and #%app works as both type and terms
+; same as fomega.rkt except λ and #%app works as both type and terms,
 ; - uses definition from stlc, but tweaks type? and kind? predicates
 ;; → is also both type and kind
 
@@ -15,36 +17,35 @@
 ;; - extend ∀ Λ inst from sysf
 ;; - #%datum from stlc+reco+var
 
-(provide define-type-alias
-         ★ ∀★ ∀
-         Λ inst)
+(provide (kind-out ★ ∀★) (type-out ∀) → λ #%app Λ inst
+         (for-syntax current-kind-eval kindcheck?))
 
-(define-syntax-category kind)
+(define-syntax-category :: kind)
 
+;; modify predicates to recognize → (function type) as both type and kind
 (begin-for-syntax
-  (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k)))))
-  ;; Try to keep "type?" backward compatible with its uses so far,
-  ;; eg in the definition of λ or previous type constuctors.
-  ;; (However, this is not completely possible, eg define-type-alias)
-  ;; So now "type?" no longer validates types, rather it's a subset.
-  ;; But we no longer need type? to validate types, instead we can use
-  ;;(kind? (typeof t))
-  (current-type? (λ (t) (or (type? t)
-                            (let ([k (typeof t)])
-                              (or (★? k) (∀★? k)))
-                            ((current-kind?) t)))))
+  (define old-kind? (current-kind?))
+  (current-kind? (λ (k) (or (#%type? k) (old-kind? k))))
 
-; must override
-(define-syntax define-type-alias
-  (syntax-parser
-    [(_ alias:id τ)
-     #:with (τ- k_τ) (infer+erase #'τ)
-     #'(define-syntax alias
-         (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))]))
+  ;; well-formed types, eg not types with kind →
+  ;; must allow kinds as types, for →
+  (current-type? (λ (t) (define k (kindof t))
+                    (and k ((current-kind?) k) (not (→? k)))))
+
+  ;; o.w., a valid type is one with any valid kind
+  (current-any-type? (λ (t) (define k (kindof t))
+                        (and k ((current-kind?) k)))))
+
+;; extend → to serve as both type and kind
+(define-syntax (→ stx)
+  (syntax-parse stx
+    [(_ k:kind ...)                ; kind
+     (add-orig (mk-kind #'(sysf:→- k.norm ...)) stx)]
+    [(_ . tys) #'(sysf:→ . tys)])) ; type
 
 (define-base-kind ★)
 (define-kind-constructor ∀★ #:arity >= 0)
-(define-binding-type ∀ #:bvs >= 0 #:arr ∀★)
+(define-binding-type ∀ #:arr ∀★)
 
 ;; alternative: normalize before type=?
 ; but then also need to normalize in current-promote
@@ -70,32 +71,69 @@
   (define (type-eval τ) (normalize (old-eval τ)))
   (current-type-eval type-eval)
   
-  (define old-type=? (current-type=?))
-  (define (type=? t1 t2)
-    (or (and (★? t1) (#%type? t2))
-        (and (#%type? t1) (★? t2))
-        (and (syntax-parse (list t1 t2) #:datum-literals (:)
-               [((~∀ ([tv1 : k1]) tbody1)
-                 (~∀ ([tv2 : k2]) tbody2))
-                ((current-type=?) #'k1 #'k2)]
-               [_ #t])
-             (old-type=? t1 t2))))
-  (current-type=? type=?)
-  (current-typecheck-relation (current-type=?)))
+  (define old-typecheck? (current-typecheck-relation))
+  (define (new-typecheck? t1 t2)
+    (and (kindcheck? (kindof t1) (kindof t2))
+         (old-typecheck? t1 t2)))
+  (current-typecheck-relation new-typecheck?)
+
+  ;; must be kind= (and not kindcheck?) since old-kind=? recurs on curr-kind=
+  (define old-kind=? (current-kind=?))
+  (define (new-kind=? k1 k2)
+    (or (and (★? k1) (#%type? k2))
+        (and (#%type? k1) (★? k2))
+        (old-kind=? k1 k2)))
+  (current-kind=? new-kind=?)
+  (current-kindcheck-relation new-kind=?))
 
 (define-typed-syntax Λ
   [(_ bvs:kind-ctx e)
-   #:with ((tv- ...) e- τ_e)
-          (infer/ctx+erase #'bvs #'e)
-   (⊢ e- : (∀ ([tv- : bvs.kind] ...) τ_e))])
+   #:with ((tv- ...) e- τ_e) (infer/ctx+erase #'bvs #'e)
+   (⊢ e- : (∀ ([tv- :: bvs.kind] ...) τ_e))])
 
 (define-typed-syntax inst
-  [(_ e τ ...)
-   #:with (e- (([tv k] ...) (τ_body))) (⇑ e as ∀)
-   #:with ([τ- k_τ] ...) (infers+erase #'(τ ...))
-   #:when (stx-andmap 
-           (λ (t k) (or ((current-kind?) k)
-                        (type-error #:src t #:msg "not a valid type: ~a" t)))
-           #'(τ ...) #'(k_τ ...))
-   #:when (typechecks? #'(k_τ ...) #'(k ...))
-   (⊢ e- : #,(substs #'(τ- ...) #'(tv ...) #'τ_body))])
+  [(_ e τ:any-type ...)
+;   #:with (e- (([tv k] ...) (τ_body))) (⇑ e as ∀)
+   #:with [e- τ_e] (infer+erase #'e)
+   #:with (~∀ (tv ...) τ_body) #'τ_e
+   #:with (~∀★ k ...) (kindof #'τ_e)
+;   #:with ([τ- k_τ] ...) (infers+erase #'(τ ...))
+   #:with (k_τ ...) (stx-map kindof #'(τ.norm ...))
+   #:fail-unless (kindchecks? #'(k_τ ...) #'(k ...))
+                 (typecheck-fail-msg/multi 
+                  #'(k ...) #'(k_τ ...) #'(τ ...))
+   #:with τ_inst (substs #'(τ.norm ...) #'(tv ...) #'τ_body)
+   (⊢ e- : τ_inst)])
+
+;; extend λ to also work as a type
+(define-typed-syntax λ
+  [(_ bvs:kind-ctx τ)           ; type
+   #:with (Xs- τ- k_res) (infer/ctx+erase #'bvs #'τ #:tag '::)
+   (assign-kind #'(λ- Xs- τ-) #'(→ bvs.kind ... k_res))]
+  [(_ . rst) #'(sysf:λ . rst)]) ; term
+
+;; extend #%app to also work as a type
+(define-typed-syntax #%app
+  [(_ τ_fn τ_arg ...) ; type
+;   #:with [τ_fn- (k_in ... k_out)] (⇑ τ_fn as ⇒)
+   #:with [τ_fn- k_fn] (infer+erase #'τ_fn #:tag '::)
+   #:when (syntax-e #'k_fn) ; non-false
+   #:with (~→ k_in ... k_out ~!) #'k_fn
+   #:with ([τ_arg- k_arg] ...) (infers+erase #'(τ_arg ...) #:tag '::)
+   #:fail-unless (kindchecks? #'(k_arg ...) #'(k_in ...))
+                 (string-append
+                  (format 
+                   "~a (~a:~a) Arguments to function ~a have wrong kinds(s), "
+                   (syntax-source stx) (syntax-line stx) (syntax-column stx)
+                   (syntax->datum #'τ_fn))
+                  "or wrong number of arguments:\nGiven:\n"
+                  (string-join
+                   (map (λ (e t) (format "  ~a : ~a" e t)) ; indent each line
+                        (syntax->datum #'(τ_arg ...))
+                        (stx-map type->str #'(k_arg ...)))
+                   "\n" #:after-last "\n")
+                  (format "Expected: ~a arguments with type(s): "
+                          (stx-length #'(k_in ...)))
+                  (string-join (stx-map type->str #'(k_in ...)) ", "))
+   (assign-kind #'(#%app- τ_fn- τ_arg- ...) #'k_out)]
+  [(_ . rst) #'(sysf:#%app . rst)]) ; term

macrotypes/examples/fomega3.rkt

@@ -1,6 +1,8 @@
 #lang s-exp macrotypes/typecheck
 (extends "fomega.rkt" #:except tyapp tyλ)
 
+;; NOTE 2017-02-03: currently not working
+
 ; same as fomega2.rkt --- λ and #%app works as both regular and type versions,
 ; → is both type and kind --- but reuses parts of fomega.rkt,
 ; ie removes the duplication in fomega2.rkt

macrotypes/examples/fsub.rkt

@@ -26,7 +26,7 @@
 (begin-for-syntax
   (define (expose t)
     (cond [(identifier? t)
-           (define sub (typeof t #:tag '<:))
+           (define sub (detach t '<:))
            (if sub (expose sub) t)]
           [else t]))
   (current-promote expose)
@@ -75,14 +75,13 @@
                        #:msg "Expected ∀ type, got: ~a" #'any))))]))))
 
 (define-typed-syntax Λ #:datum-literals (<:)
-  [(_ ([tv:id <: τsub:type] ...) e)
+  [(_ ([X:id <: τsub:type] ...) e)
    ;; NOTE: store the subtyping relation of tv and τsub in another
    ;; "environment", ie, a syntax property with another tag: '<:
    ;; The "expose" function looks for this tag to enforce the bound,
    ;; as in TaPL (fig 28-1)
-   #:with ((tv- ...) _ (e-) (τ_e))
-          (infer #'(e) #:tvctx #'([tv : #%type <: τsub] ...))
-   (⊢ e- : (∀ ([tv- <: τsub] ...) τ_e))])
+   #:with ((X- ...) e- τ_e) (infer/ctx #'([X :: #%type <: τsub] ...) #'e)
+   (⊢ e- : (∀ ([X- <: τsub] ...) τ_e))])
 (define-typed-syntax inst
   [(_ e τ:type ...)
    #:with (e- (([tv τ_sub] ...) τ_body)) (⇑ e as ∀)

macrotypes/examples/infer.rkt

@@ -51,7 +51,7 @@
                                (for/fold ([tv-id #'tv])
                                          ([s (in-list (list 'sep ...))]
                                           [k (in-list (list #'tvk ...))])
-                                 (assign-type tv-id k #:tag s))
+                                 (attach tv-id s k))
                                'tyvar #t))] ...)
               (λ- (x ...)
                 (let-syntax 

macrotypes/examples/mlish+adhoc.rkt

@@ -1,7 +1,8 @@
 #lang s-exp "../typecheck.rkt"
 (require (only-in "../typecheck.rkt"
                   [define-typed-syntax def-typed-stx/no-provide]))
-(require racket/fixnum racket/flonum)
+(require (postfix-in - racket/fixnum)
+         (postfix-in - racket/flonum))
 
 (extends
  "ext-stlc.rkt"
@@ -383,7 +384,7 @@
                            (format "Improper use of constructor ~a; expected ~a args, got ~a"
                                    (syntax->datum #'Name) (stx-length #'(X ...))
                                    (stx-length (stx-cdr #'stx))))])]
-                       [X (make-rename-transformer (⊢ X #%type))] ...)
+                       [X (make-rename-transformer (mk-type #'X))] ...)
                       (void ty_flat ...)))))
      #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...)))
                 (stx-map 
@@ -854,7 +855,7 @@
            (expand/df
             #'(lambda (X ...) 
                 (let-syntax 
-                 ([X (make-rename-transformer (assign-type #'X #'#%type))] ...)
+                 ([X (make-rename-transformer (mk-type #'X))] ...)
                  (let-syntax
                   ;; must have this inner macro bc body of lambda may require
                   ;; ops defined by TC to be bound
@@ -1670,7 +1671,7 @@
               (~=> TCsub ... 
                    (~TC [generic-op-expected ty-concrete-op-expected] ...)))
              _)
-            (infers/tyctx+erase #'([X : #%type] ...) #'(TC ... (Name ty ...)))
+            (infers/tyctx+erase #'([X :: #%type] ...) #'(TC ... (Name ty ...)))
      #:when (TCs-exist? #'(TCsub ...) #:ctx stx)
      ;; simulate as if the declared concrete-op* has TC ... predicates
      ;; TODO: fix this manual deconstruction and assembly

macrotypes/examples/mlish.rkt

@@ -1,6 +1,7 @@
 #lang s-exp macrotypes/typecheck
 (require
- racket/fixnum racket/flonum
+ (postfix-in - racket/fixnum)
+ (postfix-in - racket/flonum)
  (for-syntax macrotypes/type-constraints macrotypes/variance-constraints))
 
 (extends
@@ -447,7 +448,7 @@
                            (format "Improper use of constructor ~a; expected ~a args, got ~a"
                                    (syntax->datum #'Name) (stx-length #'(X ...))
                                    (stx-length (stx-cdr #'stx))))])]
-                       [X (make-rename-transformer (⊢ X #%type))] ...)
+                       [X (make-rename-transformer (mk-type #'X))] ...)
                       (void ty_flat ...)))))
      #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...)))
                 (stx-map 

macrotypes/examples/stlc+overloading.rkt

@@ -106,7 +106,7 @@
 
 (define-typed-syntax signature
   [(_ (name:id α:id) τ)
-   #:with ((α+) (~→ τ_α:id τ-cod) _) (infer/tyctx+erase #'([α : #%type]) #'τ)
+   #:with ((α+) (~→ τ_α:id τ-cod) _) (infer/tyctx+erase #'([α :: #%type]) #'τ)
    (define ℜ (ℜ-init #'name #'τ-cod))
    (⊢ (define-syntax name
         (syntax-parser

macrotypes/examples/sysf.rkt

@@ -15,11 +15,10 @@
 
 (define-typed-syntax Λ
   [(_ (tv:id ...) e)
-   #:with [(tv- ...) e- τ] (infer/tyctx+erase #'([tv : #%type] ...) #'e)
-   (⊢ e- : (∀ (tv- ...) τ))])
+   #:with [tvs- e- τ-] (infer/ctx #'(tv ...) #'e)
+   (⊢ e- : (∀ tvs- τ-))])
 (define-typed-syntax inst
   [(_ e τ:type ...)
    #:with [e- (~∀ tvs τ_body)] (infer+erase #'e)
-   #:with τ_inst (substs #'(τ.norm ...) #'tvs #'τ_body)
-   (⊢ e- : τ_inst)]
+   (⊢ e- : #,(substs #'(τ.norm ...) #'tvs #'τ_body))]
   [(_ e) #'e])

macrotypes/examples/tests/ext-stlc-tests.rkt

@@ -52,8 +52,8 @@
 (typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier")
 (typecheck-fail (ann 1 : 1) #:with-msg "not a well-formed type")
 (typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a well-formed type")
-(typecheck-fail (ann Int : Int)
-                #:with-msg "ann: type mismatch: expected Int, given #%type\n *expression: Int")
+(typecheck-fail (ann Bool : Int)
+                #:with-msg "ann: type mismatch: expected Int, given an invalid expression\n *expression: Bool")
 
 ; let
 (check-type (let () (+ 1 1)) : Int ⇒ 2)

macrotypes/examples/tests/fomega-tests.rkt

@@ -1,82 +1,86 @@
 #lang s-exp "../fomega.rkt"
 (require "rackunit-typechecking.rkt")
 
-(check-type Int : ★)
-(check-type String : ★)
+(check-type Int :: ★)
+(check-type String :: ★)
 (typecheck-fail →)
-(check-type (→ Int Int) : ★)
+(check-type (→ Int Int) :: ★)
 (typecheck-fail (→ →))
 (typecheck-fail (→ 1))
 (check-type 1 : Int)
 
-(typecheck-fail (tyλ ([x : ★]) 1) #:with-msg "not a valid type: 1")
+(typecheck-fail (tyλ ([x :: ★]) 1) #:with-msg "not a valid type: 1")
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
-(check-not-type (Λ ([X : ★]) (λ ([x : X]) x)) :
-                (∀ ([X : (∀★ ★)]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
+(check-not-type (Λ ([X :: ★]) (λ ([x : X]) x)) :
+                (∀ ([X :: (∀★ ★)]) (→ X X)))
 
 ;(check-type (∀ ([t : ★]) (→ t t)) : ★)
-(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★))
-(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★)
+(check-type (∀ ([t :: ★]) (→ t t)) :: (∀★ ★))
+(check-type (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)) :: ★)
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x)))
-            : (∀ ([X : ★]) (→ X X)))
-(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x))))
+(check-type ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x)
+             (Λ ([X :: ★]) (λ ([x : X]) x)))
+            : (∀ ([X :: ★]) (→ X X)))
+(typecheck-fail ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) 
+                 (Λ ([X :: (⇒ ★ ★)]) (λ ([x : X]) x))))
 
-(check-type (tyλ ([t : ★]) t) : (⇒ ★ ★))
-(check-type (tyλ ([t : ★] [s : ★]) t) : (⇒ ★ ★ ★))
-(check-type (tyλ ([t : ★]) (tyλ ([s : ★]) t)) : (⇒ ★ (⇒ ★ ★)))
-(check-type (tyλ ([t : (⇒ ★ ★)]) t) : (⇒ (⇒ ★ ★) (⇒ ★ ★)))
-(check-type (tyλ ([t : (⇒ ★ ★ ★)]) t) : (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★)))
-(check-type (tyλ ([arg : ★] [res : ★]) (→ arg res)) : (⇒ ★ ★ ★))
+(check-type (tyλ ([t :: ★]) t) :: (⇒ ★ ★))
+(check-type (tyλ ([t :: ★] [s :: ★]) t) :: (⇒ ★ ★ ★))
+(check-type (tyλ ([t :: ★]) (tyλ ([s :: ★]) t)) :: (⇒ ★ (⇒ ★ ★)))
+(check-type (tyλ ([t :: (⇒ ★ ★)]) t) :: (⇒ (⇒ ★ ★) (⇒ ★ ★)))
+(check-type (tyλ ([t :: (⇒ ★ ★ ★)]) t) :: (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★)))
+(check-type (tyλ ([arg :: ★] [res :: ★]) (→ arg res)) :: (⇒ ★ ★ ★))
 
-(check-type (tyapp (tyλ ([t : ★]) t) Int) : ★)
-(check-type (λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) : (→ Int Int))
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1)
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
-(typecheck-fail ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) "a-string"))
+(check-type (tyapp (tyλ ([t :: ★]) t) Int) :: ★)
+(check-type (λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) x) : (→ Int Int))
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) x) 1) : Int ⇒ 1)
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
+(typecheck-fail ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ 1 x)) "a-string"))
 
 ;; partial-apply →
-(check-type (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)
-            : (⇒ ★ ★))
+(check-type (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int)
+            :: (⇒ ★ ★))
 ;; f's type must have kind ★
-(typecheck-fail (λ ([f : (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)]) f))
-(check-type (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) :
-            (∀ ([tyf : (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String))))
+(typecheck-fail (λ ([f :: (tyapp (tyλ([arg : ★]) (tyλ([res :: ★]) (→ arg res)))
+                                 Int)])
+                  f))
+(check-type (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) :
+            (∀ ([tyf :: (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String))))
 (check-type (inst
-             (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-             (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+             (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+             (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
             : (→ (→ Int String) (→ Int String)))
 (typecheck-fail
- (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)
- #:with-msg "inst: type mismatch\n *expected: +★\n *given: +Int\n *expressions: 1")
+ (inst (Λ ([X :: ★]) (λ ([x : X]) x)) 1)
+ #:with-msg "inst:.*not a valid type: 1")
 
 (typecheck-fail
- (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+ (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
  #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
 ;; applied f too early
 (typecheck-fail
  (inst
-  (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
-  (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+  (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+  (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
  #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
 (check-type ((inst
-              (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+              (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
              (λ ([x : Int]) "int")) : (→ Int String))
 (check-type (((inst
-               (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+               (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
               (λ ([x : Int]) "int")) 1) : String ⇒ "int")
 
 ;; tapl examples, p441
 (typecheck-fail
  (define-type-alias tmp 1)
  #:with-msg "not a valid type: 1")
-(define-type-alias Id (tyλ ([X : ★]) X))
+(define-type-alias Id (tyλ ([X :: ★]) X))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (tyapp Id String)) Int))
 (check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int String) Int))
@@ -89,104 +93,125 @@
 (check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (tyapp Id (→ Int String))) Int))
 
 ;; tapl examples, p451
-(define-type-alias Pair (tyλ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X))))
+(define-type-alias Pair (tyλ ([A :: ★] [B :: ★]) (∀ ([X :: ★]) (→ (→ A B X) X))))
 
 ;(check-type Pair : (⇒ ★ ★ ★))
-(check-type Pair : (⇒ ★ ★ (∀★ ★)))
+(check-type Pair :: (⇒ ★ ★ (∀★ ★)))
 
-(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X)))
+(check-type (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) x)) 
+            : (∀ ([X :: ★][Y :: ★]) (→ X Y X)))
 ; parametric pair constructor
 (check-type
- (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
- : (∀ ([X : ★][Y : ★]) (→ X Y (tyapp Pair X Y))))
+ (Λ ([X :: ★] [Y :: ★]) 
+    (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ : (∀ ([X :: ★][Y :: ★]) (→ X Y (tyapp Pair X Y))))
 ; concrete Pair Int String constructor
 (check-type
- (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ (inst (Λ ([X :: ★] [Y :: ★]) 
+          (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String)
  : (→ Int String (tyapp Pair Int String)))
 ;; Pair Int String value
 (check-type
- ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ ((inst (Λ ([X :: ★] [Y :: ★])
+           (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String) 1 "1")
  : (tyapp Pair Int String))
 ;; fst: parametric
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
- : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) X)))
+ (Λ ([X :: ★][Y :: ★])
+    (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))])
+      ((inst p X) (λ ([x : X][y : Y]) x))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (tyapp Pair X Y) X)))
 ;; fst: concrete Pair Int String accessor
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+  (Λ ([X :: ★][Y :: ★])
+     (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))])
+       ((inst p X) (λ ([x : X][y : Y]) x))))
   Int String)
  : (→ (tyapp Pair Int String) Int))
 ;; apply fst
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+   (Λ ([X :: ★][Y :: ★])
+      (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))])
+        ((inst p X) (λ ([x : X][y : Y]) x))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★])
+            (λ ([x : X] [y : Y])
+              (Λ ([R :: ★])
+                 (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : Int ⇒ 1)
 ;; snd
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
- : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) Y)))
+ (Λ ([X :: ★][Y :: ★])
+    (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))])
+      ((inst p Y) (λ ([x : X][y : Y]) y))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (tyapp Pair X Y) Y)))
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+  (Λ ([X :: ★][Y :: ★])
+     (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))])
+       ((inst p Y) (λ ([x : X][y : Y]) y))))
   Int String)
  : (→ (tyapp Pair Int String) String))
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+   (Λ ([X :: ★][Y :: ★])
+      (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))])
+        ((inst p Y) (λ ([x : X][y : Y]) y))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★])
+            (λ ([x : X][y : Y])
+              (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : String ⇒ "1")
 
 ;; sysf tests wont work, unless augmented with kinds
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X :: ★]) (→ X X X))) ; true
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X :: ★]) (→ X X X))) ; false
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y :: ★]) (→ Y Y Y))) ; false, alpha equiv
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t1 :: ★]) (∀ ([t2 :: ★]) (→ t1 (→ t2 t2)))))
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t3 :: ★]) (∀ ([t4 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4)))))
+(check-not-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t4 :: ★]) (∀ ([t3 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
-(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int)
+(check-type (inst (Λ ([t :: ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
+(check-type (inst (Λ ([t :: ★]) 1) (→ Int Int)) : Int)
 ; first inst should be discarded
-(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
+(check-type (inst (inst (Λ ([t :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
 ; second inst is discarded
-(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
+(check-type (inst (inst (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
 
 ;; polymorphic arguments
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t)))
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s)))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u))))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u))))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([t :: ★]) (→ t t)))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([s :: ★]) (→ s s)))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([s :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([s :: ★]) (→ s s))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([u :: ★]) (→ u u))))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) x) : (→ (∀ ([s :: ★]) (→ s s)) (∀ ([u :: ★]) (→ u u))))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x)))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u)))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) : (∀ ([u :: ★]) (→ u u)))
 (check-type
- (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
+ (inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
 (check-type
- ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10)
+ ((inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) 10)
  : Int ⇒ 10)
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10))
-             (Λ ([s : ★]) (λ ([y : s]) y)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t :: ★]) (→ t t)) Int))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10))
+             (Λ ([s :: ★]) (λ ([y : s]) y)))
              : Int ⇒ 10)
 
 

macrotypes/examples/tests/fomega2-tests.rkt

@@ -1,10 +1,11 @@
 #lang s-exp "../fomega2.rkt"
 (require "rackunit-typechecking.rkt")
+(require "rackunit-kindchecking.rkt")
 
-(check-type Int : ★)
-(check-type String : ★)
+(check-kind Int :: ★)
+(check-kind String :: ★)
 (typecheck-fail →)
-(check-type (→ Int Int) : ★)
+(check-kind (→ Int Int) :: ★)
 (typecheck-fail (→ →))
 (typecheck-fail (→ 1))
 (check-type 1 : Int)
@@ -12,63 +13,64 @@
 ;; this should error but it doesnt
 #;(λ ([x : ★]) 1)
 
-;(check-type (∀ ([t : ★]) (→ t t)) : ★)
-(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★))
-(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★)
+;(check-kind (∀ ([t :: ★]) (→ t t)) :: ★)
+(check-kind (∀ ([t :: ★]) (→ t t)) :: (∀★ ★))
+(check-kind (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)) :: ★)
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x)))
-            : (∀ ([X : ★]) (→ X X)))
-(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (→ ★ ★)]) (λ ([x : X]) x))))
+(check-type ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X :: ★]) (λ ([x : X]) x)))
+            : (∀ ([X :: ★]) (→ X X)))
+(typecheck-fail ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X :: (→ ★ ★)]) (λ ([x : X]) x))))
 
-(check-type (λ ([t : ★]) t) : (→ ★ ★))
-(check-type (λ ([t : ★] [s : ★]) t) : (→ ★ ★ ★))
-(check-type (λ ([t : ★]) (λ ([s : ★]) t)) : (→ ★ (→ ★ ★)))
-(check-type (λ ([t : (→ ★ ★)]) t) : (→ (→ ★ ★) (→ ★ ★)))
-(check-type (λ ([t : (→ ★ ★ ★)]) t) : (→ (→ ★ ★ ★) (→ ★ ★ ★)))
-(check-type (λ ([arg : ★] [res : ★]) (→ arg res)) : (→ ★ ★ ★))
+;; λ as a type
+(check-kind (λ ([t :: ★]) t) :: (→ ★ ★))
+(check-kind (λ ([t :: ★] [s :: ★]) t) :: (→ ★ ★ ★))
+(check-kind (λ ([t :: ★]) (λ ([s :: ★]) t)) :: (→ ★ (→ ★ ★)))
+(check-kind (λ ([t :: (→ ★ ★)]) t) :: (→ (→ ★ ★) (→ ★ ★)))
+(check-kind (λ ([t :: (→ ★ ★ ★)]) t) :: (→ (→ ★ ★ ★) (→ ★ ★ ★)))
+(check-kind (λ ([arg :: ★] [res :: ★]) (→ arg res)) :: (→ ★ ★ ★))
 
-(check-type ((λ ([t : ★]) t) Int) : ★)
-(check-type (λ ([x : ((λ ([t : ★]) t) Int)]) x) : (→ Int Int))
-(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1)
-(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
-(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
-(typecheck-fail ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) "a-string"))
+(check-kind ((λ ([t :: ★]) t) Int) :: ★)
+(check-type (λ ([x : ((λ ([t :: ★]) t) Int)]) x) : (→ Int Int))
+(check-type ((λ ([x : ((λ ([t :: ★]) t) Int)]) x) 1) : Int ⇒ 1)
+(check-type ((λ ([x : ((λ ([t :: ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
+(check-type ((λ ([x : ((λ ([t :: ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
+(typecheck-fail ((λ ([x : ((λ ([t :: ★]) t) Int)]) (+ 1 x)) "a-string"))
 
 ;; partial-apply →
-(check-type ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)
-            : (→ ★ ★))
+(check-kind ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int)
+            :: (→ ★ ★))
 ; f's type must have kind ★
-(typecheck-fail (λ ([f : ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)]) f))
-(check-type (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) :
-            (∀ ([tyf : (→ ★ ★)]) (→ (tyf String) (tyf String))))
+(typecheck-fail (λ ([f : ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int)]) f))
+(check-type (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f)) :
+            (∀ ([tyf :: (→ ★ ★)]) (→ (tyf String) (tyf String))))
 (check-type (inst
-             (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f))
-             ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))
+             (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f))
+             ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int))
             : (→ (→ Int String) (→ Int String)))
 (typecheck-fail
- (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1))
+ (inst (Λ ([X :: ★]) (λ ([x :: X]) x)) 1))
  ;#:with-msg "not a valid type: 1")
 
 ;; applied f too early
 (typecheck-fail (inst
-                 (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1)))
-                 ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)))
+                 (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1)))
+                 ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int)))
 (check-type ((inst
-              (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f))
-              ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))
+              (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f))
+              ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int))
              (λ ([x : Int]) "int")) : (→ Int String))
 (check-type (((inst
-               (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f))
-              ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))
+               (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f))
+              ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int))
               (λ ([x : Int]) "int")) 1) : String ⇒ "int")
 
 ;; tapl examples, p441
 (typecheck-fail
  (define-type-alias tmp 1))
  ;#:with-msg "not a valid type: 1")
-(define-type-alias Id (λ ([X : ★]) X))
+(define-type-alias Id (λ ([X :: ★]) X))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (Id String)) Int))
 (check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int String) Int))
@@ -81,104 +83,105 @@
 (check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (Id (→ Int String))) Int))
 
 ;; tapl examples, p451
-(define-type-alias Pair (λ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X))))
+(define-type-alias Pair (λ ([A :: ★] [B :: ★]) (∀ ([X :: ★]) (→ (→ A B X) X))))
 
 ;(check-type Pair : (→ ★ ★ ★))
-(check-type Pair : (→ ★ ★ (∀★ ★)))
+(check-kind Pair :: (→ ★ ★ (∀★ ★)))
 
-(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X)))
+(check-type (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) x))
+            : (∀ ([X :: ★][Y :: ★]) (→ X Y X)))
 ; parametric pair constructor
 (check-type
- (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
- : (∀ ([X : ★][Y : ★]) (→ X Y (Pair X Y))))
+ (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ : (∀ ([X :: ★][Y :: ★]) (→ X Y (Pair X Y))))
 ; concrete Pair Int String constructor
 (check-type
- (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ (inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String)
  : (→ Int String (Pair Int String)))
 ; Pair Int String value
 (check-type
- ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String) 1 "1")
  : (Pair Int String))
 ; fst: parametric
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
- : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) X)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (Pair X Y) X)))
 ; fst: concrete Pair Int String accessor
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
   Int String)
  : (→ (Pair Int String) Int))
 ; apply fst
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : Int ⇒ 1)
 ; snd
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
- : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) Y)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (Pair X Y) Y)))
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
   Int String)
  : (→ (Pair Int String) String))
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : String ⇒ "1")
 
 ;;; sysf tests wont work, unless augmented with kinds
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X :: ★]) (→ X X X))) ; true
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X :: ★]) (→ X X X))) ; false
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y :: ★]) (→ Y Y Y))) ; false, alpha equiv
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t1 :: ★]) (∀ ([t2 :: ★]) (→ t1 (→ t2 t2)))))
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t3 :: ★]) (∀ ([t4 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4)))))
+(check-not-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t4 :: ★]) (∀ ([t3 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
-(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int)
+(check-type (inst (Λ ([t :: ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
+(check-type (inst (Λ ([t :: ★]) 1) (→ Int Int)) : Int)
 ; first inst should be discarded
-(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
+(check-type (inst (inst (Λ ([t :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
 ; second inst is discarded
-(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
+(check-type (inst (inst (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
 
 ;; polymorphic arguments
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t)))
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s)))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u))))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u))))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([t :: ★]) (→ t t)))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([s :: ★]) (→ s s)))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([s :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([s :: ★]) (→ s s))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([u :: ★]) (→ u u))))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) x) : (→ (∀ ([s :: ★]) (→ s s)) (∀ ([u :: ★]) (→ u u))))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x)))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u)))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) : (∀ ([u :: ★]) (→ u u)))
 (check-type
- (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
+ (inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
 (check-type
- ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10)
+ ((inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) 10)
  : Int ⇒ 10)
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10))
-             (Λ ([s : ★]) (λ ([y : s]) y)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t :: ★]) (→ t t)) Int))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10))
+             (Λ ([s :: ★]) (λ ([y : s]) y)))
              : Int ⇒ 10)
 
 

macrotypes/examples/tests/general-tests.rkt

@@ -15,9 +15,9 @@
   (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)
+  (define-binding-type exist #:arr void #:bvs = 1 #:arity = 1)
+  (define-binding-type exist2 #:bvs = 1 #:arity = 1 #:arr void)
+  (define-binding-type exist3 #:bvs = 1 #:arr void #:arity = 1)
   
   (check-stx-err
    (define-binding-type exist4 #:bvs = 1 #:no-attach- #:arity = 1)
@@ -32,5 +32,11 @@
    #: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?
+   #:with-msg "too many occurrences of #:bvs keyword")
+  (check-stx-err
+   (define-binding-type exist6 #:arity = 1 #:arity = 1)
+   #:with-msg "too many occurrences of #:arity keyword")
+  (check-stx-err
+   (define-binding-type exist6 #:arr void #:arr void)
+   #:with-msg "too many occurrences of #:arr keyword")
 )

macrotypes/examples/tests/infer-tests.rkt

@@ -246,7 +246,7 @@
 (typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier")
 (typecheck-fail (ann 1 : 1) #:with-msg "not a well-formed type")
 (typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a well-formed type")
-(typecheck-fail (ann Int : Int) #:with-msg "expected Int, given #%type\n *expression: Int")
+(typecheck-fail (ann Bool : Int) #:with-msg "expected Int, given an invalid expression\n *expression: Bool")
 
 ; let
 (check-type (let () (+ 1 1)) : Int ⇒ 2)

macrotypes/examples/tests/mlish-tests.rkt

@@ -64,6 +64,8 @@
 (check-type (g2 Nil) : (List (List Int)) ⇒ Nil)
 (check-type (g2 Nil) : (List (→ Int Int)) ⇒ Nil)
 
+(check-type (λ ([x : (List Int)]) x) : (→/test (List Int) (List Int)))
+
 (check-type (g2 (Cons 1 Nil)) : (List Int) ⇒ (Cons 1 Nil))
 (check-type (g2 (Cons "1" Nil)) : (List String) ⇒ (Cons "1" Nil))
 
@@ -675,7 +677,7 @@
 (typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier")
 (typecheck-fail (ann 1 : 1) #:with-msg "not a well-formed type")
 (typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a well-formed type")
-(typecheck-fail (ann Int : Int) #:with-msg "expected Int, given #%type\n *expression: Int")
+(typecheck-fail (ann Int : Int) #:with-msg "expected Int, given an invalid expression\n *expression: Int")
 
 ; let
 (check-type (let () (+ 1 1)) : Int ⇒ 2)

macrotypes/examples/tests/mlish/chameneos.mlish

@@ -118,9 +118,16 @@
   ;;          (list 66 0)
   ;;          (list 67 0)))
 
-(check-type (map (λ ([x : Result]) (proj x 0))
-                 (go 1000 (list Blue Red Yellow Red Yellow Blue)))
-  : (List Int) -> (list 333 333 333 333 334 334))
+(define res2 
+  (map (λ ([x : Result]) (proj x 0))
+       (go 1000 (list Blue Red Yellow Red Yellow Blue))))
+(check-type res2 : (List Int))
+(define (=333/4 [x : Int] -> Bool) (or (= x 333) (= x 334)))
+(define (andmap [p? : (→ X Bool)] [xs : (List X)] → Bool)
+  (match2 xs with
+   [nil -> #t]
+   [x :: rst -> (and (p? x) (andmap p? rst))]))         
+(check-type (andmap =333/4 res2) : Bool -> #t)
   ;; -> (list (list 333 0)
   ;;          (list 333 0)
   ;;          (list 333 0)

macrotypes/examples/tests/rackunit-kindchecking.rkt

@@ -0,0 +1,16 @@
+#lang racket/base
+(require (for-syntax rackunit syntax/srcloc) rackunit macrotypes/typecheck
+         (only-in "../fomega2.rkt" current-kind-eval kindcheck?))
+(provide check-kind)
+
+(define-syntax (check-kind stx)
+  (syntax-parse stx #:datum-literals (⇒ ->)
+    [(_ τ tag:id k-expected)
+     #:with k (detach (expand/df #'(add-expected τ k-expected))
+                      (stx->datum #'tag))
+     #:fail-unless (kindcheck? #'k ((current-kind-eval) #'k-expected))
+                   (format
+                    "Type ~a [loc ~a:~a] has kind ~a, expected ~a"
+                    (syntax->datum #'τ) (syntax-line #'τ) (syntax-column #'τ)
+                    (type->str #'k) (type->str #'k-expected))
+     #'(void)]))

macrotypes/info.rkt

@@ -1,14 +1,17 @@
 #lang info
 
 (define compile-omit-paths 
-  '("examples/tests"))
+  '("examples/fomega3.rkt"
+    "examples/tests"))
 
 (define test-include-paths
   '("examples/tests/mlish")) ; to include .mlish files
 
 (define test-omit-paths
   '("examples/tests/mlish/sweet-map.rkt" ; needs sweet-exp
+    "examples/fomega3.rkt"
+    "examples/tests/fomega3-tests.rkt"
     "examples/tests/mlish/bg/README.md"))
 
 (define test-timeouts
-  '(("examples/tests/mlish/generic.mlish" 200)))
+  '(("examples/tests/mlish/generic.mlish" 300)))

macrotypes/stx-utils.rkt

@@ -1,15 +1,22 @@
 #lang racket/base
-(require syntax/stx syntax/parse racket/list racket/format version/utils)
+(require syntax/stx syntax/parse syntax/parse/define
+         racket/list racket/format version/utils)
 (provide (all-defined-out))
 
+;; shorthands
+(define id? identifier?)
+(define free-id=? free-identifier=?)
+(define fmt format)
+
 (define (stx-cadr stx) (stx-car (stx-cdr stx)))
 (define (stx-caddr stx) (stx-cadr (stx-cdr stx)))
 (define (stx-cddr stx) (stx-cdr (stx-cdr stx)))
 
+(define datum->stx datum->syntax)
 (define (stx->datum stx)
-  (if (syntax? stx)
-      (syntax->datum stx)
-      (map syntax->datum stx)))
+  (cond [(syntax? stx) (syntax->datum stx)]
+        [(list? stx) (map stx->datum stx)]
+        [else stx]))
 
 (define (stx-rev stx)
   (reverse (stx->list stx)))
@@ -28,11 +35,17 @@
   (define paren-prop (syntax-property stx 'paren-shape))
   (and paren-prop (char=? #\{ paren-prop)))
 
-(define (stx-member v stx)
-  (member v (stx->list stx) free-identifier=?))
+(define (stx-datum-equal? x y [eq equal?])
+  (eq (stx->datum x) (stx->datum y)))
+
+(define (stx-member v stx [eq free-id=?])
+  (member v (stx->list stx) eq))
+
+(define (stx-datum-member v stx [eq stx-datum-equal?])
+  (stx-member v stx eq))
 
 (define (str-stx-member v stx)
-  (member (datum->syntax v) (map datum->syntax (stx->list stx)) string=?))
+  (stx-datum-member v stx))
 (define (str-stx-assoc v stx)
   (assoc v (map stx->list (stx->list stx)) stx-str=?))
 (define (stx-assoc v stx [cmp free-identifier=?]) ; v = id
@@ -41,13 +54,15 @@
   (findf f (stx->list stx)))
 
 (define (stx-length stx) (length (stx->list stx)))
-(define (stx-length=? stx1 stx2)
-  (= (stx-length stx1) (stx-length stx2)))
+(define (stx-length=? stx1 stx2)   (= (stx-length stx1) (stx-length stx2)))
+(define (stx-length>=? stx1 stx2)  (>= (stx-length stx1) (stx-length stx2)))
+(define (stx-length<=? stx1 stx2)  (<= (stx-length stx1) (stx-length stx2)))
 
 (define (stx-last stx) (last (stx->list stx)))
 
 (define (stx-list-ref stx i)
   (list-ref (stx->list stx) i))
+(define-simple-macro (in-stx-list stx) (in-list (stx->list stx)))
 
 (define (stx-str=? s1 s2)
   (string=? (syntax-e s1) (syntax-e s2)))
@@ -72,21 +87,69 @@
 
 (define (stx-remove-dups Xs)
   (remove-duplicates (stx->list Xs) free-identifier=?))
+(define (stx-remove v lst [f free-id=?])
+  (remove v (stx->list lst) f))
 
 (define (stx-drop stx n)
   (drop (stx->list stx) n))
 
+(define (id-lower-case? stx)
+  (unless (identifier? stx)
+    (error 'stx-upcase "Expected identifier, given ~a" stx))
+  (char-lower-case? 
+   (car (string->list (symbol->string (syntax->datum stx))))))
+
+(define (id-upcase stx)
+  (unless (identifier? stx)
+    (error 'stx-upcase "Expected identifier, given ~a" stx))
+  (define chars (string->list (symbol->string (syntax->datum stx))))
+  (define fst (car chars))
+  (define rst (cdr chars))
+  (datum->syntax 
+   stx 
+   (string->symbol (apply string (cons (char-upcase fst) rst)))))
+
 (define (generate-temporariess stx)
   (stx-map generate-temporaries stx))
 (define (generate-temporariesss stx)
   (stx-map generate-temporariess stx))
 
+;; stx prop helpers
+
+;; ca*r : Any -> Any
+(define (ca*r v)
+  (if (cons? v) (ca*r (car v)) v))
+;; cd*r : Any -> Any
+(define (cd*r v)
+  (if (cons? v) (cd*r (cdr v)) v))
+
+;; get-stx-prop/ca*r : Syntax Key -> Val
+;; Retrieves Val at Key stx prop on Stx.
+;; If Val is a non-empty list, continue down head until non-list.
+(define (get-stx-prop/ca*r stx tag)
+  (ca*r (syntax-property stx tag)))
+
+;; get-stx-prop/cd*r : Syntax Key -> Val
+(define (get-stx-prop/cd*r stx tag)
+  (cd*r (syntax-property stx tag)))
+
 ;; transfers properties and src loc from orig to new
 (define (transfer-stx-props new orig #:ctx [ctx new])
   (datum->syntax ctx (syntax-e new) orig orig))
 (define (replace-stx-loc old new)
   (datum->syntax (syntax-disarm old #f) (syntax-e (syntax-disarm old #f)) new old))
 
+;; transfer single prop
+(define (transfer-prop p from to)
+  (define v (syntax-property from p))
+  (syntax-property to p v))
+;; transfer all props except 'origin, 'orig, and ':
+(define (transfer-props from to #:except [dont-transfer '(origin orig :)])
+  (define (transfer-from prop to) (transfer-prop prop from to))
+  (define props (syntax-property-symbol-keys from))
+  (define props/filtered (foldr remove props dont-transfer))
+  (foldl transfer-from to props/filtered))
+
 ;; set-stx-prop/preserved : Stx Any Any -> Stx
 ;; Returns a new syntax object with the prop property set to val. If preserved
 ;; syntax properties are supported, this also marks the property as preserved.

macrotypes/type-constraints.rkt

@@ -161,7 +161,7 @@
 ;; lookup-Xs/keep-unsolved : (Stx-Listof Id) Constraints -> (Listof Type-Stx)
 ;; looks up each X in the constraints, returning the X if it's unconstrained
 (define (lookup-Xs/keep-unsolved Xs cs)
-  (for/list ([X (in-list (stx->list Xs))])
+  (for/list ([X (in-stx-list Xs)])
     (or (lookup X cs) X)))
 
 ;; instantiate polymorphic types

turnstile/examples/dep.rkt

@@ -0,0 +1,113 @@
+#lang turnstile/lang
+
+; Π  λ ≻ ⊢ ≫ ⇒ ∧ (bidir ⇒ ⇐)
+
+(provide (rename-out [#%type *]) Π → ∀ λ #%app ann define define-type-alias)
+
+#;(begin-for-syntax
+  (define old-ty= (current-type=?))
+  (current-type=?
+   (λ (t1 t2)
+     (displayln (stx->datum t1))
+     (displayln (stx->datum t2))
+     (old-ty= t1 t2)))
+  (current-typecheck-relation (current-type=?)))
+
+;(define-syntax-category : kind)
+(define-internal-type-constructor →)
+(define-internal-binding-type ∀)
+;; TODO: how to do Type : Type
+(define-typed-syntax (Π ([X:id : τ_in] ...) τ_out) ≫
+  [[X ≫ X- : τ_in] ... ⊢ [τ_out ≫ τ_out- ⇒ _][τ_in ≫ τ_in- ⇒ _] ...]
+  -------
+  [⊢ (∀- (X- ...) (→- τ_in- ... τ_out-)) ⇒ #,(expand/df #'#%type)])
+;; abbrevs for Π
+(define-simple-macro (→ τ_in ... τ_out)
+  #:with (X ...) (generate-temporaries #'(τ_in ...))
+  (Π ([X : τ_in] ...) τ_out))
+(define-simple-macro (∀ (X ...)  τ)
+  (Π ([X : #%type] ...) τ))
+;; ~Π pattern expander
+(begin-for-syntax
+  (define-syntax ~Π
+    (pattern-expander
+     (syntax-parser
+       [(_ ([x:id : τ_in] ... (~and (~literal ...) ooo)) τ_out)
+        #'(~∀ (x ... ooo) (~→ τ_in ... ooo τ_out))]
+       [(_ ([x:id : τ_in] ...)  τ_out)
+        #'(~∀ (x ...) (~→ τ_in ... τ_out))]))))
+
+;; TODO: add case with expected type + annotations
+;; - check that annotations match expected types
+(define-typed-syntax λ
+  [(_ ([x:id : τ_in] ...) e) ≫
+   [[x ≫ x- : τ_in] ... ⊢ [e ≫ e- ⇒ τ_out][τ_in ≫ τ_in- ⇒ _] ...]
+   -------
+   [⊢ (λ- (x- ...) e-) ⇒ (Π ([x- : τ_in-] ...) τ_out)]]
+  [(_ (y:id ...) e) ⇐ (~Π ([x:id : τ_in] ...) τ_out) ≫
+   [[x ≫ x- : τ_in] ... ⊢ #,(substs #'(x ...) #'(y ...) #'e) ≫ e- ⇐ τ_out]
+   ---------
+   [⊢ (λ- (x- ...) e-)]])
+
+;; TODO: do beta on terms?
+(define-typed-syntax #%app
+  [(_ e_fn e_arg ...) ≫ ; apply lambda
+   [⊢ e_fn ≫ (_ (x ...) e ~!) ⇒ (~Π ([X : τ_in] ...) τ_out)]
+   #:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...])
+                 (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])
+   [⊢ e_arg ≫ e_arg- ⇐ τ_in] ...
+   --------
+   [⊢ #,(substs #'(e_arg- ...) #'(x ...) #'e) ⇒
+      #,(substs #'(e_arg- ...) #'(X ...) #'τ_out)]]
+  [(_ e_fn e_arg ... ~!) ≫ ; apply var
+   [⊢ e_fn ≫ e_fn- ⇒ (~Π ([X : τ_in] ...) τ_out)]
+   #:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...])
+                 (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])
+   [⊢ e_arg ≫ e_arg- ⇐ τ_in] ...
+   --------
+   [⊢ (#%app- e_fn- e_arg- ...) ⇒
+      #,(substs #'(e_arg- ...) #'(X ...) #'τ_out)]])
+
+(define-typed-syntax (ann e (~datum :) τ) ≫
+  [⊢ e ≫ e- ⇐ τ]
+  --------
+  [⊢ e- ⇒ τ])
+
+(define-syntax define-type-alias
+  (syntax-parser
+    [(_ alias:id τ);τ:any-type)
+     #'(define-syntax- alias
+         (make-variable-like-transformer #'τ))]
+    #;[(_ (f:id x:id ...) ty)
+     #'(define-syntax- (f stx)
+         (syntax-parse stx
+           [(_ x ...)
+            #:with τ:any-type #'ty
+            #'τ.norm]))]))
+
+(define-typed-syntax define
+  #;[(_ x:id (~datum :) τ:type e:expr) ≫
+   ;[⊢ e ≫ e- ⇐ τ.norm]
+   #:with y (generate-temporary #'x)
+   --------
+   [≻ (begin-
+        (define-syntax x (make-rename-transformer (⊢ y : τ.norm)))
+        (define- y (ann e : τ.norm)))]]
+  [(_ x:id e) ≫
+   ;This won't work with mutually recursive definitions
+   [⊢ e ≫ e- ⇒ _]
+   #:with y (generate-temporary #'x)
+   #:with y+props (transfer-props #'e- #'y #:except '(origin))
+   --------
+   [≻ (begin-
+        (define-syntax x (make-rename-transformer #'y+props))
+        (define- y e-))]]
+  #;[(_ (f [x (~datum :) ty] ... (~or (~datum →) (~datum ->)) ty_out) e ...+) ≫
+   #:with f- (add-orig (generate-temporary #'f) #'f)
+   --------
+   [≻ (begin-
+        (define-syntax- f
+          (make-rename-transformer (⊢ f- : (→ ty ... ty_out))))
+        (define- f-
+          (stlc+lit:λ ([x : ty] ...)
+            (stlc+lit:ann (begin e ...) : ty_out))))]])

turnstile/examples/exist.rkt

@@ -65,7 +65,6 @@
    ;; Γ ⊢ (open [x <= e_packed with X_2] e) : τ_e
    ;;
   [⊢ e_packed ≫ e_packed- ⇒ (~∃ (Y) τ_body)]
-  #:with τ_x (subst #'X #'Y #'τ_body)
-  [([X ≫ X- : #%type]) ([x ≫ x- : τ_x]) ⊢ e ≫ e- ⇒ τ_e]
+  [X [x ≫ x- : #,(subst #'X #'Y #'τ_body)] ⊢ e ≫ e- ⇒ τ_e]
   --------
   [⊢ (let- ([x- e_packed-]) e-) ⇒ τ_e])

turnstile/examples/ext-stlc.rkt

@@ -50,17 +50,6 @@
             #:with τ:any-type #'ty
             #'τ.norm]))]))
 
-(begin-for-syntax
-  (define (transfer-prop p from to)
-    (define v (syntax-property from p))
-    (syntax-property to p v))
-  (define (transfer-props from to)
-    (define props (syntax-property-symbol-keys from))
-    (define props/filtered (remove 'origin (remove 'orig (remove ': props))))
-    (foldl (lambda (p stx) (transfer-prop p from stx)) 
-           to 
-           props/filtered)))
-
 (define-typed-syntax define
   [(_ x:id (~datum :) τ:type e:expr) ≫
    ;[⊢ e ≫ e- ⇐ τ.norm]

turnstile/examples/fomega-no-reuse-old.rkt

@@ -0,0 +1,175 @@
+#lang turnstile/lang
+
+;; System F_omega, without reusing rules from other languages
+;; - try to avoid using built-in "kind" system (ie #%type)
+;;   - not quite there: define-primop and typed-out still use current-type?
+;; - use define-internal- forms instead
+
+;; example suggested by Alexis King
+
+;; this version still uses ': key for kinds
+
+;; tyλ and λ are separate forms
+
+(provide define-type-alias
+         ★ ⇒ Int Bool String Float Char → ∀ tyλ tyapp
+         (typed-out [+ : (→ Int Int Int)])
+         λ #%app #%datum Λ inst ann)
+
+(define-syntax-category kind)
+
+;; redefine:
+;; - current-type?: well-formed types have kind ★
+;; - current-any-type?: valid types have any valid kind
+;; - current-type-eval: reduce tylams and tyapps
+;; - current-type=?: must compare kind annotations as well
+(begin-for-syntax
+  
+  ;; well-formed types have kind ★
+  ;; (need this for define-primop, which still uses type stx-class)
+  (current-type? (λ (t) (★? (kindof t))))
+  ;; o.w., a valid type is one with any valid kind
+  (current-any-type? (λ (t) ((current-kind?) (kindof t))))
+
+  ;; TODO: I think this can be simplified
+  (define (normalize τ)
+    (syntax-parse τ #:literals (#%plain-app #%plain-lambda)
+      [x:id #'x]
+      [(#%plain-app 
+        (#%plain-lambda (tv ...) τ_body) τ_arg ...)
+       (normalize (substs #'(τ_arg ...) #'(tv ...) #'τ_body))]
+      [(#%plain-lambda (x ...) . bodys)
+       #:with bodys_norm (stx-map normalize #'bodys)
+       (transfer-stx-props #'(#%plain-lambda (x ...) . bodys_norm) τ #:ctx τ)]
+      [(#%plain-app x:id . args)
+       #:with args_norm (stx-map normalize #'args)
+       (transfer-stx-props #'(#%plain-app x . args_norm) τ #:ctx τ)]
+      [(#%plain-app . args)
+       #:with args_norm (stx-map normalize #'args)
+       #:with res (normalize #'(#%plain-app . args_norm))
+       (transfer-stx-props #'res τ #:ctx τ)]
+      [_ τ]))
+  (define old-eval (current-type-eval))
+  (current-type-eval (lambda (τ) (normalize (old-eval τ))))
+  
+  (define old-type=? (current-type=?))
+  ; ty=? == syntax eq and syntax prop eq
+  (define (type=? t1 t2)
+    (let ([k1 (kindof t1)][k2 (kindof t2)])
+      ; the extra `and` and `or` clauses are bc type=? is a structural
+      ; traversal on stx objs, so not all sub stx objs will have a "type"-stx
+      (and (or (and (not k1) (not k2))
+               (and k1 k2 ((current-kind=?) k1 k2)))
+           (old-type=? t1 t2))))
+  (current-type=? type=?)
+  (current-typecheck-relation type=?))
+
+;; kinds ----------------------------------------------------------------------
+(define-internal-kind-constructor ★) ; defines ★-
+(define-syntax (★ stx)
+  (syntax-parse stx
+    [:id (mk-kind #'(★-))]
+    [(_ k:kind ...) (mk-kind #'(★- k.norm ...))]))
+
+(define-kind-constructor ⇒ #:arity >= 1)
+
+;; types ----------------------------------------------------------------------
+(define-kinded-syntax (define-type-alias alias:id τ:any-type) ≫
+  ------------------
+  [≻ (define-syntax- alias 
+       (make-variable-like-transformer #'τ.norm))])
+
+(define-base-type Int : ★)
+(define-base-type Bool : ★)
+(define-base-type String : ★)
+(define-base-type Float : ★)
+(define-base-type Char : ★)
+
+(define-internal-type-constructor →) ; defines →-
+(define-kinded-syntax (→ ty ...+) ≫
+  [⊢ ty ≫ ty- ⇒ (~★ . _)] ...
+  --------
+  [⊢ (→- ty- ...) ⇒ ★])
+
+(define-internal-binding-type ∀) ; defines ∀-
+(define-kinded-syntax ∀ #:datum-literals (:)
+  [(_ ([tv:id : k_in:kind] ...) ty) ≫
+   [[tv ≫ tv- : k_in.norm] ... ⊢ ty ≫ ty- ⇒ (~★ . _)]
+   -------
+   [⊢ (∀- (tv- ...) ty-) ⇒ (★ k_in.norm ...)]])
+
+(define-kinded-syntax (tyλ bvs:kind-ctx τ_body) ≫
+  [[bvs.x ≫ tv- : bvs.kind] ... ⊢ τ_body ≫ τ_body- ⇒ k_body]
+  #:fail-unless ((current-kind?) #'k_body)
+                (format "not a valid type: ~a\n" (type->str #'τ_body))
+  --------
+  [⊢ (λ- (tv- ...) τ_body-) ⇒ (⇒ bvs.kind ... k_body)])
+
+(define-kinded-syntax (tyapp τ_fn τ_arg ...) ≫
+  [⊢ τ_fn ≫ τ_fn- ⇒ (~⇒ k_in ... k_out)]
+  #:fail-unless (stx-length=? #'[k_in ...] #'[τ_arg ...])
+                (num-args-fail-msg #'τ_fn #'[k_in ...] #'[τ_arg ...])
+  [⊢ τ_arg ≫ τ_arg- ⇐ k_in] ...
+  --------
+  [⊢ (#%app- τ_fn- τ_arg- ...) ⇒ k_out])
+
+;; terms ----------------------------------------------------------------------
+(define-typed-syntax λ #:datum-literals (:)
+  [(_ ([x:id : τ_in:type] ...) e) ≫
+   [[x ≫ x- : τ_in.norm] ... ⊢ e ≫ e- ⇒ τ_out]
+   -------
+   [⊢ (λ- (x- ...) e-) ⇒ (→ τ_in.norm ... τ_out)]]
+  [(_ (x:id ...) e) ⇐ (~→ τ_in ... τ_out) ≫
+   [[x ≫ x- : τ_in] ... ⊢ e ≫ e- ⇐ τ_out]
+   ---------
+   [⊢ (λ- (x- ...) e-)]])
+
+(define-typed-syntax (#%app e_fn e_arg ...) ≫
+  [⊢ e_fn ≫ e_fn- ⇒ (~→ τ_in ... τ_out)]
+  #:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...])
+                (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])
+  [⊢ e_arg ≫ e_arg- ⇐ τ_in] ...
+  --------
+  [⊢ (#%app- e_fn- e_arg- ...) ⇒ τ_out])
+
+(define-typed-syntax (ann e (~datum :) τ:type) ≫
+  [⊢ e ≫ e- ⇐ τ.norm]
+  --------
+  [⊢ e- ⇒ τ.norm])
+
+(define-typed-syntax #%datum
+  [(_ . b:boolean) ≫
+   --------
+   [⊢ (#%datum- . b) ⇒ Bool]]
+  [(_ . s:str) ≫
+   --------
+   [⊢ (#%datum- . s) ⇒ String]]
+  [(_ . f) ≫
+   #:when (flonum? (syntax-e #'f))
+   --------
+   [⊢ (#%datum- . f) ⇒ Float]]
+  [(_ . c:char) ≫
+   --------
+   [⊢ (#%datum- . c) ⇒ Char]]
+  [(_ . n:integer) ≫
+   --------
+   [⊢ (#%datum- . n) ⇒ Int]]
+  [(_ . x) ≫
+   --------
+   [_ #:error (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x)]])
+
+(define-typed-syntax (Λ bvs:kind-ctx e) ≫
+  [([bvs.x ≫ tv- : bvs.kind] ...) () ⊢ e ≫ e- ⇒ τ_e]
+  --------
+  [⊢ e- ⇒ (∀ ([tv- : bvs.kind] ...) τ_e)])
+
+(define-typed-syntax (inst e τ ...) ≫
+  [⊢ e ≫ e- ⇒ (~∀ (tv ...) τ_body) (⇒ (~★ k ...))]
+;  [⊢ τ ≫ τ- ⇐ k] ...  ; ⇐ would use typechecks?
+  [⊢ τ ≫ τ- ⇒ k_τ] ... ; so use ⇒ and kindchecks?
+  #:fail-unless (kindchecks? #'(k_τ ...) #'(k ...))
+                (typecheck-fail-msg/multi #'(k ...) #'(k_τ ...) #'(τ ...))
+  #:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)
+  --------
+  [⊢ e- ⇒ τ-inst])
+

turnstile/examples/fomega-no-reuse.rkt

@@ -12,7 +12,7 @@
          (typed-out [+ : (→ Int Int Int)])
          λ #%app #%datum Λ inst ann)
 
-(define-syntax-category kind)
+(define-syntax-category :: kind)
 
 ;; redefine:
 ;; - current-type?: well-formed types have kind ★
@@ -23,9 +23,10 @@
   
   ;; well-formed types have kind ★
   ;; (need this for define-primop, which still uses type stx-class)
-  (current-type? (λ (t) (★? (typeof t))))
+  (current-type? (λ (t) (★? (kindof t))))
   ;; o.w., a valid type is one with any valid kind
-  (current-any-type? (λ (t) ((current-kind?) (typeof t))))
+  (current-any-type? (λ (t) (define k (kindof t))
+                        (and k ((current-kind?) k))))
 
   ;; TODO: I think this can be simplified
   (define (normalize τ)
@@ -48,20 +49,19 @@
   (define old-eval (current-type-eval))
   (current-type-eval (lambda (τ) (normalize (old-eval τ))))
   
-  (define old-type=? (current-type=?))
+  (define old-typecheck? (current-typecheck-relation))
   ; ty=? == syntax eq and syntax prop eq
-  (define (type=? t1 t2)
-    (let ([k1 (typeof t1)][k2 (typeof t2)])
+  (define (new-typecheck? t1 t2)
+    (let ([k1 (kindof t1)][k2 (kindof t2)])
       ; the extra `and` and `or` clauses are bc type=? is a structural
       ; traversal on stx objs, so not all sub stx objs will have a "type"-stx
       (and (or (and (not k1) (not k2))
-               (and k1 k2 ((current-kind=?) k1 k2)))
-           (old-type=? t1 t2))))
-  (current-type=? type=?)
-  (current-typecheck-relation (current-type=?)))
+               (and k1 k2 (kindcheck? k1 k2)))
+           (old-typecheck? t1 t2))))
+  (current-typecheck-relation new-typecheck?))
 
 ;; kinds ----------------------------------------------------------------------
-(define-internal-kind-constructor ★ #:arity >= 0) ; defines ★-
+(define-internal-kind-constructor ★) ; defines ★-
 (define-syntax (★ stx)
   (syntax-parse stx
     [:id (mk-kind #'(★-))]
@@ -75,11 +75,11 @@
   [≻ (define-syntax- alias 
        (make-variable-like-transformer #'τ.norm))])
 
-(define-base-type Int : ★)
-(define-base-type Bool : ★)
-(define-base-type String : ★)
-(define-base-type Float : ★)
-(define-base-type Char : ★)
+(define-base-type Int :: ★)
+(define-base-type Bool :: ★)
+(define-base-type String :: ★)
+(define-base-type Float :: ★)
+(define-base-type Char :: ★)
 
 (define-internal-type-constructor →) ; defines →-
 (define-kinded-syntax (→ ty ...+) ≫
@@ -88,15 +88,15 @@
   [⊢ (→- ty- ...) ⇒ ★])
 
 (define-internal-binding-type ∀) ; defines ∀-
-(define-kinded-syntax ∀ #:datum-literals (:)
-  [(_ ([tv:id : k_in:kind] ...) ty) ≫
-   [[tv ≫ tv- : k_in.norm] ... ⊢ ty ≫ ty- ⇒ (~★ . _)]
+(define-kinded-syntax ∀
+  [(_ ctx:kind-ctx ty) ≫
+   [[ctx.x ≫ tv- :: ctx.kind] ... ⊢ ty ≫ ty- ⇒ (~★ . _)]
    -------
-   [⊢ (∀- (tv- ...) ty-) ⇒ (★ k_in.norm ...)]])
+   [⊢ (∀- (tv- ...) ty-) ⇒ (★ ctx.kind ...)]])
 
 (define-kinded-syntax (tyλ bvs:kind-ctx τ_body) ≫
-  [[bvs.x ≫ tv- : bvs.kind] ... ⊢ τ_body ≫ τ_body- ⇒ k_body]
-  #:fail-unless ((current-kind?) #'k_body)
+  [[bvs.x ≫ tv- :: bvs.kind] ... ⊢ τ_body ≫ τ_body- ⇒ k_body]
+  #:fail-unless ((current-kind?) #'k_body) ; better err, in terms of τ_body
                 (format "not a valid type: ~a\n" (type->str #'τ_body))
   --------
   [⊢ (λ- (tv- ...) τ_body-) ⇒ (⇒ bvs.kind ... k_body)])
@@ -155,20 +155,16 @@
    [_ #:error (type-error #:src #'x #:msg "Unsupported literal: ~v" #'x)]])
 
 (define-typed-syntax (Λ bvs:kind-ctx e) ≫
-  [([bvs.x ≫ tv- : bvs.kind] ...) () ⊢ e ≫ e- ⇒ τ_e]
+  [[bvs.x ≫ tv- :: bvs.kind] ... ⊢ e ≫ e- ⇒ τ_e]
   --------
-  [⊢ e- ⇒ (∀ ([tv- : bvs.kind] ...) τ_e)])
+  [⊢ e- ⇒ (∀ ([tv- :: bvs.kind] ...) τ_e)])
 
-;; TODO: what to do when a def-typed-stx needs both
-;; current-typecheck-relation and current-kindcheck-relation
-(define-typed-syntax (inst e τ ...) ≫
-  [⊢ e ≫ e- ⇒ (~∀ (tv ...) τ_body) (⇒ (~★ k ...))]
-;  [⊢ τ ≫ τ- ⇐ k] ...
-  ;; want to use kindchecks? instead of typechecks?
-  [⊢ τ ≫ τ- ⇒ k_τ] ...
+(define-typed-syntax (inst e τ:any-type ...) ≫
+  [⊢ e ≫ e- ⇒ (~∀ (tv ...) τ_body) (⇒ :: (~★ k ...))]
+;  [⊢ τ ≫ τ- ⇐ k] ...     ; ⇐ would use typechecks?
+  [⊢ τ ≫ τ- ⇒ :: k_τ] ... ; so use ⇒ and kindchecks?
   #:fail-unless (kindchecks? #'(k_τ ...) #'(k ...))
                 (typecheck-fail-msg/multi #'(k ...) #'(k_τ ...) #'(τ ...))
-  #:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)
   --------
-  [⊢ e- ⇒ τ-inst])
+  [⊢ e- ⇒ #,(substs #'(τ.norm ...) #'(tv ...) #'τ_body)])
 

turnstile/examples/fomega.rkt

@@ -1,54 +1,33 @@
 #lang turnstile/lang
-(extends "sysf.rkt" #:except #%datum ∀ ~∀ ∀? Λ inst)
-(reuse String #%datum #:from "stlc+reco+var.rkt")
+(reuse λ #%app Int → + #:from "sysf.rkt")
+(reuse define-type-alias #%datum String #:from "ext-stlc.rkt")
 
 ;; System F_omega
-;; Type relation:
 ;; Types:
-;; - types from sysf.rkt
-;; - String from stlc+reco+var
+;; - redefine ∀
+;; - extend sysf with tyλ and tyapp
 ;; Terms:
-;; - extend ∀ Λ inst from sysf
-;; - add tyλ and tyapp
-;; - #%datum from stlc+reco+var
+;; - extend sysf with Λ inst
 
-(provide (for-syntax current-kind?)
-         define-type-alias
-         (type-out ★ ⇒ ∀★ ∀)
-         Λ inst tyλ tyapp)
+(provide (type-out ∀) (kind-out ★ ⇒ ∀★) Λ inst tyλ tyapp)
 
-(define-syntax-category kind)
+(define-syntax-category :: kind)
 
-; want #%type to be equiv to★
-; => edit current-kind? so existing #%type annotations (with no #%kind tag)
-;    are treated as kinds
-; <= define ★ as rename-transformer expanding to #%type
+;; want #%type to be equiv to ★
+;; => extend current-kind? to recognize #%type
+;; <= define ★ as rename-transformer expanding to #%type
 (begin-for-syntax
   (current-kind? (λ (k) (or (#%type? k) (kind? k))))
-  ;; Try to keep "type?" backward compatible with its uses so far,
-  ;; eg in the definition of λ or previous type constuctors.
-  ;; (However, this is not completely possible, eg define-type-alias)
-  ;; So now "type?" no longer validates types, rather it's a subset.
-  ;; But we no longer need type? to validate types, instead we can use
-  ;; (kind? (typeof t))
-  (current-type? (λ (t)
-                   (define k (typeof t))
-                   #;(or (type? t) (★? (typeof t)) (∀★? (typeof t)))
-                   (and ((current-kind?) k) (not (⇒? k))))))
-
-; must override, to handle kinds
-(define-syntax define-type-alias
-  (syntax-parser
-    [(define-type-alias alias:id τ)
-     #:with (τ- k_τ) (infer+erase #'τ)
-     #:fail-unless ((current-kind?) #'k_τ)
-                   (format "not a valid type: ~a\n" (type->str #'τ))
-     #'(define-syntax alias 
-         (syntax-parser [x:id #'τ-] [(_ . rst) #'(τ- . rst)]))]))
+  ;; any valid type (includes ⇒-kinded types)
+  (current-any-type? (λ (t) (define k (kindof t))
+                        (and k ((current-kind?) k))))
+  ;; well-formed types, ie not types with ⇒ kind
+  (current-type? (λ (t) (and ((current-any-type?) t)
+                             (not (⇒? (kindof t)))))))
 
 (begin-for-syntax
   (define ★? #%type?)
-  (define-syntax ~★ (lambda _ (error "~★ not implemented")))) ; placeholder
+  (define-syntax ~★ (λ _ (error "~★ not implemented")))) ; placeholder
 (define-syntax ★ (make-rename-transformer #'#%type))
 (define-kind-constructor ⇒ #:arity >= 1)
 (define-kind-constructor ∀★ #:arity >= 0)
@@ -56,7 +35,7 @@
 (define-binding-type ∀ #:arr ∀★)
 
 ;; alternative: normalize before type=?
-; but then also need to normalize in current-promote
+;; but then also need to normalize in current-promote
 (begin-for-syntax
   (define (normalize τ)
     (syntax-parse τ #:literals (#%plain-app #%plain-lambda)
@@ -77,44 +56,45 @@
       [_ τ]))
   
   (define old-eval (current-type-eval))
-  (define (type-eval τ) (normalize (old-eval τ)))
-  (current-type-eval type-eval)
+  (define (new-type-eval τ) (normalize (old-eval τ)))
+  (current-type-eval new-type-eval)
   
   (define old-type=? (current-type=?))
-  ; ty=? == syntax eq and syntax prop eq
-  (define (type=? t1 t2)
-    (let ([k1 (typeof t1)][k2 (typeof t2)])
+  ;; need to also compare kinds of types
+  (define (new-type=? t1 t2)
+    (let ([k1 (kindof t1)][k2 (kindof t2)])
+      ;; need these `not` checks bc type= does a structural stx traversal
+      ;; and may compare non-type ids (like #%plain-app)
       (and (or (and (not k1) (not k2))
-               (and k1 k2 ((current-type=?) k1 k2)))
+               (and k1 k2 ((current-kind=?) k1 k2)))
            (old-type=? t1 t2))))
-  (current-type=? type=?)
-  (current-typecheck-relation (current-type=?)))
+  (current-typecheck-relation new-type=?))
 
 (define-typed-syntax (Λ bvs:kind-ctx e) ≫
-  [([bvs.x ≫ tv- : bvs.kind] ...) () ⊢ e ≫ e- ⇒ τ_e]
+  [[bvs.x ≫ tv- :: bvs.kind] ... ⊢ e ≫ e- ⇒ τ_e]
   --------
-  [⊢ e- ⇒ (∀ ([tv- : bvs.kind] ...) τ_e)])
+  [⊢ e- ⇒ (∀ ([tv- :: bvs.kind] ...) τ_e)])
 
-(define-typed-syntax (inst e τ ...) ≫
-  [⊢ e ≫ e- ⇒ (~∀ (tv ...) τ_body) (⇒ (~∀★ k ...))]
-  [⊢ τ ≫ τ- ⇐ k] ...
-  #:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)
+;; τ.norm invokes current-type-eval while "≫ τ-" uses only local-expand
+;; (via infer fn)
+(define-typed-syntax (inst e τ:any-type ...) ≫
+  [⊢ e ≫ e- ⇒ (~∀ tvs τ_body) (⇒ :: (~∀★ k ...))]
+  [⊢ τ ≫ τ- ⇐ :: k] ...
   --------
-  [⊢ e- ⇒ τ-inst])
+  [⊢ e- ⇒ #,(substs #'(τ.norm ...) #'tvs #'τ_body)])
 
-;; TODO: merge with regular λ and app?
-;; - see fomega2.rkt
-(define-typed-syntax (tyλ bvs:kind-ctx τ_body) ≫
-  [[bvs.x ≫ tv- : bvs.kind] ... ⊢ τ_body ≫ τ_body- ⇒ k_body]
-  #:fail-unless ((current-kind?) #'k_body)
-  (format "not a valid type: ~a\n" (type->str #'τ_body))
+;; - see fomega2.rkt for example with no explicit tyλ and tyapp
+(define-kinded-syntax (tyλ bvs:kind-ctx τ_body) ≫
+  [[bvs.x ≫ tv- :: bvs.kind] ... ⊢ τ_body ≫ τ_body- ⇒ k_body]
+  #:fail-unless ((current-kind?) #'k_body) ; better err, in terms of τ_body
+                (format "not a valid type: ~a\n" (type->str #'τ_body))
   --------
   [⊢ (λ- (tv- ...) τ_body-) ⇒ (⇒ bvs.kind ... k_body)])
 
-(define-typed-syntax (tyapp τ_fn τ_arg ...) ≫
+(define-kinded-syntax (tyapp τ_fn τ_arg ...) ≫
   [⊢ τ_fn ≫ τ_fn- ⇒ (~⇒ k_in ... k_out)]
   #:fail-unless (stx-length=? #'[k_in ...] #'[τ_arg ...])
-  (num-args-fail-msg #'τ_fn #'[k_in ...] #'[τ_arg ...])
+                (num-args-fail-msg #'τ_fn #'[k_in ...] #'[τ_arg ...])
   [⊢ τ_arg ≫ τ_arg- ⇐ k_in] ...
   --------
   [⊢ (#%app- τ_fn- τ_arg- ...) ⇒ k_out])

turnstile/examples/fomega2.rkt

@@ -1,5 +1,5 @@
 #lang turnstile/lang
-(extends "sysf.rkt" #:except #%datum ∀ ~∀ ∀? Λ inst)
+(extends "sysf.rkt" #:except #%datum ∀ ~∀ ∀? Λ inst λ #%app →)
 (reuse String #%datum #:from "stlc+reco+var.rkt")
 
 ; same as fomega.rkt except here λ and #%app works as both type and terms
@@ -17,31 +17,42 @@
 
 (provide define-type-alias
          ★ ∀★ ∀
-         Λ inst)
+         λ #%app → Λ inst
+         (for-syntax current-kind-eval kindcheck?))
 
-(define-syntax-category kind)
+(define-syntax-category :: kind)
 
 (begin-for-syntax
-  (current-kind? (λ (k) (or (#%type? k) (kind? k) (#%type? (typeof k)))))
+  (define old-kind? (current-kind?))
+  (current-kind? (λ (k) (or (#%type? k) (old-kind? k))))
   ;; Try to keep "type?" backward compatible with its uses so far,
   ;; eg in the definition of λ or previous type constuctors.
   ;; (However, this is not completely possible, eg define-type-alias)
   ;; So now "type?" no longer validates types, rather it's a subset.
   ;; But we no longer need type? to validate types, instead we can use
   ;; (kind? (typeof t))
-  (current-type? (λ (t) (or (type? t)
-                            (let ([k (typeof t)])
-                              (or (★? k) (∀★? k)))
-                            ((current-kind?) t)))))
+  (current-type? (λ (t) (define k (kindof t))
+                    (and k ((current-kind?) k) (not (→? k)))))
+
+  ;; o.w., a valid type is one with any valid kind
+  (current-any-type? (λ (t) (define k (kindof t))
+                        (and k ((current-kind?) k)))))
 
 ; must override
 (define-syntax define-type-alias
   (syntax-parser
     [(_ alias:id τ)
-     #:with (τ- k_τ) (infer+erase #'τ)
+     #:with (τ- _) (infer+erase #'τ #:tag '::)
      #'(define-syntax alias
          (syntax-parser [x:id #'τ-][(_ . rst) #'(τ- . rst)]))]))
 
+;; extend → to serve as both type and kind
+(define-syntax (→ stx)
+  (syntax-parse stx
+    [(_ k:kind ...)                ; kind
+     (add-orig (mk-kind #'(sysf:→- k.norm ...)) stx)]
+    [(_ . tys) #'(sysf:→ . tys)])) ; type
+
 (define-base-kind ★)
 (define-kind-constructor ∀★ #:arity >= 0)
 (define-binding-type ∀ #:arr ∀★)
@@ -70,28 +81,53 @@
   (define (type-eval τ) (normalize (old-eval τ)))
   (current-type-eval type-eval)
   
-  (define old-type=? (current-type=?))
-  (define (type=? t1 t2)
-    (or (and (★? t1) (#%type? t2))
-        (and (#%type? t1) (★? t2))
-        (and (syntax-parse (list t1 t2) #:datum-literals (:)
-               [((~∀ ([tv1 : k1]) tbody1)
-                 (~∀ ([tv2 : k2]) tbody2))
-                ((current-type=?) #'k1 #'k2)]
-               [_ #t])
-             (old-type=? t1 t2))))
-  (current-type=? type=?)
-  (current-typecheck-relation (current-type=?)))
+  ;; must be kind= (and not kindcheck?) since old-kind=? recurs on curr-kind=
+  (define old-kind=? (current-kind=?))
+  (define (new-kind=? k1 k2)
+    (or (and (★? k1) (#%type? k2)) ; enables use of existing type defs
+        (and (#%type? k1) (★? k2))
+        (old-kind=? k1 k2)))
+  (current-kind=? new-kind=?)
+  (current-kindcheck-relation new-kind=?)
+
+  (define old-typecheck? (current-typecheck-relation))
+  (define (new-typecheck? t1 t2)
+    (syntax-parse (list t1 t2) #:datum-literals (:)
+     [((~∀ ([tv1 : k1]) tbody1)
+       (~∀ ([tv2 : k2]) tbody2))
+      (and (kindcheck? #'k1 #'k2) (typecheck? #'tbody1 #'tbody2))]
+     [_ (old-typecheck? t1 t2)]))
+  (current-typecheck-relation new-typecheck?))
 
 (define-typed-syntax (Λ bvs:kind-ctx e) ≫
-  [[bvs.x ≫ tv- : bvs.kind] ... ⊢ e ≫ e- ⇒ τ_e]
+  [[bvs.x ≫ tv- :: bvs.kind] ... ⊢ e ≫ e- ⇒ τ_e]
   --------
-  [⊢ e- ⇒ (∀ ([tv- : bvs.kind] ...) τ_e)])
+  [⊢ e- ⇒ (∀ ([tv- :: bvs.kind] ...) τ_e)])
 
-(define-typed-syntax (inst e τ ...) ≫
-  [⊢ e ≫ e- ⇒ (~∀ (tv ...) τ_body) (⇒ : (~∀★ k ...))]
-  [⊢ τ ≫ τ- ⇐ k] ...
-  #:with τ-inst (substs #'(τ- ...) #'(tv ...) #'τ_body)
+(define-typed-syntax (inst e τ:any-type ...) ≫
+  [⊢ e ≫ e- ⇒ (~∀ (tv ...) τ_body) (⇒ :: (~∀★ k ...))]
+;  [⊢ τ ≫ τ- ⇐ :: k] ... ; doesnt work since def-typed-s ⇐ not using kindcheck?
+  #:with (k_τ ...) (stx-map kindof #'(τ.norm ...))
+  #:fail-unless (kindchecks? #'(k_τ ...) #'(k ...))
+                (typecheck-fail-msg/multi #'(k ...) #'(k_τ ...) #'(τ ...))
   --------
-  [⊢ e- ⇒ τ-inst])
+  [⊢ e- ⇒ #,(substs #'(τ.norm ...) #'(tv ...) #'τ_body)])
 
+;; extend λ to also work as a type
+(define-kinded-syntax λ
+  [(_ bvs:kind-ctx τ) ≫                 ; type
+   [[bvs.x ≫ X- :: bvs.kind] ... ⊢ τ ≫ τ- ⇒ k_res]
+   ------------
+   [⊢ (λ- (X- ...) τ-) ⇒ (→ bvs.kind ... k_res)]]
+  [(_ . rst) ≫ --- [≻ (sysf:λ . rst)]]) ; term
+
+;; extend #%app to also work as a type
+(define-kinded-syntax #%app
+  [(_ τ_fn τ_arg ...) ≫                     ; type
+   [⊢ τ_fn ≫ τ_fn- ⇒ (~→ k_in ... k_out)]
+   #:fail-unless (stx-length=? #'[k_in ...] #'[τ_arg ...])
+                 (num-args-fail-msg #'τ_fn #'[k_in ...] #'[τ_arg ...])
+   [⊢ τ_arg ≫ τ_arg- ⇐ k_in] ...
+   -------------
+   [⊢ (#%app- τ_fn- τ_arg- ...) ⇒ k_out]]
+  [(_ . rst) ≫ --- [≻ (sysf:#%app . rst)]]) ; term

turnstile/examples/fomega3.rkt

@@ -1,6 +1,8 @@
 #lang turnstile/lang
 (extends "fomega.rkt" #:except tyapp tyλ)
 
+;; not current working 2017-02-03
+
 ; same as fomega2.rkt --- λ and #%app works as both regular and type versions,
 ; → is both type and kind --- but reuses parts of fomega.rkt,
 ; ie removes the duplication in fomega2.rkt

turnstile/examples/fsub.rkt

@@ -26,7 +26,7 @@
 (begin-for-syntax
   (define (expose t)
     (cond [(identifier? t)
-           (define sub (typeof t #:tag '<:))
+           (define sub (detach t '<:))
            (if sub (expose sub) t)]
           [else t]))
   (current-promote expose)
@@ -34,7 +34,7 @@
   (define (sub? t1 t2)
     (stlc:sub? ((current-promote) t1) t2))
   (current-sub? sub?)
-  (current-typecheck-relation (current-sub?)))
+  (current-typecheck-relation sub?))
 
 ; quasi-kind, but must be type constructor because its arguments are types
 (define-type-constructor <: #:arity >= 0) 
@@ -79,7 +79,7 @@
   ;; environment with a syntax property using another tag: '<:
   ;; The "expose" function looks for this tag to enforce the bound,
   ;; as in TaPL (fig 28-1)
-  [([tv ≫ tv- : #%type <: τsub] ...) () ⊢ e ≫ e- ⇒ τ_e]
+  [[tv ≫ tv- :: #%type <: τsub] ... ⊢ e ≫ e- ⇒ τ_e]
   --------
   [⊢ e- ⇒ (∀ ([tv- <: τsub] ...) τ_e)])
 (define-typed-syntax (inst e τ:type ...) ≫

turnstile/examples/infer.rkt

@@ -159,7 +159,7 @@
    #:with [X ...]
    (for/list ([X (in-list (generate-temporaries #'[x ...]))])
      (add-orig X X))
-   [([X ≫ X- : #%type] ...) ([x ≫ x- : X] ...)
+   [([X ≫ X- :: #%type] ...) ([x ≫ x- : X] ...)
     ⊢ [body ≫ body- ⇒ : τ_body*]]
    #:with (~?Some [V ...] τ_body (~Cs [id_2 τ_2] ...)) (syntax-local-introduce #'τ_body*)
    #:with τ_fn (some/inst/generalize #'[X- ... V ...]

turnstile/examples/linear/fabul-utils.rkt

@@ -0,0 +1,71 @@
+#lang racket
+(require syntax/parse
+         turnstile/mode
+         (for-syntax syntax/parse syntax/stx racket/syntax)
+         (for-template macrotypes/typecheck
+                       (only-in "lin.rkt"
+                                linear-mode?
+                                make-empty-linear-mode)))
+
+(provide current-language
+         language-name
+         type-converter
+         unrestricted-mode?
+         make-empty-unrestricted-mode
+         L->U
+         U->L
+         )
+
+(struct unrestricted-mode mode (lin-mode))
+
+(define (make-empty-unrestricted-mode)
+  (unrestricted-mode void void (make-empty-linear-mode)))
+
+(define (L->U lin-mode)
+  (unrestricted-mode void void lin-mode))
+
+(define (U->L un-mode)
+  (unrestricted-mode-lin-mode un-mode))
+
+
+(define (current-language)
+  (if (linear-mode? (current-mode))
+      'L
+      'U))
+
+(define (language-name [lang (current-language)])
+  (case lang
+    [(L) "linear"]
+    [(U) "unrestricted"]))
+
+
+; generates function to convert type into language
+; e.g.   (type-converter [ <clauses> ... ]
+;                        [ A  =>  B ]
+;                        [ C  =>  D ]
+;                        <fail-function>)
+(define-syntax type-converter
+  (syntax-parser
+    #:datum-literals (=>)
+    [(_ (stxparse ...)
+        ([from:id => to:id] ...)
+        fail-fn)
+     #:with self (generate-temporary)
+     #:with [(lhs rhs) ...] #'[(from to) ... (to to) ...]
+     #:with [tycon-clause ...]
+     (stx-map (λ (tycon/l tycon/r)
+                (with-syntax ([patn (format-id tycon/l "~~~a" tycon/l)]
+                              [ctor tycon/r]
+                              [t (generate-temporary)]
+                              [s (generate-temporary)])
+                  #'[(patn t (... ...))
+                     #:with [s (... ...)] (stx-map self #'[t (... ...)])
+                     (syntax/loc this-syntax (ctor s (... ...)))]))
+              #'[lhs ...]
+              #'[rhs ...])
+     #'(letrec ([self (syntax-parser
+                        stxparse ...
+                        tycon-clause ...
+                        [(~not (~Any _ . _)) this-syntax]
+                        [_ (fail-fn this-syntax)])])
+         self)]))

turnstile/examples/linear/fabul.rkt

@@ -0,0 +1,241 @@
+#lang turnstile
+(require (for-syntax "fabul-utils.rkt"
+                     turnstile/mode))
+
+(provide begin let let* letrec λ lambda #%app if tup cons nil
+         drop match-list
+         proj isnil head tail list-ref member
+         define
+         %L %U
+         #%module-begin #%top-interaction require
+         (typed-out [= : (→ Int Int Int)]
+                    [< : (→ Int Int Bool)]
+                    [sub1 : (→ Int Int)]
+                    [add1 : (→ Int Int)]
+                    [zero? : (→ Int Bool)]))
+
+; import other languages
+(require (prefix-in U: "../ext-stlc.rkt")
+         (prefix-in U: (except-in "../stlc+cons.rkt" tup proj))
+         (prefix-in U: (only-in "../stlc+tup.rkt" tup proj))
+         (prefix-in L: "lin.rkt")
+         (prefix-in L: "lin+cons.rkt")
+         (only-in "../ext-stlc.rkt" → ~→)
+         (only-in "../stlc+tup.rkt" × ~×)
+         (only-in "../stlc+cons.rkt" List ~List)
+         (only-in "lin+cons.rkt" ⊗ ~⊗ MList ~MList)
+         (only-in "lin+tup.rkt" in-cad*rs)
+         "lin.rkt" #| this includes base types like Int, Unit, etc. |#)
+
+; reuse types
+(reuse Unit Bool Int Float String → #:from "../ext-stlc.rkt")
+(reuse × #:from "../stlc+tup.rkt")
+(reuse List #:from "../stlc+cons.rkt")
+(reuse -o ⊗ MList #:from "lin+cons.rkt")
+
+; reuse forms
+(reuse #%datum ann and or define-type-alias #:from "../ext-stlc.rkt")
+
+
+
+; begin in unrestricted mode
+(begin-for-syntax
+  (current-mode (make-empty-unrestricted-mode)))
+
+
+; dispatch some forms to L: or U: variant, based on [current-language]
+(define-syntax language-dispatch
+  (syntax-parser
+    [(_ [lang ...] form)
+     #:with (form/lang ...) (stx-map (λ (X) (format-id X "~a:~a" X #'form)) #'[lang ...])
+     #'(define-syntax form
+         (syntax-parser
+           [(_ . args)
+            #:when (eq? (current-language) 'lang)
+            (syntax/loc this-syntax
+              (form/lang . args))] ...
+           [_
+            (raise-syntax-error 'form
+                                (format "form not allowed inside ~a language"
+                                        (language-name)))]))]
+
+    [(_ [lang ...] form ...+)
+     #'(begin-
+         (language-dispatch [lang ...] form) ...)]))
+
+(language-dispatch [L U] begin let let* letrec λ lambda #%app if tup cons nil)
+(language-dispatch [L] drop match-list)
+(language-dispatch [U] proj isnil head tail list-ref member)
+
+
+(begin-for-syntax
+  (define (fully-unrestricted? type)
+    (and (unrestricted-type? type)
+         (syntax-parse type
+           [(~Any _ τ ...) (for/and ([t (in-syntax #'[τ ...])])
+                             (fully-unrestricted? t))]
+           [_ #t])))
+
+  (define (fail/type-convert src lang ty)
+    (raise-syntax-error #f (format "cannot convert type ~a into ~a language"
+                                   (type->str ty)
+                                   (language-name lang))
+                        src))
+
+  ; convert-type : Symbol Type -> Type
+  ;  converts a type into a more appropriate variant for the given language
+  (define (convert-type lang type
+                        #:src [fail-src #f]
+                        #:fail [fail (λ (_) (fail/type-convert fail-src lang type))])
+    (define converter
+      (case lang
+        [(L)
+         (type-converter ([σ #:when (linear-type? #'σ) #'σ])
+                         ([List =>  MList]
+                          [×    =>  ⊗]
+                          [→    =>  →]
+                          [-o   =>  -o])
+                         fail)]
+
+        [(U)
+         (type-converter ([τ #:when (fully-unrestricted? #'τ) #'τ])
+                         ([MList =>  List]
+                          [⊗    =>  ×]
+                          [→     =>  →])
+                         fail)]
+
+        [else (error "invalid language" lang)]))
+
+    ((current-type-eval) (converter type)))
+
+  ; convert-syntax : Type Type Syntax -> Syntax
+  ;  creates an expression that wraps the given syntax such that
+  ;  it converts objects from the first type into the second type.
+  ;  the resulting syntax will never evaluate the original syntax twice.
+  ;  e.g.
+  ;    (convert-stx #'(List Int) #'(MList Int) #'x)
+  ;    ->
+  ;    #'(foldr mcons '() x)
+  (define (convert-syntax . args)
+    (syntax-parse args
+      [[τ σ src] #:when (type=? #'τ #'σ) #'src]
+
+      ; convert tuples
+      [[(~or (~⊗ τ ...) (~× τ ...)) (~or (~⊗ σ ...) (~× σ ...)) src]
+       #:with [out ...] (for/list ([cad*r (in-cad*rs #'tmp)]
+                                   [T (in-syntax #'[τ ...])]
+                                   [S (in-syntax #'[σ ...])])
+                          (convert-syntax T S cad*r))
+       #'(let- ([tmp src]) (#%app- list- out ...))]
+
+      ; convert lists
+      [[(~List τ) (~MList σ) src]
+       #:with x+ (convert-syntax #'τ #'σ #'x)
+       #'(#%app- foldr- (λ- (x l) (#%app- mcons- x+ l)) '() src)]
+
+      [[(~MList τ) (~List σ) src]
+       #:with x+ (convert-syntax #'τ #'σ #'x)
+       #'(for/list- ([x (in-mlist src)]) x+)]
+
+      ; convert functions
+      [[(~or (~→ τ ... τ_out) (~-o τ ... τ_out))
+        (~or (~→ σ ... σ_out) (~-o σ ... σ_out))
+        src]
+       #:with (x ...) (stx-map generate-temporary #'[τ ...])
+       #:with (x+ ...) (stx-map convert-syntax #'[σ ...] #'[τ ...] #'[x ...])
+       #:with out (convert-syntax #'τ_out #'σ_out #'(#%app- f x+ ...))
+       #'(let- ([f src]) (λ- (x ...) out))]))
+
+  )
+
+
+; generate barrier crossing macros
+(define-syntax define-barrier
+  (syntax-parser
+    [(_ form LANG A->B)
+     #'(define-typed-syntax form
+         [(_ e) ≫
+          #:when (eq? (syntax-local-context) 'expression)
+          #:fail-when (eq? (current-language) 'LANG)
+                      (format "already in ~a language"
+                              (language-name 'LANG))
+          [⊢ [e ≫ e- ⇒ τ] #:submode A->B]
+          #:with σ (convert-type (current-language) #'τ #:src this-syntax)
+          #:with e-- (convert-syntax #'τ #'σ #'e-)
+          --------
+          [⊢ e-- ⇒ σ]]
+
+         ; expand toplevels using different syntax, bleh
+         [(_ e ...+) ≫
+          #:submode (if (eq? (current-language) 'LANG)
+                        values
+                        A->B)
+            (#:with e- (local-expand #'(begin- e (... ...))
+                                     'top-level
+                                     '()))
+          --------
+          [≻ e-]])]))
+
+(define-barrier %L L U->L)
+(define-barrier %U U L->U)
+
+
+; variable syntax
+(define-typed-variable-syntax
+  #:datum-literals (:)
+  [(_ x- : τ) ≫
+   #:when (eq? (current-language) 'U)
+   #:fail-unless (fully-unrestricted? #'τ)
+   (raise-syntax-error #f "cannot use linear variable from unrestricted language" #'x-)
+   --------
+   [⊢ x- ⇒ τ]]
+
+  [(_ x- : σ) ≫
+   #:when (eq? (current-language) 'L)
+   --------
+   [≻ (#%lin-var x- : σ)]])
+
+; define syntax
+(define-typed-syntax define
+  #:datum-literals (:)
+  [(define (f [x:id : ty] ...) ret
+     e ...+) ≫
+   --------
+   [≻ (define f : (→ ty ... ret)
+        (letrec ([{f : (→ ty ... ret)}
+                  (λ (x ...)
+                    (begin e ...))])
+          f))]]
+
+  [(_ x:id : τ:type e:expr) ≫
+   #:fail-when (linear-type? #'τ.norm)
+               "cannot define linear type globally"
+   #:with y (generate-temporary #'x)
+   --------
+   [≻ (begin-
+        (define-syntax x (make-rename-transformer (⊢ y : τ.norm)))
+        (define- y (ann e : τ.norm)))]])
+
+
+; REPL prints expression types
+; enter :lang=L or :lang=U to switch language in REPL
+(define-typed-syntax #%top-interaction
+  [(_ . d) ≫
+   #:when (regexp-match? #px":lang=L" (~a (syntax-e #'d)))
+   #:do [(when (unrestricted-mode? (current-mode))
+           (current-mode (U->L (current-mode))))]
+   --------
+   [≻ (#%app- void-)]]
+
+  [(_ . d) ≫
+   #:when (regexp-match? #px":lang=U" (~a (syntax-e #'d)))
+   #:do [(when (linear-mode? (current-mode))
+           (current-mode (L->U (current-mode))))]
+   --------
+   [≻ (#%app- void-)]]
+
+  [(_ . e) ≫
+   #:do [(printf "; language: ~a\n" (language-name))]
+   [⊢ e ≫ e- ⇒ τ]
+   --------
+   [≻ (#%app- printf- '"~v : ~a\n" e- '#,(type->str #'τ))]])

turnstile/examples/linear/lin+chan.rkt

@@ -0,0 +1,61 @@
+#lang turnstile/lang
+(extends "lin+tup.rkt")
+
+(provide (type-out InChan OutChan)
+         make-channel channel-put channel-get
+         thread sleep)
+
+(define-type-constructor InChan #:arity = 1)
+(define-type-constructor OutChan #:arity = 1)
+
+(begin-for-syntax
+  (current-linear-type? (or/c InChan? (current-linear-type?))))
+
+
+(define-typed-syntax make-channel
+  [(_ {ty:type}) ≫
+   #:with σ #'ty.norm
+   #:with tmp (generate-temporary)
+   --------
+   [⊢ (let ([tmp (#%app- make-channel-)])
+            (list tmp tmp))
+      ⇒ (⊗ (InChan σ) (OutChan σ))]])
+
+
+(define-typed-syntax channel-put
+  [(_ ch e) ≫
+   [⊢ ch ≫ ch- ⇒ (~OutChan σ)]
+   [⊢ e ≫ e- ⇐ σ]
+   --------
+   [⊢ (channel-put- ch- e-) ⇒ Unit]])
+
+
+(define-typed-syntax channel-get
+  [(_ ch) ≫
+   [⊢ ch ≫ ch- ⇒ (~InChan σ)]
+   #:with tmp (generate-temporary #'ch)
+   --------
+   [⊢ (let ([tmp ch-])
+            (list tmp (channel-get- tmp)))
+      ⇒ (⊗ (InChan σ) σ)]])
+
+
+(define-typed-syntax thread
+  [(_ f) ≫
+   [⊢ f ≫ f- ⇒ (~-o _)]
+   --------
+   [⊢ (void (thread- f-)) ⇒ Unit]])
+
+
+(define-typed-syntax sleep
+  [(_) ≫
+   --------
+   [⊢ (sleep-) ⇒ Unit]]
+
+  [(_ e) ≫
+   [⊢ e ≫ e- ⇒ σ]
+   #:fail-unless (or (Int? #'σ)
+                     (Float? #'σ))
+   "invalid sleep time, expected Int or Float"
+   --------
+   [⊢ (sleep- e-) ⇒ Unit]])

turnstile/examples/linear/lin+cons.rkt

@@ -0,0 +1,80 @@
+#lang turnstile/lang
+(extends "lin+tup.rkt")
+
+(provide (type-out MList MList0)
+         cons nil match-list)
+
+(define-type-constructor MList #:arity = 1)
+(define-base-type MList0)
+
+(begin-for-syntax
+  (current-linear-type? (or/c MList? MList0? (current-linear-type?))))
+
+
+(define-typed-syntax cons
+  #:datum-literals (@)
+
+  ; implicit memory location created
+  [(_ e e_rest) ≫
+   [⊢ e ≫ e- ⇒ σ]
+   [⊢ e_rest ≫ e_rest- ⇐ (MList σ)]
+   --------
+   [⊢ (#%app- mcons- e- e_rest-) ⇒ (MList σ)]]
+
+  ; with memory location given
+  [(_ e e_rest @ e_loc) ≫
+   [⊢ e ≫ e- ⇒ σ]
+   [⊢ e_rest ≫ e_rest- ⇐ (MList σ)]
+   [⊢ e_loc ≫ e_loc- ⇐ MList0]
+   #:with tmp (generate-temporary #'e_loc)
+   --------
+   [⊢ (let- ([tmp e_loc-])
+            (set-mcar!- tmp e-)
+            (set-mcdr!- tmp e_rest-)
+            tmp)
+      ⇒ (MList σ)]])
+
+
+(define-typed-syntax nil
+  [(_ {ty:type}) ≫
+   --------
+   [⊢ '() ⇒ (MList ty.norm)]]
+  [(_) ⇐ (~MList σ) ≫
+   --------
+   [⊢ '()]])
+
+
+(define-typed-syntax match-list
+  #:datum-literals (cons nil @)
+  [(_ e_list
+      (~or [(cons x+:id xs+:id @ l+:id) e_cons+]
+           [(nil) e_nil+]) ...) ≫
+   #:with [(l x xs e_cons)] #'[(l+ x+ xs+ e_cons+) ...]
+   #:with [e_nil] #'[e_nil+ ...]
+
+   ; list
+   [⊢ e_list ≫ e_list- ⇒ (~MList σ)]
+   #:with σ_xs ((current-type-eval) #'(MList σ))
+   #:with σ_l ((current-type-eval) #'MList0)
+
+   #:mode (make-linear-branch-mode 2)
+     (; cons branch
+      #:submode (branch-nth 0)
+        ([[x ≫ x- : σ]
+          [xs ≫ xs- : σ_xs]
+          [l ≫ l- : σ_l]
+          ⊢ e_cons ≫ e_cons- ⇒ σ_out]
+         #:do [(linear-out-of-scope! #'([x- : σ] [xs- : σ_xs] [l- : σ_l]))])
+
+      ; nil branch
+      #:submode (branch-nth 1)
+        ([⊢ [e_nil ≫ e_nil- ⇐ σ_out]]))
+
+   --------
+   [⊢ (let- ([l- e_list-])
+            (if- (null? l-)
+                 e_nil-
+                 (let- ([x- (mcar- l-)]
+                        [xs- (mcdr- l-)])
+                       e_cons-)))
+      ⇒ σ_out]])

turnstile/examples/linear/lin+tup.rkt

@@ -0,0 +1,112 @@
+#lang turnstile/lang
+(extends "lin.rkt")
+
+(provide (type-out ⊗) tup let*)
+(begin-for-syntax (provide in-cad*rs
+                           list-destructure-syntax))
+
+(define-type-constructor ⊗ #:arity >= 2)
+
+(begin-for-syntax
+  (define (num-tuple-fail-msg σs xs)
+    (format "wrong number of tuple elements: expected ~a, got ~a"
+            (stx-length xs)
+            (stx-length σs)))
+
+  (current-linear-type? (or/c ⊗? (current-linear-type?))))
+
+
+(define-typed-syntax tup
+  [(_ e1 e2 ...+) ≫
+   [⊢ e1 ≫ e1- ⇒ σ1]
+   [⊢ e2 ≫ e2- ⇒ σ2] ...
+   --------
+   [⊢ (list- e1- e2- ...) ⇒ (⊗ σ1 σ2 ...)]])
+
+
+(define-typed-syntax let*
+  ; normal let* recursive bindings
+  [(_ ([x:id e_rhs] . xs) . body) ≫
+   [⊢ e_rhs ≫ e_rhs- ⇒ σ]
+   [[x ≫ x- : σ] ⊢ (let* xs . body) ≫ e_body- ⇒ σ_out]
+   #:do [(linear-out-of-scope! #'([x- : σ]))]
+   --------
+   [⊢ (let- ([x- e_rhs-]) e_body-) ⇒ σ_out]]
+
+  ; tuple unpacking with (let* ([(x ...) tup]) ...)
+  [(_ ([(x:id ...) e_rhs] . xs) . body) ≫
+   [⊢ e_rhs ≫ e_rhs- ⇒ (~⊗ σ ...)]
+   #:fail-unless (stx-length=? #'[σ ...] #'[x ...])
+                 (num-tuple-fail-msg #'[σ ...] #'[x ...])
+
+   [[x ≫ x- : σ] ... ⊢ (let* xs . body) ≫ e_body- ⇒ σ_out]
+   #:do [(linear-out-of-scope! #'([x- : σ] ...))]
+
+   #:with tmp (generate-temporary #'e_tup)
+   #:with destr (list-destructure-syntax #'[x- ...] #'tmp #:unsafe? #t
+                                         #'e_body-)
+   --------
+   [⊢ (let- ([tmp e_rhs-]) destr) ⇒ σ_out]]
+
+  [(_ () e) ≫
+   --------
+   [≻ e]]
+
+  [(_ () e ...+) ≫
+   --------
+   [≻ (lin:begin e ...)]])
+
+
+
+(require racket/unsafe/ops)
+
+;; generate infinite sequence of cad*r syntax, e.g.
+;;   (car e) (cadr e) (caddr e) ...
+(define-for-syntax (in-cad*rs e #:unsafe? [unsafe? #f])
+  (make-do-sequence
+   (λ ()
+     (values (λ (s)
+               (if unsafe?
+                   (quasisyntax/loc e (unsafe-car #,s))
+                   (quasisyntax/loc e (car #,s))))
+             (λ (s)
+               (if unsafe?
+                   (quasisyntax/loc e (unsafe-cdr #,s))
+                   (quasisyntax/loc e (cdr #,s))))
+             e
+             #f #f #f))))
+
+
+;; (list-destructure-syntax #'(x y z ...) #'rhs #'body)
+;;   =
+;; (let ([x (car rhs)]
+;;       [y (cadr rhs)]
+;;       [z (caddr rhs)]
+;;       ...)
+;;   body)
+(define-for-syntax (list-destructure-syntax xs rhs body #:unsafe? [unsafe? #f])
+  (with-syntax ([binds (for/list ([c (in-cad*rs rhs #:unsafe? unsafe?)]
+                                  [x (in-syntax xs)])
+                         (list x c))]
+                [body body])
+    (syntax/loc rhs
+      (let- binds body))))
+
+
+
+(module+ test
+  (begin-for-syntax
+    (require  rackunit)
+    (check-equal? (for/list ([c (in-cad*rs #'x)]
+                             [i (in-range 4)])
+                    (syntax->datum c))
+                  '[(car x)
+                    (car (cdr x))
+                    (car (cdr (cdr x)))
+                    (car (cdr (cdr (cdr x))))])
+
+    (check-equal? (syntax->datum
+                   (list-destructure-syntax #'[x y] #'lst #'z #:unsafe? #t))
+                  '(let- ([x (unsafe-car lst)]
+                          [y (unsafe-car (unsafe-cdr lst))])
+                         z))))

turnstile/examples/linear/lin+var.rkt

@@ -0,0 +1,118 @@
+#lang turnstile/lang
+(extends "lin.rkt")
+(require (only-in "lin+tup.rkt" list-destructure-syntax))
+
+(provide ⊕ var match)
+
+(define-internal-type-constructor ⊕/i)
+
+(define-syntax ⊕
+  (syntax-parser
+    [(_ (V:id t ...) ...)
+     (add-orig (mk-type #'(⊕/i- (#%app 'V t ...) ...))
+               this-syntax)]))
+
+(begin-for-syntax
+  (provide ⊕? ~⊕)
+  (define ⊕? ⊕/i?)
+
+  (define (fail/no-variant type V [src V])
+    (raise-syntax-error #f
+       (format "expected type ~a does not have variant named '~a'\n"
+               (type->str type)
+               (stx->datum V))
+       src))
+
+  (define (num-var-args-fail-msg σs xs)
+    (format "wrong number of arguments to variant: expected ~a, got ~a"
+            (stx-length σs)
+            (stx-length xs)))
+
+
+  (define (unvariant type)
+    (syntax-parse type
+      [(~⊕/i ((~literal #%plain-app) ((~literal quote) U) τ ...) ...)
+       #'[(U τ ...) ...]]))
+
+  (define-syntax ~⊕
+    (pattern-expander
+     (λ (stx)
+       (syntax-case stx ()
+         [(_ . pat)
+          (with-syntax ([(x) (generate-temporaries #'(x))])
+            #'(~and x (~⊕/i . _) (~parse pat (unvariant #'x))))]))))
+
+  (define (has-variant? type v)
+    (syntax-parse type
+      [(~⊕ [U . _] ...)
+       (for/or ([u (in-syntax #'[U ...])])
+         (eq? (stx->datum u) (stx->datum v)))]
+      [_ #f]))
+
+  (define (get-variant type v)
+    (syntax-parse type
+      [(~⊕ [U τ ...] ...)
+       (for/first ([u (in-syntax #'[U ...])]
+                   [ts (in-syntax #'[(τ ...) ...])]
+                   #:when (eq? (stx->datum u) (stx->datum v)))
+         ts)]))
+
+  (current-linear-type? (or/c ⊕? (current-linear-type?)))
+  )
+
+
+(define-typed-syntax var
+  [(_ [V:id e ...]) ⇐ σ_var ≫
+   #:when (⊕? #'σ_var)
+   #:fail-unless (has-variant? #'σ_var #'V)
+                 (fail/no-variant #'σ_var #'V this-syntax)
+   #:with [σ ...] (get-variant #'σ_var #'V)
+   #:fail-unless (stx-length=? #'[σ ...] #'[e ...])
+                 (num-var-args-fail-msg #'[σ ...] #'[e ...])
+   [⊢ e ≫ e- ⇐ σ] ...
+   --------
+   [⊢ (list 'V e- ...)]]
+
+  [(_ [V:id e ...] (~datum as) t) ≫
+   --------
+   [≻ (lin:ann (var [V e ...]) : t)]])
+
+
+
+(define-typed-syntax match
+  [(_ e_var [(V:id x:id ...) e_bra] ...) ≫
+   [⊢ e_var ≫ e_var- ⇒ σ_var]
+   #:fail-unless (⊕? #'σ_var)
+   (format "expected type ⊕, given ~a" (type->str #'σ_var))
+
+   #:mode (make-linear-branch-mode (stx-length #'[e_bra ...]))
+     (#:with ([(x- ...) e_bra- σ_bra] ...)
+      (for/list ([q (in-syntax #'([V (x ...) e_bra] ...))]
+                 [i (in-naturals)])
+        (syntax-parse/typecheck q
+         [(V (x ...) e) ≫
+          #:fail-unless (has-variant? #'σ_var #'V)
+                        (fail/no-variant #'σ_var #'V)
+
+          #:with [σ ...] (get-variant #'σ_var #'V)
+          #:fail-unless (stx-length=? #'[σ ...] #'[x ...])
+                        (num-var-args-fail-msg #'[σ ...] #'[x ...])
+
+          #:submode (branch-nth i)
+            ([[x ≫ x- : σ] ... ⊢ e ≫ e- ⇒ σ_bra]
+             #:do [(linear-out-of-scope! #'([x- : σ] ...))])
+          --------
+          [≻ [(x- ...) e- σ_bra]]])))
+
+   #:with tmp (generate-temporary)
+   #:with (destr ...) (stx-map (λ (l) (apply list-destructure-syntax (stx->list l)))
+                               #'[([x- ...]
+                                   (cdr tmp)
+                                   e_bra-) ...])
+   --------
+   [⊢ (let ([tmp e_var-])
+        (case (car tmp)
+          [(V) destr] ...
+          [else (printf "~a\n" tmp)
+                (error '"unhandled case: " (car tmp))]))
+      ⇒ (⊔ σ_bra ...)]])

turnstile/examples/linear/lin.rkt

@@ -0,0 +1,350 @@
+#lang turnstile
+(extends "../ext-stlc.rkt" #:except define if begin let let* letrec λ #%app)
+
+(provide (for-syntax current-linear-type?
+                     linear-type?
+                     unrestricted-type?
+
+                     linear-mode?
+                     linear-scope
+                     linear-in-scope?
+                     linear-use-var!
+                     linear-out-of-scope!
+                     linear-merge-scopes!
+                     linear-merge-scopes*!
+
+                     ;; TODO: should these be in turnstile/mode ?
+                     branch-nth
+                     branch-then
+                     branch-else
+
+                     make-empty-linear-mode
+                     make-fresh-linear-mode
+                     make-linear-branch-mode)
+
+         %%reset-linear-mode
+
+         (type-out Unit Int String Bool -o)
+         #%top-interaction #%module-begin require only-in
+         begin drop
+         #%app #%lin-var
+         λ (rename-out [λ lambda])
+         let letrec
+         if
+         define
+         )
+
+
+(define-type-constructor -o #:arity >= 1)
+
+
+(begin-for-syntax
+  (require syntax/id-set
+           racket/set
+           racket/generic
+           turnstile/mode)
+
+  (define (fail/multiple-use x)
+    (raise-syntax-error #f "linear variable used more than once" x))
+  (define (fail/unused x)
+    (raise-syntax-error #f "linear variable unused" x))
+  (define (fail/unbalanced-branches x)
+    (raise-syntax-error #f "linear variable may be unused in certain branches" x))
+  (define (fail/unrestricted-fn x)
+    (raise-syntax-error #f "linear variable may not be used by unrestricted function" x))
+
+
+  ;; this parameter defines the linear-type? function.
+  ;; we defining new types that are linear, modify this
+  ;; parameter like so:
+  ;;   (current-linear-type? (or/c MYTYPE? (current-linear-type?)))
+  ;;
+  ;; current-linear-type? : (Parameter (Type -> Bool))
+  (define current-linear-type?
+    (make-parameter -o?))
+
+  ;; is the given type [linear|unrestricted]?
+  ;; Type -> Bool
+  (define (linear-type? T)
+    ((current-linear-type?) T))
+  (define (unrestricted-type? T)
+    (not ((current-linear-type?) T)))
+
+
+
+  ;; mode object to be used during linear typing.
+  ;; the field 'scope' contains a free-id-set of
+  ;; variables that have been used, and therefore
+  ;; can't be used again.
+  (struct linear-mode mode (scope))
+
+  ;; get the current scope (as described above)
+  ;; based on (current-mode)
+  (define (linear-scope)
+    (linear-mode-scope (current-mode)))
+
+  ;; is the given variable available for use?
+  ;; linear-in-scope? : Id -> Bool
+  (define (linear-in-scope? x)
+    (not (set-member? (linear-scope) x)))
+
+  ;; set the variable to be used in this scope, or raise
+  ;; an error if it's already used.
+  ;;
+  ;; linear-use-var! : Id Type -> void
+  (define (linear-use-var! x T #:fail [fail fail/multiple-use])
+    (when (linear-type? T)
+      (when (set-member? (linear-scope) x)
+        (fail x))
+      (set-add! (linear-scope) x)))
+
+
+  ;; call this with the ([x : t] ...) context after introducing variables,
+  ;; to remove those variables from the linear scope
+  ;;
+  ;; linear-out-of-scope! : Ctx -> Void
+  (define (linear-out-of-scope! ctx #:fail [fail fail/unused])
+    (syntax-parse ctx
+      #:datum-literals (:)
+      [([x : σ] ...)
+       (for ([var (in-syntax #'[x ...])]
+             [T (in-syntax #'[σ ...])] #:when (linear-type? T))
+         (if (linear-in-scope? var)
+             (fail var)
+             (set-remove! (linear-scope) var)))]))
+
+  ;; linear-merge-scopes! : (or '∪ '∩) FreeIdSet ... -> void
+  (define (linear-merge-scopes! op #:fail [fail fail/unbalanced-branches] . ss)
+    (linear-merge-scopes*! op ss #:fail fail))
+
+  ;; linear-merge-scopes*! : (or '∪ '∩) (Listof FreeIdSet) -> void
+  (define (linear-merge-scopes*! op ss #:fail [fail fail/unbalanced-branches])
+    (define s0
+      (case op
+        [(∩)
+         (let ([s0 (set-copy (car ss))])
+           (for ([s (in-list (cdr ss))])
+             (set-intersect! s0 s))
+           (for* ([s (in-list ss)]
+                  [x (in-set s)] #:when (not (set-member? s0 x)))
+             (fail x))
+           s0)]
+
+        [(∪) (apply set-union ss)]))
+
+    (set-clear! (linear-scope))
+    (set-union! (linear-scope) s0))
+
+
+
+  ;; a mode that contains submodes, for use
+  ;; in branching (if, cond, etc.)
+  (struct branch-mode mode (sub-modes))
+
+  ;; for use as `#:submode (branch-nth n)`
+  (define ((branch-nth n) bm)
+    (list-ref (branch-mode-sub-modes bm) n))
+  (define branch-then (branch-nth 0))
+  (define branch-else (branch-nth 1))
+
+  ;; creates a branch-mode with n branches (default: 2)
+  ;; which merges the linear sub-scopes during teardown.
+  ;; see 'if' syntax.
+  ;;
+  ;; make-linear-branch : Int -> BranchMode
+  (define (make-linear-branch-mode [n 2])
+    (define scopes
+      (for/list ([i (in-range n)])
+        (set-copy (linear-scope))))
+
+    (branch-mode void
+                 (λ () (linear-merge-scopes*! '∩ scopes))
+                 (for/list ([s (in-list scopes)])
+                   (linear-mode void void s))))
+
+
+  ;; creates a linear mode that disallows (on teardown) use
+  ;; of variables from outside of the current scope.
+  ;; see unrestricted λ syntax.
+  ;;
+  ;; make-fresh-linear-context : -> linear-mode?
+  (define (make-fresh-linear-mode #:fail [fail fail/unrestricted-fn])
+    (let ([ls #f])
+      (linear-mode (λ () (set! ls (set-copy (linear-scope))))
+                   (λ () (linear-merge-scopes! '∩ (linear-scope) ls #:fail fail))
+                   (linear-scope))))
+
+
+  ;; creates an empty linear mode.
+  ;;
+  ;; make-empty-linear-mode : -> LinearMode
+  (define (make-empty-linear-mode)
+    (linear-mode void void (mutable-free-id-set)))
+
+  (current-mode (make-empty-linear-mode))
+
+  )
+
+;; this function resets the mode to be an empty
+;; linear-mode. this should ONLY be used by tests
+;; that screw up the state of current-mode, and
+;; need to reset it for the next test. this is because
+;; we don't have proper backtracking facilities, so
+;; errors in the middle of inference screw up the
+;; global state
+(define-syntax %%reset-linear-mode
+  (syntax-parser
+    [(_)
+     #:do [(current-mode (make-empty-linear-mode))]
+     #'(#%app- void-)]))
+
+
+
+(define-typed-syntax begin
+  [(begin e ... e0) ≫
+   [⊢ [e ≫ e- ⇐ Unit] ... [e0 ≫ e0- ⇒ σ]]
+   --------
+   [⊢ (begin- e- ... e0-) ⇒ σ]]
+
+  [(begin e ... e0) ⇐ σ ≫
+   [⊢ [e ≫ e- ⇐ Unit] ... [e0 ≫ e0- ⇐ σ]]
+   --------
+   [⊢ (begin- e- ... e0-)]])
+
+
+
+(define-typed-syntax drop
+  [(drop e) ≫
+   [⊢ e ≫ e- ⇒ _]
+   --------
+   [⊢ (#%app- void- e-) ⇒ Unit]])
+
+
+
+(define-typed-syntax #%app
+  [(_) ≫
+   --------
+   [⊢ (#%app- void-) ⇒ Unit]]
+
+  [(#%app fun arg ...) ≫
+   [⊢ fun ≫ fun- ⇒ σ_fun]
+   #:with (~or (~-o σ_in ... σ_out)
+               (~→ σ_in ... σ_out)
+               (~post (~fail "expected linear function type")))
+          #'σ_fun
+   [⊢ [arg ≫ arg- ⇐ σ_in] ...]
+   --------
+   [⊢ (#%app- fun- arg- ...) ⇒ σ_out]])
+
+
+
+(define-typed-variable-syntax
+  #:name #%lin-var
+  [(#%var x- : σ) ≫
+   #:do [(linear-use-var! #'x- #'σ)]
+   ----------
+   [⊢ x- ⇒ σ]])
+
+
+(define-typed-syntax λ
+  #:datum-literals (: !)
+  ;; linear lambda; annotations
+  [(λ ([x:id : T:type] ...) b) ≫
+   #:with [σ ...] #'[T.norm ...]
+   [[x ≫ x- : σ] ... ⊢ b ≫ b- ⇒ σ_out]
+   #:do [(linear-out-of-scope! #'([x- : σ] ...))]
+   --------
+   [⊢ (λ- (x- ...) b-) ⇒ (-o σ ... σ_out)]]
+
+  ;; unrestricted lambda; annotations
+  [(λ ! ([x:id : T:type] ...) b) ≫
+   #:with [σ ...] #'[T.norm ...]
+   #:mode (make-fresh-linear-mode)
+     ([[x ≫ x- : σ] ... ⊢ b ≫ b- ⇒ σ_out]
+      #:do [(linear-out-of-scope! #'([x- : σ] ...))])
+   --------
+   [⊢ (λ- (x- ...) b-) ⇒ (→ σ ... σ_out)]]
+
+  ;; linear lambda; inferred
+  [(λ (x:id ...) b) ⇐ (~-o σ ... σ_out) ≫
+   #:fail-unless (stx-length=? #'[x ...] #'[σ ...])
+                 (num-args-fail-msg this-syntax #'[x ...] #'[σ ...])
+   [[x ≫ x- : σ] ... ⊢ b ≫ b- ⇐ σ_out]
+   #:do [(linear-out-of-scope! #'([x- : σ] ...))]
+   --------
+   [⊢ (λ- (x- ...) b-)]]
+
+  ;; unrestricted lambda; inferred
+  [(λ (x:id ...) b) ⇐ (~→ σ ... σ_out) ≫
+   #:fail-unless (stx-length=? #'[x ...] #'[σ ...])
+                 (num-args-fail-msg this-syntax #'[x ...] #'[σ ...])
+   #:mode (make-fresh-linear-mode)
+     ([[x ≫ x- : σ] ... ⊢ b ≫ b- ⇐ σ_out]
+      #:do [(linear-out-of-scope! #'([x- : σ] ...))])
+   --------
+   [⊢ (λ- (x- ...) b-)]])
+
+
+
+(define-typed-syntax let
+  [(let ([x e] ...) b) ≫
+   [⊢ [e ≫ e- ⇒ σ] ...]
+   [[x ≫ x- : σ] ... ⊢ b ≫ b- ⇒ σ_out]
+   #:do [(linear-out-of-scope! #'([x- : σ] ...))]
+   --------
+   [⊢ (let- ([x- e-] ...) b-) ⇒ σ_out]])
+
+
+
+(define-typed-syntax letrec
+  [(letrec ([b:type-bind rhs] ...) e ...) ≫
+   #:fail-when (ormap linear-type? (stx->list #'[b.type ...]))
+               (format "may not bind linear type ~a in letrec"
+                       (type->str (findf linear-type? (stx->list #'[b.type ...]))))
+   [[b.x ≫ x- : b.type] ...
+    ⊢ [rhs ≫ rhs- ⇐ b.type] ...
+       [(begin e ...) ≫ e- ⇒ σ_out]]
+   #:do [(linear-out-of-scope! #'([x- : b.type] ...))]
+   --------
+   [⊢ (letrec- ([x- rhs-] ...) e-) ⇒ σ_out]])
+
+
+
+(define-typed-syntax if
+  [(_ c e1 e2) ⇐ σ ≫
+   [⊢ c ≫ c- ⇐ Bool]
+   #:mode (make-linear-branch-mode 2)
+     ([⊢ [e1 ≫ e1- ⇐ σ] #:submode branch-then]
+      [⊢ [e2 ≫ e2- ⇐ σ] #:submode branch-else])
+   --------
+   [⊢ (if- c- e1- e2-)]]
+
+  [(_ c e1 e2) ≫
+   [⊢ c ≫ c- ⇐ Bool]
+   #:mode (make-linear-branch-mode 2)
+     ([⊢ [e1 ≫ e1- ⇒ σ1] #:submode branch-then]
+      [⊢ [e2 ≫ e2- ⇒ σ2] #:submode branch-else])
+   --------
+   [⊢ (if- c- e1- e2-) ⇒ (⊔ σ1 σ2)]])
+
+
+
+(define-typed-syntax define
+  #:datum-literals (:)
+  [(define (f [x:id : ty] ...) ret
+     e ...+) ≫
+   --------
+   [≻ (define f : (→ ty ... ret)
+        (letrec ([{f : (→ ty ... ret)}
+                  (λ ! ([x : ty] ...)
+                    (begin e ...))])
+          f))]]
+
+  [(_ x:id : τ:type e:expr) ≫
+   #:fail-when (linear-type? #'τ.norm)
+               "cannot define linear type globally"
+   #:with y (generate-temporary #'x)
+   --------
+   [≻ (begin-
+        (define-syntax x (make-rename-transformer (⊢ y : τ.norm)))
+        (define- y (ann e : τ.norm)))]])

turnstile/examples/mlish+adhoc.rkt

@@ -1,5 +1,5 @@
 #lang turnstile
-(require racket/fixnum racket/flonum)
+(require (postfix-in - racket/fixnum) (postfix-in - racket/flonum))
 
 (extends
  "ext-stlc.rkt"
@@ -338,7 +338,7 @@
    --------
    [≻ (begin-
         (define-syntax- f (make-rename-transformer (⊢ g : ty_fn_expected)))
-        #,(quasisyntax/loc stx
+        #,(quasisyntax/loc this-syntax
             (define- g
               ;(Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))])
               (liftedλ {Y ...} ([x : τ] ... #:where TC ...) 
@@ -387,7 +387,7 @@
                            (format "Improper use of constructor ~a; expected ~a args, got ~a"
                                    (syntax->datum #'Name) (stx-length #'(X ...))
                                    (stx-length (stx-cdr #'stx))))])]
-                       [X (make-rename-transformer (⊢ X #%type))] ...)
+                       [X (make-rename-transformer (mk-type #'X))] ...)
                       (void ty_flat ...)))))
      #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...)))
                 (stx-map 
@@ -658,10 +658,10 @@
    [⊢ e ≫ e- ⇒ τ_e]
    #:with ([(~seq p ...) (~datum ->) e_body] ...) #'clauses
    #:with (pat ...) (stx-map ; use brace to indicate root pattern
-                     (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc stx {pp ...})]))
+                     (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc this-syntax {pp ...})]))
                      #'((p ...) ...))
    #:with ([(~and ctx ([x ty] ...)) pat-] ...) (compile-pats #'(pat ...) #'τ_e)
-   #:with ty-expected (get-expected-type stx)
+   #:with ty-expected (get-expected-type this-syntax)
    [[x ≫ x- : ty] ... ⊢ [(add-expected e_body ty-expected) ≫ e_body- ⇒ ty_body]] ...
    #:when (check-exhaust #'(pat- ...) #'τ_e)
    ----
@@ -671,7 +671,7 @@
    [(_ e with . clauses) ≫
     #:fail-when (null? (syntax->list #'clauses)) "no clauses"
     [⊢ e ≫ e- ⇒ τ_e]
-    #:with t_expect (syntax-property stx 'expected-type) ; propagate inferred type
+    #:with t_expect (syntax-property this-syntax 'expected-type) ; propagate inferred type
     #:with out
     (cond
      [(×? #'τ_e) ;; e is tuple
@@ -730,7 +730,7 @@
         #:with (_ (_ (_ ConsAll) . _) ...) #'info-body
         #:fail-unless (set=? (syntax->datum #'(Clause ...))
                              (syntax->datum #'(ConsAll ...)))
-                      (type-error #:src stx
+                      (type-error #:src this-syntax
                        #:msg (string-append
                               "match: clauses not exhaustive; missing: "
                               (string-join      
@@ -842,7 +842,7 @@
            (expand/df
             #'(lambda (X ...) 
                 (let-syntax 
-                 ([X (make-rename-transformer (assign-type #'X #'#%type))] ...)
+                 ([X (make-rename-transformer (mk-type #'X))] ...)
                  (let-syntax
                   ;; must have this inner macro bc body of lambda may require
                   ;; ops defined by TC to be bound
@@ -896,7 +896,7 @@
       ⇒ (∀ Xs+ (=> TC+ ... (ext-stlc:→ ty+ ... ty-out)))]]
   [(_ ([x:id (~datum :) ty] ...) body) ≫ ; no TC
    #:with (X ...) (compute-tyvars #'(ty ...))
-   #:with (~∀ () (~ext-stlc:→ _ ... body-ty)) (get-expected-type stx)
+   #:with (~∀ () (~ext-stlc:→ _ ... body-ty)) (get-expected-type this-syntax)
    --------
    [≻ (Λ (X ...) (ext-stlc:λ ([x : ty] ...) (add-expected body body-ty)))]]
   [(_ ([x:id (~datum :) ty] ...) body) ≫ ; no TC, ignoring expected-type
@@ -904,12 +904,12 @@
    --------
    [≻ (Λ (X ...) (ext-stlc:λ ([x : ty] ...) body))]]
   [(_ (x:id ...+) body) ≫
-   #:with (~?∀ Xs expected) (get-expected-type stx)
+   #:with (~?∀ Xs expected) (get-expected-type this-syntax)
    #:do [(unless (→? #'expected)
-           (type-error #:src stx #:msg "λ parameters must have type annotations"))]
+           (type-error #:src this-syntax #:msg "λ parameters must have type annotations"))]
    #:with (~ext-stlc:→ arg-ty ... body-ty) #'expected
    #:do [(unless (stx-length=? #'[x ...] #'[arg-ty ...])
-           (type-error #:src stx #:msg
+           (type-error #:src this-syntax #:msg
                        (format "expected a function of ~a arguments, got one with ~a arguments"
                                (stx-length #'[arg-ty ...] #'[x ...]))))]
    --------
@@ -922,10 +922,9 @@
    ;; TODO is there a way to have λs that refer to ids defined after them?
    #'(Λ Xs (ext-stlc:λ x+tys . body))])
 
-
 ;; #%app --------------------------------------------------
 (define-typed-syntax mlish:#%app #:export-as #%app
-  [(_ e_fn . e_args) ≫
+  [(~and this-app (_ e_fn . e_args)) ≫
 ;   #:when (printf "app: ~a\n" (syntax->datum #'(e_fn . e_args)))
    ;; ) compute fn type (ie ∀ and →) 
    [⊢ e_fn ≫ e_fn- ⇒ (~and ty_fn (~∀ Xs ty_fnX))]
@@ -939,7 +938,7 @@
         (syntax-parse #'(e_args tyX_args)
           [((e_arg ...) (τ_inX ... _))
            #:fail-unless (stx-length=? #'(e_arg ...) #'(τ_inX ...))
-           (mk-app-err-msg stx #:expected #'(τ_inX ...) 
+           (mk-app-err-msg #'this-app #:expected #'(τ_inX ...) 
                            #:note "Wrong number of arguments.")
            #:with e_fn/ty (⊢ e_fn- : (ext-stlc:→ . tyX_args))
            #'(ext-stlc:#%app e_fn/ty (add-expected e_arg τ_inX) ...)])]
@@ -949,13 +948,13 @@
       ;; no typeclasses, duplicate code for now --------------------------------
       [(~ext-stlc:→ . tyX_args) 
        ;; ) solve for type variables Xs
-       (define/with-syntax ((e_arg1- ...) (unsolved-X ...) cs) (solve #'Xs #'tyX_args stx))
+       (define/with-syntax ((e_arg1- ...) (unsolved-X ...) cs) (solve #'Xs #'tyX_args #'this-app))
        ;; ) instantiate polymorphic function type
        (syntax-parse (inst-types/cs #'Xs #'cs #'tyX_args)
         [(τ_in ... τ_out) ; concrete types
          ;; ) arity check
          #:fail-unless (stx-length=? #'(τ_in ...) #'e_args)
-                       (mk-app-err-msg stx #:expected #'(τ_in ...)
+                       (mk-app-err-msg #'this-app #:expected #'(τ_in ...)
                         #:note "Wrong number of arguments.")
          ;; ) compute argument types; re-use args expanded during solve
          #:with ([e_arg2- τ_arg2] ...) (let ([n (stx-length #'(e_arg1- ...))])
@@ -967,7 +966,7 @@
          #:with (e_arg- ...) #'(e_arg1- ... e_arg2- ...)
          ;; ) typecheck args
          #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...))
-                       (mk-app-err-msg stx 
+                       (mk-app-err-msg #'this-app
                         #:given #'(τ_arg ...)
                         #:expected 
                         (stx-map 
@@ -986,13 +985,13 @@
                            (syntax-parse #'τ_out
                              [(~?∀ (Y ...) τ_out)
                               (unless (→? #'τ_out)
-                                (raise-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn))
+                                (raise-app-poly-infer-error #'this-app #'(τ_in ...) #'(τ_arg ...) #'e_fn))
                               #'(∀ (unsolved-X ... Y ...) τ_out)]))
          (⊢ (#%app- e_fn- e_arg- ...) : τ_out*)])]
       ;; handle type class constraints ----------------------------------------
       [(~=> TCX ... (~ext-stlc:→ . tyX_args))
        ;; ) solve for type variables Xs
-       (define/with-syntax ((e_arg1- ...) (unsolved-X ...) cs) (solve #'Xs #'tyX_args stx))
+       (define/with-syntax ((e_arg1- ...) (unsolved-X ...) cs) (solve #'Xs #'tyX_args #'this-app))
        ;; ) instantiate polymorphic function type
        (syntax-parse (inst-types/cs #'Xs #'cs #'((TCX ...) tyX_args))
          [((TC ...) (τ_in ... τ_out)) ; concrete types
@@ -1005,7 +1004,7 @@
                          (with-handlers 
                            ([exn:fail:syntax:unbound? 
                              (lambda (e)
-                               (type-error #:src stx
+                               (type-error #:src #'this-app
                                 #:msg 
                                 (format 
                                  (string-append
@@ -1028,9 +1027,12 @@
                                  (stx-map 
                                    (lambda (X ty-solved)
                                      (string-append (type->str X) " : " (type->str ty-solved)))
-                                   #'Xs (lookup-Xs/keep-unsolved #'Xs #'cs)) ", "))))])
+                                   #'Xs (lookup-Xs/keep-unsolved #'Xs #'cs)) ", "))))]
+                            [(lambda _ #t)
+                             (lambda (e) (displayln "other exn")(displayln e)
+                             (error 'lookup))])
                          (lookup-op o tys)))
-                       (stx-map (lambda (o) (format-id stx "~a" o #:source stx)) gen-ops)
+                       (stx-map (lambda (o) (format-id #'this-app "~a" o #:source #'this-app)) gen-ops)
                        (stx-map
                          (syntax-parser
                            [(~∀ _ (~ext-stlc:→ ty_in ... _)) #'(ty_in ...)])
@@ -1038,7 +1040,7 @@
                    #'((generic-op ...) ...) #'((ty-concrete-op ...) ...) #'(TC ...))
           ;; ) arity check
           #:fail-unless (stx-length=? #'(τ_in ...) #'e_args)
-                        (mk-app-err-msg stx #:expected #'(τ_in ...)
+                        (mk-app-err-msg #'this-app #:expected #'(τ_in ...)
                                         #:note "Wrong number of arguments.")
           ;; ) compute argument types; re-use args expanded during solve
           #:with ([e_arg2- τ_arg2] ...) (let ([n (stx-length #'(e_arg1- ...))])
@@ -1050,7 +1052,7 @@
           #:with (e_arg- ...) #'(e_arg1- ... e_arg2- ...)
           ;; ) typecheck args
           #:fail-unless (typechecks? #'(τ_arg ...) #'(τ_in ...))
-                        (mk-app-err-msg stx 
+                        (mk-app-err-msg #'this-app
                          #:given #'(τ_arg ...)
                          #:expected 
                          (stx-map 
@@ -1069,14 +1071,14 @@
                            (syntax-parse #'τ_out
                              [(~?∀ (Y ...) τ_out)
                               (unless (→? #'τ_out)
-                                (raise-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn))
+                                (raise-app-poly-infer-error #'this-app #'(τ_in ...) #'(τ_arg ...) #'e_fn))
                               #'(∀ (unsolved-X ... Y ...) τ_out)]))
           (⊢ ((#%app- e_fn- op ...) e_arg- ...) : τ_out*)])])])]]
   [(_ e_fn . e_args) ≫ ; err case; e_fn is not a function
    [⊢ e_fn ≫ e_fn- ⇒ τ_fn]
    --------
    [#:error 
-    (type-error #:src stx 
+    (type-error #:src #'this-app
                 #:msg (format "Expected expression ~a to have → type, got: ~a"
                               (syntax->datum #'e_fn) (type->str #'τ_fn)))]])
 
@@ -1658,10 +1660,10 @@
   [(_ (Name ty ...) [generic-op concrete-op] ...) ≫
    [⊢ (Name ty ...) ≫ 
       (~=> TC ... (~TC [generic-op-expected ty-concrete-op-expected] ...)) ⇒ _]
-   #:when (TCs-exist? #'(TC ...) #:ctx stx)
+   #:when (TCs-exist? #'(TC ...) #:ctx this-syntax)
    #:fail-unless (set=? (syntax->datum #'(generic-op ...)) 
                         (syntax->datum #'(generic-op-expected ...)))
-                 (type-error #:src stx
+                 (type-error #:src this-syntax
                   #:msg (format "Type class instance ~a incomplete, missing: ~a"
                           (syntax->datum #'(Name ty ...))
                           (string-join
@@ -1711,15 +1713,15 @@
                 (~=> TCsub ... 
                      (~TC [generic-op-expected ty-concrete-op-expected] ...)))
            _)
-           (infers/tyctx+erase #'([X : #%type] ...) #'(TC ... (Name ty ...)))
+           (infers/tyctx+erase #'(X ...) #'(TC ... (Name ty ...)))
    ;; this produces #%app bad stx err, so manually call infer for now
-   ;; [([X ≫ X- : #%type] ...) () ⊢ (TC ... (Name ty ...)) ≫
+   ;; [([X ≫ X- :: #%type] ...) () ⊢ (TC ... (Name ty ...)) ≫
    ;;                                (TC+ ... 
    ;;                                 (~=> TCsub ... 
    ;;                                  (~TC [generic-op-expected ty-concrete-op-expected] ...)))
    ;;                                ⇒ _]
    ;; #:with Xs+ #'(X- ...)
-   #:when (TCs-exist? #'(TCsub ...) #:ctx stx)
+   #:when (TCs-exist? #'(TCsub ...) #:ctx this-syntax)
    ;; simulate as if the declared concrete-op* has TC ... predicates
    ;; TODO: fix this manual deconstruction and assembly
    #:with ((app fa (lam _ ei ty_fn)) ...) #'(ty-concrete-op-expected ...)
@@ -1727,7 +1729,7 @@
           (stx-map (current-type-eval) #'((app fa (lam Xs+ ei (=> TC+ ... ty_fn))) ...))
    #:fail-unless (set=? (syntax->datum #'(generic-op ...)) 
                         (syntax->datum #'(generic-op-expected ...)))
-                 (type-error #:src stx
+                 (type-error #:src this-syntax
                   #:msg (format "Type class instance ~a incomplete, missing: ~a"
                           (syntax->datum #'(Name ty ...))
                           (string-join

turnstile/examples/mlish.rkt

@@ -1,6 +1,7 @@
 #lang turnstile/lang
 (require
- racket/fixnum racket/flonum
+ (postfix-in - racket/fixnum)
+ (postfix-in - racket/flonum)
  (for-syntax macrotypes/type-constraints macrotypes/variance-constraints))
 
 (extends
@@ -86,9 +87,7 @@
   ;; find-free-Xs : (Stx-Listof Id) Type -> (Listof Id)
   ;; finds the free Xs in the type
   (define (find-free-Xs Xs ty)
-    (for/list ([X (in-list (stx->list Xs))]
-               #:when (stx-contains-id? ty X))
-      X))
+    (for/list ([X (in-stx-list Xs)] #:when (stx-contains-id? ty X)) X))
 
   ;; solve for Xs by unifying quantified fn type with the concrete types of stx's args
   ;;   stx = the application stx = (#%app e_fn e_arg ...)
@@ -104,8 +103,9 @@
     (syntax-parse tyXs
       [(τ_inX ... τ_outX)
        ;; generate initial constraints with expected type and τ_outX
-       #:with (~?∀ Vs expected-ty) (and (get-expected-type stx)
-                                        ((current-type-eval) (get-expected-type stx)))
+       #:with (~?∀ Vs expected-ty)
+              (and (get-expected-type stx)
+                   ((current-type-eval) (get-expected-type stx)))
        (define initial-cs
          (if (and (syntax-e #'expected-ty) (stx-null? #'Vs))
              (add-constraints Xs '() (list (list #'expected-ty #'τ_outX)))
@@ -114,8 +114,8 @@
          [(_ e_fn . args)
           (define-values (as- cs)
               (for/fold ([as- null] [cs initial-cs])
-                        ([a (in-list (syntax->list #'args))]
-                         [tyXin (in-list (syntax->list #'(τ_inX ...)))])
+                        ([a (in-stx-list #'args)]
+                         [tyXin (in-stx-list #'(τ_inX ...))])
                 (define ty_in (inst-type/cs Xs cs tyXin))
                 (define/with-syntax [a- ty_a]
                   (infer+erase (if (empty? (find-free-Xs Xs ty_in))
@@ -149,7 +149,7 @@
   (define (covariant-Xs? ty)
     (syntax-parse ((current-type-eval) ty)
       [(~?∀ Xs ty)
-       (for/and ([X (in-list (syntax->list #'Xs))])
+       (for/and ([X (in-stx-list #'Xs)])
          (covariant-X? X #'ty))]))
 
   ;; find-X-variance : Id Type [Variance] -> Variance
@@ -186,7 +186,7 @@
          (for/list ([arg-variance (in-list (get-arg-variances #'tycons))])
            (variance-compose ctxt-variance arg-variance)))
        (for/fold ([acc (make-list (length Xs) irrelevant)])
-                 ([τ (in-list (syntax->list #'[τ ...]))]
+                 ([τ (in-stx-list #'[τ ...])]
                   [τ-ctxt-variance (in-list τ-ctxt-variances)])
          (map variance-join
               acc
@@ -422,7 +422,7 @@
                            (format "Improper use of constructor ~a; expected ~a args, got ~a"
                                    (syntax->datum #'Name) (stx-length #'(X ...))
                                    (stx-length (stx-cdr #'stx))))])]
-                       [X (make-rename-transformer (⊢ X #%type))] ...)
+                       [X (make-rename-transformer (mk-type #'X))] ...)
                       (void ty_flat ...)))))
      #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...)))
                 (stx-map 
@@ -701,10 +701,10 @@
    [⊢ e ≫ e- ⇒ τ_e]
    #:with ([(~seq p ...) -> e_body] ...) #'clauses
    #:with (pat ...) (stx-map ; use brace to indicate root pattern
-                     (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc stx {pp ...})]))
+                     (lambda (ps) (syntax-parse ps [(pp ...) (syntax/loc this-syntax {pp ...})]))
                      #'((p ...) ...))
    #:with ([(~and ctx ([x ty] ...)) pat-] ...) (compile-pats #'(pat ...) #'τ_e)
-   #:with ty-expected (get-expected-type stx)
+   #:with ty-expected (get-expected-type this-syntax)
    [[x ≫ x- : ty] ... ⊢ (add-expected e_body ty-expected) ≫ e_body- ⇒ ty_body] ...
    #:when (check-exhaust #'(pat- ...) #'τ_e)
    --------
@@ -716,7 +716,7 @@
    #:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"
    [⊢ e ≫ e- ⇒ τ_e]
    #:when (×? #'τ_e)
-   #:with t_expect (get-expected-type stx) ; propagate inferred type
+   #:with t_expect (get-expected-type this-syntax) ; propagate inferred type
    #:with ([x ... -> e_body]) #'clauses
    #:with (~× ty ...) #'τ_e
    #:fail-unless (stx-length=? #'(ty ...) #'(x ...))
@@ -733,7 +733,7 @@
    #:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"
    [⊢ e ≫ e- ⇒ τ_e]
    #:when (List? #'τ_e)
-   #:with t_expect (get-expected-type stx) ; propagate inferred type
+   #:with t_expect (get-expected-type this-syntax) ; propagate inferred type
    #:with ([(~or (~and (~and xs [x ...]) (~parse rst (generate-temporary)))
                  (~and (~seq (~seq x ::) ... rst:id) (~parse xs #'())))
             -> e_body] ...+)
@@ -770,7 +770,7 @@
    #:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"
    [⊢ e ≫ e- ⇒ τ_e]
    #:when (and (not (×? #'τ_e)) (not (List? #'τ_e)))
-   #:with t_expect (get-expected-type stx) ; propagate inferred type
+   #:with t_expect (get-expected-type this-syntax) ; propagate inferred type
    #:with ([Clause:id x:id ... 
                       (~optional (~seq #:when e_guard) #:defaults ([e_guard #'(ext-stlc:#%datum . #t)]))
                       -> e_c_un] ...+) ; un = unannotated with expected ty
@@ -780,7 +780,7 @@
    #:with (_ (_ (_ ConsAll) . _) ...) #'info-body
    #:fail-unless (set=? (syntax->datum #'(Clause ...))
                         (syntax->datum #'(ConsAll ...)))
-   (type-error #:src stx
+   (type-error #:src this-syntax
                #:msg (string-append
                       "match: clauses not exhaustive; missing: "
                       (string-join      
@@ -851,22 +851,21 @@
    #:fail-unless (stx-length=? #'[x ...] #'[τ_in ...])
    (format "expected a function of ~a arguments, got one with ~a arguments"
            (stx-length #'[τ_in ...]) (stx-length #'[x ...]))
-   [([X ≫ X- : #%type] ...) ([x ≫ x- : τ_in] ...) ⊢ [body ≫ body- ⇐ τ_out]]
+   [(X ...) ([x ≫ x- : τ_in] ...) ⊢ [body ≫ body- ⇐ τ_out]]
    --------
    [⊢ (λ- (x- ...) body-)]]
   [(λ ([x : τ_x] ...) body) ⇐ (~?∀ (V ...) (~ext-stlc:→ τ_in ... τ_out)) ≫
    #:with [X ...] (compute-tyvars #'(τ_x ...))
-   [([X ≫ X- : #%type] ...) () ⊢ [τ_x ≫ τ_x- ⇐ #%type] ...]
+   [[X ≫ X- :: #%type] ... ⊢ [τ_x ≫ τ_x- ⇐ :: #%type] ...]
    [τ_in τ⊑ τ_x- #:for x] ...
    ;; TODO is there a way to have λs that refer to ids defined after them?
-   [([V ≫ V- : #%type] ... [X- ≫ X-- : #%type] ...) ([x ≫ x- : τ_x-] ...)
-    ⊢ body ≫ body- ⇐ τ_out]
+   [(V ... X- ...) ([x ≫ x- : τ_x-] ...) ⊢ body ≫ body- ⇐ τ_out]
    --------
    [⊢ (λ- (x- ...) body-)]]
   [(λ ([x : τ_x] ...) body) ≫
    #:with [X ...] (compute-tyvars #'(τ_x ...))
    ;; TODO is there a way to have λs that refer to ids defined after them?
-   [([X ≫ X- : #%type] ...) ([x ≫ x- : τ_x] ...) ⊢ body ≫ body- ⇒ τ_body]
+   [([X ≫ X- :: #%type] ...) ([x ≫ x- : τ_x] ...) ⊢ body ≫ body- ⇒ τ_body]
    #:with [τ_x* ...] (inst-types/cs #'[X ...] #'([X X-] ...) #'[τ_x ...])
    #:with τ_fn (add-orig #'(?∀ (X- ...) (ext-stlc:→ τ_x* ... τ_body))
                          #`(→ #,@(stx-map get-orig #'[τ_x* ...]) #,(get-orig #'τ_body)))
@@ -880,7 +879,7 @@
    ;; compute fn type (ie ∀ and →)
    [⊢ e_fn ≫ e_fn- ⇒ (~?∀ Xs (~ext-stlc:→ . tyX_args))]
    ;; solve for type variables Xs
-   #:with [[e_arg- ...] Xs* cs] (solve #'Xs #'tyX_args stx)
+   #:with [[e_arg- ...] Xs* cs] (solve #'Xs #'tyX_args this-syntax)
    ;; instantiate polymorphic function type
    #:with [τ_in ... τ_out] (inst-types/cs #'Xs* #'cs #'tyX_args)
    #:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out)
@@ -896,13 +895,13 @@
                      (syntax-parse #'τ_out
                        [(~?∀ (Y ...) τ_out)
                         #:fail-unless (→? #'τ_out)
-                        (mk-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn)
+                        (mk-app-poly-infer-error this-syntax #'(τ_in ...) #'(τ_arg ...) #'e_fn)
                         (for ([X (in-list (syntax->list #'(unsolved-X ...)))])
                           (unless (covariant-X? X #'τ_out)
                             (raise-syntax-error
                              #f
-                             (mk-app-poly-infer-error stx #'(τ_in ...) #'(τ_arg ...) #'e_fn)
-                             stx)))
+                             (mk-app-poly-infer-error this-syntax #'(τ_in ...) #'(τ_arg ...) #'e_fn)
+                             this-syntax)))
                         #'(∀ (unsolved-X ... Y ...) τ_out)]))
    --------
    [⊢ (#%app- e_fn- e_arg- ...) ⇒ τ_out*]])

turnstile/examples/stlc+effect.rkt

@@ -80,7 +80,7 @@
    --------
    [⊢ (#%app- box- e-)
        (⇒ : (Ref τ))
-       (⇒ ν (locs #,(syntax-position stx) ns ...))
+       (⇒ ν (locs #,(syntax-position this-syntax) ns ...))
        (⇒ := (locs as ...))
        (⇒ ! (locs ds ...))]])
 (define-typed-syntax deref
@@ -95,7 +95,7 @@
        (⇒ : ty)
        (⇒ ν (locs ns ...))
        (⇒ := (locs as ...))
-       (⇒ ! (locs #,(syntax-position stx) ds ...))]])
+       (⇒ ! (locs #,(syntax-position this-syntax) ds ...))]])
 (define-typed-syntax := #:literals (:=)
   [(_ e_ref e) ≫
    [⊢ e_ref ≫ e_ref-
@@ -112,6 +112,6 @@
    [⊢ (#%app- set-box!- e_ref- e-)
        (⇒ : Unit)
        (⇒ ν (locs ns1 ... ns2 ...))
-       (⇒ := (locs #,(syntax-position stx) as1 ... as2 ...))
+       (⇒ := (locs #,(syntax-position this-syntax) as1 ... as2 ...))
        (⇒ ! (locs ds1 ... ds2 ...))]])
 

turnstile/examples/stlc+rec-iso.rkt

@@ -23,7 +23,6 @@
   [⊢ e- ⇒ #,(subst #'τ.norm #'tv #'τ_body)])
 (define-typed-syntax (fld τ:type-ann e) ≫
   #:with (~μ (tv) τ_body) #'τ.norm
-  #:with τ_e (subst #'τ.norm #'tv #'τ_body)
-  [⊢ e ≫ e- ⇐ τ_e]
+  [⊢ e ≫ e- ⇐ #,(subst #'τ.norm #'tv #'τ_body)]
   --------
   [⊢ e- ⇒ τ.norm])

turnstile/examples/stlc+reco+sub.rkt

@@ -49,4 +49,4 @@
          #'([l τl] ...))]
        [_ #f])))
   (current-sub? sub?)
-  (current-typecheck-relation (current-sub?)))
+  (current-typecheck-relation sub?))

turnstile/examples/stlc+reco+var.rkt

@@ -122,7 +122,7 @@
    (∨-ref #'τ #'l #:else
           (λ () (raise-syntax-error #f
                    (format "~a field does not exist" (syntax->datum #'l))
-                   stx)))
+                   this-syntax)))
    [⊢ e ≫ e- ⇐ τ_e]
    --------
    [⊢ (list- 'l e)]])

turnstile/examples/stlc+sub.rkt

@@ -52,6 +52,7 @@
         (Top? τ2)))
   (define current-sub? (make-parameter sub?))
   (current-typecheck-relation sub?)
+
   (define (subs? τs1 τs2)
     (and (stx-length=? τs1 τs2)
          (stx-andmap (current-sub?) τs1 τs2)))

turnstile/examples/stlc+union+case.rkt

@@ -99,7 +99,5 @@
   (current-typecheck-relation sub?)
   (define (subs? τs1 τs2)
     (and (stx-length=? τs1 τs2)
-         (stx-andmap (current-sub?) τs1 τs2)))
-  
-  )
+         (stx-andmap (current-sub?) τs1 τs2))))
                    

turnstile/examples/stlc+union.rkt

@@ -3,6 +3,8 @@
  #:except #%app #%datum + add1 sub1 *
           Int Int? ~Int Float Float? ~Float Bool ~Bool Bool?)
 
+(require (for-syntax "util/filter-maximal.rkt"))
+
 ;; Simply-Typed Lambda Calculus, plus union types
 ;; Types:
 ;; - types from and ext+stlc.rkt
@@ -27,7 +29,8 @@
                     [* : (→ Num Num Num)]
                     [add1 : (→ Int Int)]
                     [sub1 : (→ Int Int)])
-         #%datum #%app)
+         #%datum #%app
+         (for-syntax ~PosInt ~Zero ~NegInt ~True ~False))
 
 (define-syntax define-named-type-alias
   (syntax-parser
@@ -44,11 +47,9 @@
 
 (define-for-syntax (prune+sort tys)
   (stx-sort 
-   (remove-duplicates 
+   (filter-maximal 
     (stx->list tys)
-    ;; remove dups keeps first element
-    ;; but we want to keep supertype
-    (lambda (x y) (typecheck? y x)))))
+    typecheck?)))
   
 (define-syntax (U stx)
   (syntax-parse stx
@@ -57,8 +58,8 @@
      #:with ((~or (~U* ty1- ...) ty2-) ...) (stx-map (current-type-eval) #'tys)
      #:with tys- (prune+sort #'(ty1- ... ... ty2- ...))
      (if (= 1 (stx-length #'tys-))
-         (stx-car #'tys)
-         #'(U* . tys-))]))
+         (stx-car #'tys-)
+         (syntax/loc stx (U* . tys-)))]))
 (define-syntax Bool
   (make-variable-like-transformer
    (add-orig #'(U False True) #'Bool)))

turnstile/examples/sysf.rkt

@@ -14,17 +14,14 @@
 (define-binding-type ∀)
 
 (define-typed-syntax (Λ (tv:id ...) e) ≫
-  [([tv ≫ tv- : #%type] ...) () ⊢ e ≫ e- ⇒ τ]
+  [[tv ≫ tv- :: #%type] ... ⊢ e ≫ e- ⇒ τ]
   --------
   [⊢ e- ⇒ (∀ (tv- ...) τ)])
 
 (define-typed-syntax inst
   [(_ e τ:type ...) ≫
    [⊢ e ≫ e- ⇒ (~∀ tvs τ_body)]
-   #:with τ_inst (substs #'(τ.norm ...) #'tvs #'τ_body)
    --------
-   [⊢ e- ⇒ τ_inst]]
-  [(_ e) ≫
-   --------
-   [≻ e]])
+   [⊢ e- ⇒ #,(substs #'(τ.norm ...) #'tvs #'τ_body)]]
+  [(_ e) ≫ --- [≻ e]])
 

turnstile/examples/tests/dep-tests.rkt

@@ -0,0 +1,96 @@
+#lang s-exp "../dep.rkt"
+(require "rackunit-typechecking.rkt")
+
+; Π → λ ∀ ≻ ⊢ ≫ ⇒
+
+;; examples from Prabhakar's Proust paper
+
+(check-type (λ ([x : *]) x) : (Π ([x : *]) *))
+(typecheck-fail ((λ ([x : *]) x) (λ ([x : *]) x))
+ #:verb-msg "expected *, given (Π ([x : *]) *)")
+
+;; transitivity of implication
+(check-type (λ ([A : *][B : *][C : *])
+              (λ ([f : (→ B C)])
+                (λ ([g : (→ A B)])
+                  (λ ([x : A])
+                    (f (g x))))))
+            : (∀ (A B C) (→ (→ B C) (→ (→ A B) (→ A C)))))
+; unnested
+(check-type (λ ([A : *][B : *][C : *])
+              (λ ([f : (→ B C)][g : (→ A B)])
+                (λ ([x : A])
+                  (f (g x)))))
+            : (∀ (A B C) (→ (→ B C) (→ A B) (→ A C))))
+;; no annotations
+(check-type (λ (A B C)
+              (λ (f) (λ (g) (λ (x)
+                (f (g x))))))
+            : (∀ (A B C) (→ (→ B C) (→ (→ A B) (→ A C)))))
+(check-type (λ (A B C)
+              (λ (f g)
+                (λ (x)
+                  (f (g x)))))
+            : (∀ (A B C) (→ (→ B C) (→ A B) (→ A C))))
+;; TODO: partial annotations
+
+;; booleans -------------------------------------------------------------------
+
+;; Bool type
+(define-type-alias Bool (∀ (A) (→ A A A)))
+
+;; Bool terms
+(define T (λ ([A : *]) (λ ([x : A][y : A]) x)))
+(define F (λ ([A : *]) (λ ([x : A][y : A]) y)))
+(check-type T : Bool)
+(check-type F : Bool)
+(define and (λ ([x : Bool][y : Bool]) ((x Bool) y F)))
+(check-type and : (→ Bool Bool Bool))
+
+;; And type constructor, ie type-level fn
+(define-type-alias And
+  (λ ([A : *][B : *])
+    (∀ (C) (→ (→ A B C) C))))
+(check-type And : (→ * * *))
+
+;; And type intro
+(define ∧
+  (λ ([A : *][B : *])
+    (λ ([x : A][y : B])
+      (λ ([C : *])
+        (λ ([f : (→ A B C)])
+          (f x y))))))
+(check-type ∧ : (∀ (A B) (→ A B (And A B))))
+
+;; And type elim
+(define proj1
+  (λ ([A : *][B : *])
+    (λ ([e∧ : (And A B)])
+      ((e∧ A) (λ ([x : A][y : B]) x)))))
+(define proj2
+  (λ ([A : *][B : *])
+    (λ ([e∧ : (And A B)])
+      ((e∧ B) (λ ([x : A][y : B]) y)))))
+;; bad proj2: (e∧ A) should be (e∧ B)
+(typecheck-fail
+ (λ ([A : *][B : *])
+   (λ ([e∧ : (And A B)])
+     ((e∧ A) (λ ([x : A][y : B]) y))))
+ #:verb-msg
+ "expected (→ A B C), given (Π ((x : A) (y : B)) B)")
+(check-type proj1 : (∀ (A B) (→ (And A B) A)))
+(check-type proj2 : (∀ (A B) (→ (And A B) B)))
+
+;((((conj q) p) (((proj2 p) q) a)) (((proj1 p) q) a)))))
+(define and-commutes
+  (λ ([A : *][B : *])
+    (λ ([e∧ : (And A B)])
+      ((∧ B A) ((proj2 A B) e∧) ((proj1 A B) e∧)))))
+;; bad and-commutes, dont flip A and B: (→ (And A B) (And A B))
+(typecheck-fail
+ (λ ([A : *][B : *])
+   (λ ([e∧ : (And A B)])
+     ((∧ A B) ((proj2 A B) e∧) ((proj1 A B) e∧))))
+ #:verb-msg
+ "#%app: type mismatch: expected A, given C") ; TODO: err msg should be B not C?
+(check-type and-commutes : (∀ (A B) (→ (And A B) (And B A))))

turnstile/examples/tests/ext-stlc-tests.rkt

@@ -52,8 +52,8 @@
 (typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier")
 (typecheck-fail (ann 1 : 1) #:with-msg "not a well-formed type")
 (typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a well-formed type")
-(typecheck-fail (ann Int : Int)
-                #:with-msg "ann: type mismatch: expected Int, given #%type\n *expression: Int")
+(typecheck-fail (ann Bool : Int)
+                #:with-msg "ann: type mismatch: expected Int, given an invalid expression\n *expression: Bool")
 
 ; let
 (check-type (let () (+ 1 1)) : Int ⇒ 2)

turnstile/examples/tests/fomega-no-reuse-tests-old.rkt

@@ -0,0 +1,213 @@
+#lang s-exp "../fomega-no-reuse-old.rkt"
+(require "rackunit-typechecking.rkt")
+
+;; similar to fomega-tests.rkt, but with ': kind key
+
+(check-type Int : ★)
+(check-type String : ★)
+(typecheck-fail →)
+(check-type (→ Int Int) : ★)
+(typecheck-fail (→ →))
+(typecheck-fail (→ 1))
+(check-type 1 : Int)
+
+(typecheck-fail (tyλ ([x : ★]) 1) #:with-msg "not a valid type: 1")
+
+(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-not-type (Λ ([X : ★]) (λ ([x : X]) x)) :
+                (∀ ([X : (★ ★)]) (→ X X)))
+
+;(check-type (∀ ([t : ★]) (→ t t)) : ★)
+(check-type (∀ ([t : ★]) (→ t t)) : (★ ★))
+(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★)
+
+(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+
+(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x)))
+           : (∀ ([X : ★]) (→ X X)))
+(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x))))
+
+(check-type (tyλ ([t : ★]) t) : (⇒ ★ ★))
+(check-type (tyλ ([t : ★] [s : ★]) t) : (⇒ ★ ★ ★))
+(check-type (tyλ ([t : ★]) (tyλ ([s : ★]) t)) : (⇒ ★ (⇒ ★ ★)))
+(check-type (tyλ ([t : (⇒ ★ ★)]) t) : (⇒ (⇒ ★ ★) (⇒ ★ ★)))
+(check-type (tyλ ([t : (⇒ ★ ★ ★)]) t) : (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★)))
+(check-type (tyλ ([arg : ★] [res : ★]) (→ arg res)) : (⇒ ★ ★ ★))
+
+(check-type (tyapp (tyλ ([t : ★]) t) Int) : ★)
+(check-type (λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) : (→ Int Int))
+(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1)
+(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
+(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
+(typecheck-fail ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) "a-string"))
+
+;; partial-apply →
+(check-type (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)
+            : (⇒ ★ ★))
+;; f's type must have kind ★
+(typecheck-fail (λ ([f : (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)]) f))
+(check-type (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) :
+            (∀ ([tyf : (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String))))
+(check-type (inst
+             (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+             (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+            : (→ (→ Int String) (→ Int String)))
+(typecheck-fail
+ (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)
+ #:with-msg "inst: type mismatch.*expected:.*★.*given:.*Int.*expressions: 1")
+
+(typecheck-fail
+ (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+ #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
+;; applied f too early
+(typecheck-fail
+ (inst
+  (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+  (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+ #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
+(check-type ((inst
+              (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+             (λ ([x : Int]) "int")) : (→ Int String))
+(check-type (((inst
+               (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+              (λ ([x : Int]) "int")) 1) : String ⇒ "int")
+
+;; tapl examples, p441
+(typecheck-fail
+ (define-type-alias tmp 1)
+ #:with-msg "not a valid type: 1")
+(define-type-alias Id (tyλ ([X : ★]) X))
+(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int))
+(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (tyapp Id String)) Int))
+(check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int String) Int))
+(check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int (tyapp Id String)) Int))
+(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (tyapp Id Int) (tyapp Id String)) Int))
+(check-type (λ ([f : (→ Int String)]) 1) : (→ (→ (tyapp Id Int) String) Int))
+(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (→ Int String) Int))
+(check-type (λ ([f : (→ Int String)]) 1) : (→ (tyapp Id (→ Int String)) Int))
+(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (→ Int String)) Int))
+(check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (tyapp Id (→ Int String))) Int))
+
+;; tapl examples, p451
+(define-type-alias Pair (tyλ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X))))
+
+;(check-type Pair : (⇒ ★ ★ ★))
+(check-type Pair : (⇒ ★ ★ (★ ★)))
+
+(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X)))
+; parametric pair constructor
+(check-type
+ (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ : (∀ ([X : ★][Y : ★]) (→ X Y (tyapp Pair X Y))))
+; concrete Pair Int String constructor
+(check-type
+ (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+       Int String)
+ : (→ Int String (tyapp Pair Int String)))
+;; Pair Int String value
+(check-type
+ ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+       Int String) 1 "1")
+ : (tyapp Pair Int String))
+;; fst: parametric
+(check-type
+ (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+ : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) X)))
+;; fst: concrete Pair Int String accessor
+(check-type
+ (inst
+  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+  Int String)
+ : (→ (tyapp Pair Int String) Int))
+;; apply fst
+(check-type
+ ((inst
+   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+   Int String)
+  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+         Int String) 1 "1"))
+ : Int ⇒ 1)
+;; snd
+(check-type
+ (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+ : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) Y)))
+(check-type
+ (inst
+  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+  Int String)
+ : (→ (tyapp Pair Int String) String))
+(check-type
+ ((inst
+   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+   Int String)
+  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+         Int String) 1 "1"))
+ : String ⇒ "1")
+
+;; sysf tests wont work, unless augmented with kinds
+(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+
+(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true
+(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false
+(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv
+
+(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2)))))
+
+(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4)))))
+
+(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4)))))
+
+(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
+(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int)
+; first inst should be discarded
+(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
+; second inst is discarded
+(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
+
+;; polymorphic arguments
+(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t)))
+(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s)))
+(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t))))
+(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t))))
+(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s))))
+(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u))))
+(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u))))
+(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x)))
+(typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1))
+(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u)))
+(check-type
+ (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
+(check-type
+ ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10)
+ : Int ⇒ 10)
+(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)))
+(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int))
+(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10))
+             (Λ ([s : ★]) (λ ([y : s]) y)))
+             : Int ⇒ 10)
+
+
+;; previous tests -------------------------------------------------------------
+(check-type 1 : Int)
+(check-not-type 1 : (→ Int Int))
+;(typecheck-fail #f) ; unsupported literal
+(check-type (λ ([x : Int] [y : Int]) x) : (→ Int Int Int))
+(check-not-type (λ ([x : Int]) x) : Int)
+(check-type (λ ([x : Int]) x) : (→ Int Int))
+(check-type (λ ([f : (→ Int Int)]) 1) : (→ (→ Int Int) Int))
+(check-type ((λ ([x : Int]) x) 1) : Int ⇒ 1)
+;(typecheck-fail ((λ ([x : Bool]) x) 1)) ; Bool is not valid type
+;(typecheck-fail (λ ([x : Bool]) x)) ; Bool is not valid type
+(typecheck-fail (λ ([f : Int]) (f 1 2))) ; applying f with non-fn type
+(check-type (λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y))
+            : (→ (→ Int Int Int) Int Int Int))
+(check-type ((λ ([f : (→ Int Int Int)] [x : Int] [y : Int]) (f x y)) + 1 2) : Int ⇒ 3)
+(typecheck-fail (+ 1 (λ ([x : Int]) x))) ; adding non-Int
+(typecheck-fail (λ ([x : (→ Int Int)]) (+ x x))) ; x should be Int
+(typecheck-fail ((λ ([x : Int] [y : Int]) y) 1)) ; wrong number of args
+(check-type ((λ ([x : Int]) (+ x x)) 10) : Int ⇒ 20)

turnstile/examples/tests/fomega-no-reuse-tests.rkt

@@ -1,84 +1,84 @@
 #lang s-exp "../fomega-no-reuse.rkt"
 (require "rackunit-typechecking.rkt")
 
-;; identical to fomega-tests.rkt
+;; mostly identical to fomega-tests.rkt
 
-(check-type Int : ★)
-(check-type String : ★)
+(check-type Int :: ★)
+(check-type String :: ★)
 (typecheck-fail →)
-(check-type (→ Int Int) : ★)
+(check-type (→ Int Int) :: ★)
 (typecheck-fail (→ →))
 (typecheck-fail (→ 1))
 (check-type 1 : Int)
 
-(typecheck-fail (tyλ ([x : ★]) 1) #:with-msg "not a valid type: 1")
+(typecheck-fail (tyλ ([x :: ★]) 1) #:with-msg "not a valid type: 1")
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
-(check-not-type (Λ ([X : ★]) (λ ([x : X]) x)) :
-                (∀ ([X : (★ ★)]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
+(check-not-type (Λ ([X :: ★]) (λ ([x : X]) x)) :
+                (∀ ([X :: (★ ★)]) (→ X X)))
 
-;(check-type (∀ ([t : ★]) (→ t t)) : ★)
-(check-type (∀ ([t : ★]) (→ t t)) : (★ ★))
-(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★)
+;(check-type (∀ ([t :: ★]) (→ t t)) :: ★)
+(check-type (∀ ([t :: ★]) (→ t t)) :: (★ ★))
+(check-type (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)) :: ★)
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x)))
-           : (∀ ([X : ★]) (→ X X)))
-(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x))))
+(check-type ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X :: ★]) (λ ([x : X]) x)))
+           : (∀ ([X :: ★]) (→ X X)))
+(typecheck-fail ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x))))
 
-(check-type (tyλ ([t : ★]) t) : (⇒ ★ ★))
-(check-type (tyλ ([t : ★] [s : ★]) t) : (⇒ ★ ★ ★))
-(check-type (tyλ ([t : ★]) (tyλ ([s : ★]) t)) : (⇒ ★ (⇒ ★ ★)))
-(check-type (tyλ ([t : (⇒ ★ ★)]) t) : (⇒ (⇒ ★ ★) (⇒ ★ ★)))
-(check-type (tyλ ([t : (⇒ ★ ★ ★)]) t) : (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★)))
-(check-type (tyλ ([arg : ★] [res : ★]) (→ arg res)) : (⇒ ★ ★ ★))
+(check-type (tyλ ([t :: ★]) t) :: (⇒ ★ ★))
+(check-type (tyλ ([t :: ★] [s :: ★]) t) :: (⇒ ★ ★ ★))
+(check-type (tyλ ([t :: ★]) (tyλ ([s :: ★]) t)) :: (⇒ ★ (⇒ ★ ★)))
+(check-type (tyλ ([t :: (⇒ ★ ★)]) t) :: (⇒ (⇒ ★ ★) (⇒ ★ ★)))
+(check-type (tyλ ([t :: (⇒ ★ ★ ★)]) t) :: (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★)))
+(check-type (tyλ ([arg :: ★] [res :: ★]) (→ arg res)) :: (⇒ ★ ★ ★))
 
-(check-type (tyapp (tyλ ([t : ★]) t) Int) : ★)
-(check-type (λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) : (→ Int Int))
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1)
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
-(typecheck-fail ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) "a-string"))
+(check-type (tyapp (tyλ ([t :: ★]) t) Int) :: ★)
+(check-type (λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) x) : (→ Int Int))
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) x) 1) : Int ⇒ 1)
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
+(typecheck-fail ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ 1 x)) "a-string"))
 
 ;; partial-apply →
-(check-type (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)
-            : (⇒ ★ ★))
+(check-type (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int)
+            :: (⇒ ★ ★))
 ;; f's type must have kind ★
-(typecheck-fail (λ ([f : (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)]) f))
-(check-type (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) :
-            (∀ ([tyf : (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String))))
+(typecheck-fail (λ ([f : (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int)]) f))
+(check-type (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) :
+            (∀ ([tyf :: (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String))))
 (check-type (inst
-             (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-             (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+             (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+             (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
             : (→ (→ Int String) (→ Int String)))
-(typecheck-fail
- (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)
- #:with-msg "inst: type mismatch.*expected:.*★.*given:.*Int.*expressions: 1")
+(typecheck-fail ; TODO: fix err msg: "given an invalid expression"
+ (inst (Λ ([X :: ★]) (λ ([x : X]) x)) 1)
+ #:with-msg "inst:.*not a valid type: 1") 
 
 (typecheck-fail
- (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+ (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
  #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
 ;; applied f too early
 (typecheck-fail
  (inst
-  (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
-  (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+  (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+  (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
  #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
 (check-type ((inst
-              (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+              (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
              (λ ([x : Int]) "int")) : (→ Int String))
 (check-type (((inst
-               (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+               (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
               (λ ([x : Int]) "int")) 1) : String ⇒ "int")
 
 ;; tapl examples, p441
 (typecheck-fail
  (define-type-alias tmp 1)
  #:with-msg "not a valid type: 1")
-(define-type-alias Id (tyλ ([X : ★]) X))
+(define-type-alias Id (tyλ ([X :: ★]) X))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (tyapp Id String)) Int))
 (check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int String) Int))
@@ -91,104 +91,104 @@
 (check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (tyapp Id (→ Int String))) Int))
 
 ;; tapl examples, p451
-(define-type-alias Pair (tyλ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X))))
+(define-type-alias Pair (tyλ ([A :: ★] [B :: ★]) (∀ ([X :: ★]) (→ (→ A B X) X))))
 
-;(check-type Pair : (⇒ ★ ★ ★))
-(check-type Pair : (⇒ ★ ★ (★ ★)))
+;(check-type Pair :: (⇒ ★ ★ ★))
+(check-type Pair :: (⇒ ★ ★ (★ ★)))
 
-(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X)))
+(check-type (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X :: ★][Y :: ★]) (→ X Y X)))
 ; parametric pair constructor
 (check-type
- (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
- : (∀ ([X : ★][Y : ★]) (→ X Y (tyapp Pair X Y))))
+ (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ : (∀ ([X :: ★][Y :: ★]) (→ X Y (tyapp Pair X Y))))
 ; concrete Pair Int String constructor
 (check-type
- (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ (inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String)
  : (→ Int String (tyapp Pair Int String)))
 ;; Pair Int String value
 (check-type
- ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String) 1 "1")
  : (tyapp Pair Int String))
 ;; fst: parametric
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
- : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) X)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (tyapp Pair X Y) X)))
 ;; fst: concrete Pair Int String accessor
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
   Int String)
  : (→ (tyapp Pair Int String) Int))
 ;; apply fst
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : Int ⇒ 1)
 ;; snd
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
- : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) Y)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (tyapp Pair X Y) Y)))
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
   Int String)
  : (→ (tyapp Pair Int String) String))
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : String ⇒ "1")
 
 ;; sysf tests wont work, unless augmented with kinds
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X :: ★]) (→ X X X))) ; true
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X :: ★]) (→ X X X))) ; false
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y :: ★]) (→ Y Y Y))) ; false, alpha equiv
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t1 :: ★]) (∀ ([t2 :: ★]) (→ t1 (→ t2 t2)))))
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t3 :: ★]) (∀ ([t4 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4)))))
+(check-not-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t4 :: ★]) (∀ ([t3 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
-(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int)
+(check-type (inst (Λ ([t :: ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
+(check-type (inst (Λ ([t :: ★]) 1) (→ Int Int)) : Int)
 ; first inst should be discarded
-(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
+(check-type (inst (inst (Λ ([t :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
 ; second inst is discarded
-(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
+(check-type (inst (inst (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
 
 ;; polymorphic arguments
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t)))
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s)))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u))))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u))))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([t :: ★]) (→ t t)))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([s :: ★]) (→ s s)))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([s :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([s :: ★]) (→ s s))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([u :: ★]) (→ u u))))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) x) : (→ (∀ ([s :: ★]) (→ s s)) (∀ ([u :: ★]) (→ u u))))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x)))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u)))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) : (∀ ([u :: ★]) (→ u u)))
 (check-type
- (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
+ (inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
 (check-type
- ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10)
+ ((inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) 10)
  : Int ⇒ 10)
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10))
-             (Λ ([s : ★]) (λ ([y : s]) y)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t :: ★]) (→ t t)) Int))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10))
+             (Λ ([s :: ★]) (λ ([y : s]) y)))
              : Int ⇒ 10)
 
 

turnstile/examples/tests/fomega-tests.rkt

@@ -1,82 +1,84 @@
 #lang s-exp "../fomega.rkt"
 (require "rackunit-typechecking.rkt")
 
-(check-type Int : ★)
-(check-type String : ★)
+;; ok to conflate check-kind and check-type bc
+;; kindcheck? does not require special cases
+(check-type Int :: ★)
+(check-type String :: ★)
 (typecheck-fail →)
-(check-type (→ Int Int) : ★)
+(check-type (→ Int Int) :: ★)
 (typecheck-fail (→ →))
 (typecheck-fail (→ 1))
 (check-type 1 : Int)
 
-(typecheck-fail (tyλ ([x : ★]) 1) #:with-msg "not a valid type: 1")
+(typecheck-fail (tyλ ([x :: ★]) 1) #:with-msg "not a valid type: 1")
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
-(check-not-type (Λ ([X : ★]) (λ ([x : X]) x)) :
-                (∀ ([X : (∀★ ★)]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
+(check-not-type (Λ ([X :: ★]) (λ ([x : X]) x)) :
+                (∀ ([X :: (∀★ ★)]) (→ X X)))
 
-;(check-type (∀ ([t : ★]) (→ t t)) : ★)
-(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★))
-(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★)
+;(check-type (∀ ([t :: ★]) (→ t t)) :: ★)
+(check-type (∀ ([t :: ★]) (→ t t)) :: (∀★ ★))
+(check-type (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)) :: ★)
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x)))
-            : (∀ ([X : ★]) (→ X X)))
-(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x))))
+(check-type ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X :: ★]) (λ ([x : X]) x)))
+            : (∀ ([X :: ★]) (→ X X)))
+(typecheck-fail ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X : (⇒ ★ ★)]) (λ ([x : X]) x))))
 
-(check-type (tyλ ([t : ★]) t) : (⇒ ★ ★))
-(check-type (tyλ ([t : ★] [s : ★]) t) : (⇒ ★ ★ ★))
-(check-type (tyλ ([t : ★]) (tyλ ([s : ★]) t)) : (⇒ ★ (⇒ ★ ★)))
-(check-type (tyλ ([t : (⇒ ★ ★)]) t) : (⇒ (⇒ ★ ★) (⇒ ★ ★)))
-(check-type (tyλ ([t : (⇒ ★ ★ ★)]) t) : (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★)))
-(check-type (tyλ ([arg : ★] [res : ★]) (→ arg res)) : (⇒ ★ ★ ★))
+(check-type (tyλ ([t :: ★]) t) :: (⇒ ★ ★))
+(check-type (tyλ ([t :: ★] [s :: ★]) t) :: (⇒ ★ ★ ★))
+(check-type (tyλ ([t :: ★]) (tyλ ([s :: ★]) t)) :: (⇒ ★ (⇒ ★ ★)))
+(check-type (tyλ ([t :: (⇒ ★ ★)]) t) :: (⇒ (⇒ ★ ★) (⇒ ★ ★)))
+(check-type (tyλ ([t :: (⇒ ★ ★ ★)]) t) :: (⇒ (⇒ ★ ★ ★) (⇒ ★ ★ ★)))
+(check-type (tyλ ([arg :: ★] [res :: ★]) (→ arg res)) :: (⇒ ★ ★ ★))
 
-(check-type (tyapp (tyλ ([t : ★]) t) Int) : ★)
-(check-type (λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) : (→ Int Int))
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1)
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
-(check-type ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
-(typecheck-fail ((λ ([x : (tyapp (tyλ ([t : ★]) t) Int)]) (+ 1 x)) "a-string"))
+(check-type (tyapp (tyλ ([t :: ★]) t) Int) :: ★)
+(check-type (λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) x) : (→ Int Int))
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) x) 1) : Int ⇒ 1)
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
+(check-type ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
+(typecheck-fail ((λ ([x : (tyapp (tyλ ([t :: ★]) t) Int)]) (+ 1 x)) "a-string"))
 
 ;; partial-apply →
-(check-type (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)
-            : (⇒ ★ ★))
+(check-type (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int)
+            :: (⇒ ★ ★))
 ;; f's type must have kind ★
-(typecheck-fail (λ ([f : (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int)]) f))
-(check-type (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) :
-            (∀ ([tyf : (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String))))
+(typecheck-fail (λ ([f : (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int)]) f))
+(check-type (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f)) :
+            (∀ ([tyf :: (⇒ ★ ★)]) (→ (tyapp tyf String) (tyapp tyf String))))
 (check-type (inst
-             (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-             (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+             (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+             (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
             : (→ (→ Int String) (→ Int String)))
 (typecheck-fail
- (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1)
- #:with-msg "inst: type mismatch: expected ★, given Int\n *expression: 1")
+ (inst (Λ ([X :: ★]) (λ ([x : X]) x)) 1)
+ #:with-msg "inst:.*not a valid type: 1")
 
 (typecheck-fail
- (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+ (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
  #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
 ;; applied f too early
 (typecheck-fail
  (inst
-  (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
-  (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+  (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) (f 1)))
+  (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
  #:with-msg "Expected → type, got: \\(tyapp tyf String\\)")
 (check-type ((inst
-              (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+              (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
              (λ ([x : Int]) "int")) : (→ Int String))
 (check-type (((inst
-               (Λ ([tyf : (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
-              (tyapp (tyλ ([arg : ★]) (tyλ ([res : ★]) (→ arg res))) Int))
+               (Λ ([tyf :: (⇒ ★ ★)]) (λ ([f : (tyapp tyf String)]) f))
+              (tyapp (tyλ ([arg :: ★]) (tyλ ([res :: ★]) (→ arg res))) Int))
               (λ ([x : Int]) "int")) 1) : String ⇒ "int")
 
 ;; tapl examples, p441
 (typecheck-fail
  (define-type-alias tmp 1)
  #:with-msg "not a valid type: 1")
-(define-type-alias Id (tyλ ([X : ★]) X))
+(define-type-alias Id (tyλ ([X :: ★]) X))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (tyapp Id String)) Int))
 (check-type (λ ([f : (→ Int (tyapp Id String))]) 1) : (→ (→ Int String) Int))
@@ -89,104 +91,104 @@
 (check-type (λ ([f : (tyapp Id (→ Int String))]) 1) : (→ (tyapp Id (tyapp Id (→ Int String))) Int))
 
 ;; tapl examples, p451
-(define-type-alias Pair (tyλ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X))))
+(define-type-alias Pair (tyλ ([A :: ★] [B :: ★]) (∀ ([X :: ★]) (→ (→ A B X) X))))
 
 ;(check-type Pair : (⇒ ★ ★ ★))
-(check-type Pair : (⇒ ★ ★ (∀★ ★)))
+(check-type Pair :: (⇒ ★ ★ (∀★ ★)))
 
-(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X)))
+(check-type (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X :: ★][Y :: ★]) (→ X Y X)))
 ; parametric pair constructor
 (check-type
- (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
- : (∀ ([X : ★][Y : ★]) (→ X Y (tyapp Pair X Y))))
+ (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ : (∀ ([X :: ★][Y :: ★]) (→ X Y (tyapp Pair X Y))))
 ; concrete Pair Int String constructor
 (check-type
- (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ (inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String)
  : (→ Int String (tyapp Pair Int String)))
 ;; Pair Int String value
 (check-type
- ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String) 1 "1")
  : (tyapp Pair Int String))
 ;; fst: parametric
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
- : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) X)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (tyapp Pair X Y) X)))
 ;; fst: concrete Pair Int String accessor
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
   Int String)
  : (→ (tyapp Pair Int String) Int))
 ;; apply fst
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : Int ⇒ 1)
 ;; snd
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
- : (∀ ([X : ★][Y : ★]) (→ (tyapp Pair X Y) Y)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (tyapp Pair X Y) Y)))
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
   Int String)
  : (→ (tyapp Pair Int String) String))
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : String ⇒ "1")
 
 ;; sysf tests wont work, unless augmented with kinds
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X :: ★]) (→ X X X))) ; true
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X :: ★]) (→ X X X))) ; false
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y :: ★]) (→ Y Y Y))) ; false, alpha equiv
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t1 :: ★]) (∀ ([t2 :: ★]) (→ t1 (→ t2 t2)))))
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t3 :: ★]) (∀ ([t4 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4)))))
+(check-not-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t4 :: ★]) (∀ ([t3 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
-(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int)
+(check-type (inst (Λ ([t :: ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
+(check-type (inst (Λ ([t :: ★]) 1) (→ Int Int)) : Int)
 ; first inst should be discarded
-(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
+(check-type (inst (inst (Λ ([t :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
 ; second inst is discarded
-(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
+(check-type (inst (inst (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
 
 ;; polymorphic arguments
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t)))
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s)))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u))))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u))))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([t :: ★]) (→ t t)))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([s :: ★]) (→ s s)))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([s :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([s :: ★]) (→ s s))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([u :: ★]) (→ u u))))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) x) : (→ (∀ ([s :: ★]) (→ s s)) (∀ ([u :: ★]) (→ u u))))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x)))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u)))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) : (∀ ([u :: ★]) (→ u u)))
 (check-type
- (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
+ (inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
 (check-type
- ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10)
+ ((inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) 10)
  : Int ⇒ 10)
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10))
-             (Λ ([s : ★]) (λ ([y : s]) y)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t :: ★]) (→ t t)) Int))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10))
+             (Λ ([s :: ★]) (λ ([y : s]) y)))
              : Int ⇒ 10)
 
 

turnstile/examples/tests/fomega2-tests.rkt

@@ -1,74 +1,76 @@
 #lang s-exp "../fomega2.rkt"
 (require "rackunit-typechecking.rkt")
+(require "rackunit-kindchecking.rkt")
 
-(check-type Int : ★)
-(check-type String : ★)
+(check-kind Int :: ★)
+(check-kind String :: ★)
 (typecheck-fail →)
-(check-type (→ Int Int) : ★)
+(check-kind (→ Int Int) :: ★)
 (typecheck-fail (→ →))
 (typecheck-fail (→ 1))
 (check-type 1 : Int)
 
 ;; this should error but it doesnt
-#;(λ ([x : ★]) 1)
+#;(λ ([x :: ★]) 1)
 
-;(check-type (∀ ([t : ★]) (→ t t)) : ★)
-(check-type (∀ ([t : ★]) (→ t t)) : (∀★ ★))
-(check-type (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)) : ★)
+;(check-type (∀ ([t :: ★]) (→ t t)) :: ★)
+(check-kind (∀ ([t :: ★]) (→ t t)) :: (∀★ ★))
+(check-kind (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)) :: ★)
 
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : ★]) (λ ([x : X]) x)))
-            : (∀ ([X : ★]) (→ X X)))
-(typecheck-fail ((λ ([x : (∀ ([X : ★]) (→ X X))]) x) (Λ ([X : (→ ★ ★)]) (λ ([x : X]) x))))
+(check-type ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X :: ★]) (λ ([x : X]) x)))
+            : (∀ ([X :: ★]) (→ X X)))
+(typecheck-fail ((λ ([x : (∀ ([X :: ★]) (→ X X))]) x) (Λ ([X : (→ ★ ★)]) (λ ([x : X]) x))))
 
-(check-type (λ ([t : ★]) t) : (→ ★ ★))
-(check-type (λ ([t : ★] [s : ★]) t) : (→ ★ ★ ★))
-(check-type (λ ([t : ★]) (λ ([s : ★]) t)) : (→ ★ (→ ★ ★)))
-(check-type (λ ([t : (→ ★ ★)]) t) : (→ (→ ★ ★) (→ ★ ★)))
-(check-type (λ ([t : (→ ★ ★ ★)]) t) : (→ (→ ★ ★ ★) (→ ★ ★ ★)))
-(check-type (λ ([arg : ★] [res : ★]) (→ arg res)) : (→ ★ ★ ★))
+;; tests for λ as a type
+(check-kind (λ ([t :: ★]) t) :: (→ ★ ★))
+(check-kind (λ ([t :: ★] [s :: ★]) t) :: (→ ★ ★ ★))
+(check-kind (λ ([t :: ★]) (λ ([s :: ★]) t)) :: (→ ★ (→ ★ ★)))
+(check-kind (λ ([t :: (→ ★ ★)]) t) :: (→ (→ ★ ★) (→ ★ ★)))
+(check-kind (λ ([t :: (→ ★ ★ ★)]) t) :: (→ (→ ★ ★ ★) (→ ★ ★ ★)))
+(check-kind (λ ([arg :: ★] [res :: ★]) (→ arg res)) :: (→ ★ ★ ★))
 
-(check-type ((λ ([t : ★]) t) Int) : ★)
-(check-type (λ ([x : ((λ ([t : ★]) t) Int)]) x) : (→ Int Int))
-(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) x) 1) : Int ⇒ 1)
-(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
-(check-type ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
-(typecheck-fail ((λ ([x : ((λ ([t : ★]) t) Int)]) (+ 1 x)) "a-string"))
+(check-kind ((λ ([t :: ★]) t) Int) :: ★)
+(check-type (λ ([x : ((λ ([t :: ★]) t) Int)]) x) : (→ Int Int))
+(check-type ((λ ([x : ((λ ([t :: ★]) t) Int)]) x) 1) : Int ⇒ 1)
+(check-type ((λ ([x : ((λ ([t :: ★]) t) Int)]) (+ x 1)) 1) : Int ⇒ 2)
+(check-type ((λ ([x : ((λ ([t :: ★]) t) Int)]) (+ 1 x)) 1) : Int ⇒ 2)
+(typecheck-fail ((λ ([x : ((λ ([t :: ★]) t) Int)]) (+ 1 x)) "a-string"))
 
 ;; partial-apply →
-(check-type ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)
-            : (→ ★ ★))
+(check-kind ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int)
+            :: (→ ★ ★))
 ; f's type must have kind ★
-(typecheck-fail (λ ([f : ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)]) f))
-(check-type (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f)) :
-            (∀ ([tyf : (→ ★ ★)]) (→ (tyf String) (tyf String))))
+(typecheck-fail (λ ([f : ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int)]) f))
+(check-type (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f)) :
+            (∀ ([tyf :: (→ ★ ★)]) (→ (tyf String) (tyf String))))
 (check-type (inst
-             (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f))
-             ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))
+             (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f))
+             ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int))
             : (→ (→ Int String) (→ Int String)))
 (typecheck-fail
- (inst (Λ ([X : ★]) (λ ([x : X]) x)) 1))
- ;#:with-msg "not a valid type: 1")
+ (inst (Λ ([X :: ★]) (λ ([x : X]) x)) 1)
+ #:with-msg "not a valid type: 1")
 
 ;; applied f too early
 (typecheck-fail (inst
-                 (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1)))
-                 ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int)))
+                 (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) (f 1)))
+                 ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int)))
 (check-type ((inst
-              (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f))
-              ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))
+              (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f))
+              ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int))
              (λ ([x : Int]) "int")) : (→ Int String))
 (check-type (((inst
-               (Λ ([tyf : (→ ★ ★)]) (λ ([f : (tyf String)]) f))
-              ((λ ([arg : ★]) (λ ([res : ★]) (→ arg res))) Int))
+               (Λ ([tyf :: (→ ★ ★)]) (λ ([f : (tyf String)]) f))
+              ((λ ([arg :: ★]) (λ ([res :: ★]) (→ arg res))) Int))
               (λ ([x : Int]) "int")) 1) : String ⇒ "int")
 
 ;; tapl examples, p441
 (typecheck-fail
  (define-type-alias tmp 1))
  ;#:with-msg "not a valid type: 1")
-(define-type-alias Id (λ ([X : ★]) X))
+(define-type-alias Id (λ ([X :: ★]) X))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int String) Int))
 (check-type (λ ([f : (→ Int String)]) 1) : (→ (→ Int (Id String)) Int))
 (check-type (λ ([f : (→ Int (Id String))]) 1) : (→ (→ Int String) Int))
@@ -81,104 +83,104 @@
 (check-type (λ ([f : (Id (→ Int String))]) 1) : (→ (Id (Id (→ Int String))) Int))
 
 ;; tapl examples, p451
-(define-type-alias Pair (λ ([A : ★] [B : ★]) (∀ ([X : ★]) (→ (→ A B X) X))))
+(define-type-alias Pair (λ ([A :: ★] [B :: ★]) (∀ ([X :: ★]) (→ (→ A B X) X))))
 
-;(check-type Pair : (→ ★ ★ ★))
-(check-type Pair : (→ ★ ★ (∀★ ★)))
+;(check-type Pair :: (→ ★ ★ ★))
+(check-type Pair :: (→ ★ ★ (∀★ ★)))
 
-(check-type (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X : ★][Y : ★]) (→ X Y X)))
+(check-type (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) x)) : (∀ ([X :: ★][Y :: ★]) (→ X Y X)))
 ; parametric pair constructor
 (check-type
- (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
- : (∀ ([X : ★][Y : ★]) (→ X Y (Pair X Y))))
+ (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ : (∀ ([X :: ★][Y :: ★]) (→ X Y (Pair X Y))))
 ; concrete Pair Int String constructor
 (check-type
- (inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ (inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String)
  : (→ Int String (Pair Int String)))
 ; Pair Int String value
 (check-type
- ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+ ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
        Int String) 1 "1")
  : (Pair Int String))
 ; fst: parametric
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
- : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) X)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (Pair X Y) X)))
 ; fst: concrete Pair Int String accessor
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
   Int String)
  : (→ (Pair Int String) Int))
 ; apply fst
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p X) (λ ([x : X][y : Y]) x))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : Int ⇒ 1)
 ; snd
 (check-type
- (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
- : (∀ ([X : ★][Y : ★]) (→ (Pair X Y) Y)))
+ (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+ : (∀ ([X :: ★][Y :: ★]) (→ (Pair X Y) Y)))
 (check-type
  (inst
-  (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+  (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
   Int String)
  : (→ (Pair Int String) String))
 (check-type
  ((inst
-   (Λ ([X : ★][Y : ★]) (λ ([p : (∀ ([R : ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
+   (Λ ([X :: ★][Y :: ★]) (λ ([p : (∀ ([R :: ★]) (→ (→ X Y R) R))]) ((inst p Y) (λ ([x : X][y : Y]) y))))
    Int String)
-  ((inst (Λ ([X : ★] [Y : ★]) (λ ([x : X][y : Y]) (Λ ([R : ★]) (λ ([p : (→ X Y R)]) (p x y)))))
+  ((inst (Λ ([X :: ★] [Y :: ★]) (λ ([x : X][y : Y]) (Λ ([R :: ★]) (λ ([p : (→ X Y R)]) (p x y)))))
          Int String) 1 "1"))
  : String ⇒ "1")
 
-;;; sysf tests wont work, unless augmented with kinds
-(check-type (Λ ([X : ★]) (λ ([x : X]) x)) : (∀ ([X : ★]) (→ X X)))
+;; sysf tests wont work, unless augmented with kinds
+(check-type (Λ ([X :: ★]) (λ ([x : X]) x)) : (∀ ([X :: ★]) (→ X X)))
 
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X : ★]) (→ X X X))) ; true
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X : ★]) (→ X X X))) ; false
-(check-type (Λ ([X : ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y : ★]) (→ Y Y Y))) ; false, alpha equiv
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) t)) : (∀ ([X :: ★]) (→ X X X))) ; true
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([X :: ★]) (→ X X X))) ; false
+(check-type (Λ ([X :: ★]) (λ ([t : X] [f : X]) f)) : (∀ ([Y :: ★]) (→ Y Y Y))) ; false, alpha equiv
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t1 : ★]) (∀ ([t2 : ★]) (→ t1 (→ t2 t2)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t1 :: ★]) (∀ ([t2 :: ★]) (→ t1 (→ t2 t2)))))
 
-(check-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t3 : ★]) (∀ ([t4 : ★]) (→ t3 (→ t4 t4)))))
+(check-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t3 :: ★]) (∀ ([t4 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-not-type (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
-            : (∀ ([t4 : ★]) (∀ ([t3 : ★]) (→ t3 (→ t4 t4)))))
+(check-not-type (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) (λ ([y : t2]) y))))
+            : (∀ ([t4 :: ★]) (∀ ([t3 :: ★]) (→ t3 (→ t4 t4)))))
 
-(check-type (inst (Λ ([t : ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
-(check-type (inst (Λ ([t : ★]) 1) (→ Int Int)) : Int)
+(check-type (inst (Λ ([t :: ★]) (λ ([x : t]) x)) Int) : (→ Int Int))
+(check-type (inst (Λ ([t :: ★]) 1) (→ Int Int)) : Int)
 ; first inst should be discarded
-(check-type (inst (inst (Λ ([t : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
+(check-type (inst (inst (Λ ([t :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) (→ Int Int)) Int) : (→ Int Int))
 ; second inst is discarded
-(check-type (inst (inst (Λ ([t1 : ★]) (Λ ([t2 : ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
+(check-type (inst (inst (Λ ([t1 :: ★]) (Λ ([t2 :: ★]) (λ ([x : t1]) x))) Int) (→ Int Int)) : (→ Int Int))
 
 ;; polymorphic arguments
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([t : ★]) (→ t t)))
-(check-type (Λ ([t : ★]) (λ ([x : t]) x)) : (∀ ([s : ★]) (→ s s)))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([s : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([t : ★]) (→ t t))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([s : ★]) (→ s s))))
-(check-type (Λ ([s : ★]) (Λ ([t : ★]) (λ ([x : t]) x))) : (∀ ([r : ★]) (∀ ([u : ★]) (→ u u))))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) x) : (→ (∀ ([s : ★]) (→ s s)) (∀ ([u : ★]) (→ u u))))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([t :: ★]) (→ t t)))
+(check-type (Λ ([t :: ★]) (λ ([x : t]) x)) : (∀ ([s :: ★]) (→ s s)))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([s :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([t :: ★]) (→ t t))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([s :: ★]) (→ s s))))
+(check-type (Λ ([s :: ★]) (Λ ([t :: ★]) (λ ([x : t]) x))) : (∀ ([r :: ★]) (∀ ([u :: ★]) (→ u u))))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) x) : (→ (∀ ([s :: ★]) (→ s s)) (∀ ([u :: ★]) (→ u u))))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) (λ ([x : Int]) x)))
 (typecheck-fail ((λ ([x : (∀ (t) (→ t t))]) x) 1))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) : (∀ ([u : ★]) (→ u u)))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) : (∀ ([u :: ★]) (→ u u)))
 (check-type
- (inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
+ (inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) : (→ Int Int))
 (check-type
- ((inst ((λ ([x : (∀ ([t : ★]) (→ t t))]) x) (Λ ([s : ★]) (λ ([y : s]) y))) Int) 10)
+ ((inst ((λ ([x : (∀ ([t :: ★]) (→ t t))]) x) (Λ ([s :: ★]) (λ ([y : s]) y))) Int) 10)
  : Int ⇒ 10)
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t : ★]) (→ t t)) (→ Int Int)))
-(check-type (λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t : ★]) (→ t t)) Int))
-(check-type ((λ ([x : (∀ ([t : ★]) (→ t t))]) ((inst x Int) 10))
-             (Λ ([s : ★]) (λ ([y : s]) y)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) (inst x Int)) : (→ (∀ ([t :: ★]) (→ t t)) (→ Int Int)))
+(check-type (λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10)) : (→ (∀ ([t :: ★]) (→ t t)) Int))
+(check-type ((λ ([x : (∀ ([t :: ★]) (→ t t))]) ((inst x Int) 10))
+             (Λ ([s :: ★]) (λ ([y : s]) y)))
              : Int ⇒ 10)
 
 

turnstile/examples/tests/linear/fabul-tests.rkt

@@ -0,0 +1,75 @@
+#lang s-exp turnstile/examples/linear/fabul
+(require turnstile/rackunit-typechecking)
+
+(%U (define birthday : (× Int Int Int)
+     (tup 10 10 97)))
+
+(%U (check-type birthday : (× Int Int Int)))
+(%L (check-type (%U birthday) : (⊗ Int Int Int) ⇒ (tup 10 10 97)))
+
+(%U (typecheck-fail
+    (%L (let ([bday (%U birthday)]) 0))
+    #:with-msg "bday: linear variable unused"))
+
+(%L (typecheck-fail
+    (let ([x (%U birthday)]) (%U x))
+    #:with-msg "x: cannot use linear variable from unrestricted language"))
+
+(%L (check-type (let ([bday (%U birthday)])
+                  (%U (%L bday)))
+               : (⊗ Int Int Int)))
+
+(%L (check-type (%U (cons 1 (cons 2 (nil {Int}))))
+               : (MList Int)
+               ⇒ (cons 1 (cons 2 (nil)))))
+
+(%U (check-type (%L (cons 1 (cons 2 (nil))))
+               : (List Int)
+               ⇒ (cons 1 (cons 2 (nil {Int})))))
+
+(%L (check-type (let ([f (%U (λ () (cons 1 (nil {Int}))))]) f)
+               : (→ (MList Int))))
+
+(%L (check-type (let ([f (%U (λ () (cons 1 (nil {Int}))))]) (f))
+               : (MList Int)
+               ⇒ (cons 1 (nil))))
+
+
+
+(%L (define (partition [pred : (→ Int Bool)]
+                      [lst : (MList Int)]) (⊗ (MList Int) (MList Int))
+     (match-list lst
+       [(cons x xs @ l)
+        (let* ([(yes no) (partition pred xs)])
+          (if (pred x)
+              (tup (cons x yes @ l) no)
+              (tup yes (cons x no @ l))))]
+       [(nil)
+        (tup (nil {Int}) (nil {Int}))])))
+
+(%L (check-type (partition (λ (n) (< n 3))
+                          (cons 1 (cons 2 (cons 4 (cons 5 (nil))))))
+               : (⊗ (MList Int) (MList Int))
+               ⇒ (tup (cons 1 (cons 2 (nil)))
+                      (cons 4 (cons 5 (nil))))))
+
+
+(%L (define (mqsort [lst : (MList Int)] [acc : (MList Int)]) (MList Int)
+     (match-list lst
+       [(cons piv xs @ l)
+        (let* ([(lt gt) (partition (λ (x) (< x piv)) xs)])
+          (mqsort lt (cons piv (mqsort gt acc) @ l)))]
+       [(nil) acc])))
+
+(%L (check-type (mqsort (cons 4 (cons 7 (cons 2 (cons 1 (nil))))) (nil))
+               : (MList Int)
+               ⇒ (cons 1 (cons 2 (cons 4 (cons 7 (nil)))))))
+
+
+
+(%U (define (qsort [lst : (List Int)]) (List Int)
+     (%L (mqsort (%U lst) (nil)))))
+
+(%U (check-type (qsort (cons 4 (cons 7 (cons 2 (cons 1 (nil {Int}))))))
+               : (List Int)
+               ⇒ (cons 1 (cons 2 (cons 4 (cons 7 (nil {Int})))))))

turnstile/examples/tests/linear/lin+chan-tests.rkt

@@ -0,0 +1,18 @@
+#lang s-exp turnstile/examples/linear/lin+chan
+(require turnstile/rackunit-typechecking)
+
+(check-type
+ (let* ([(c c-out) (make-channel {Int})])
+   (thread (λ () (channel-put c-out 5)))
+   (thread (λ () (channel-put c-out 4)))
+   (let* ([(c1 x) (channel-get c)]
+          [(c2 y) (channel-get c1)])
+     (drop c2)
+     (+ x y)))
+ : Int -> 9)
+
+(typecheck-fail
+ (let* ([(c-in c-out) (make-channel {String})])
+   (thread (λ () (channel-get c-in)))
+   (channel-get c-in))
+ #:with-msg "c-in: linear variable used more than once")

turnstile/examples/tests/linear/lin+cons-tests.rkt

@@ -0,0 +1,28 @@
+#lang s-exp turnstile/examples/linear/lin+cons
+(require turnstile/rackunit-typechecking)
+
+
+(define (length [lst : (MList Int)]) Int
+  (match-list lst
+    [(cons _ xs @ l)
+     (begin (drop l)
+            (add1 (length xs)))]
+    [(nil) 0]))
+
+(check-type (length (cons 9 (cons 8 (cons 7 (nil))))) : Int -> 3)
+
+
+
+(define (rev-append [lst : (MList String)]
+                    [acc : (MList String)]) (MList String)
+  (match-list lst
+    [(cons x xs @ l) (rev-append xs (cons x acc @ l))]
+    [(nil) acc]))
+
+(define (rev [lst : (MList String)]) (MList String)
+  (rev-append lst (nil)))
+
+
+(check-type (rev (cons "a" (cons "b" (cons "c" (nil)))))
+            : (MList String)
+            -> (cons "c" (cons "b" (cons "a" (nil)))))

turnstile/examples/tests/linear/lin+tup-tests.rkt

@@ -0,0 +1,29 @@
+#lang s-exp turnstile/examples/linear/lin+tup
+
+(require turnstile/rackunit-typechecking
+         (only-in racket/base quote))
+
+(check-type (tup 1 #t) : (⊗ Int Bool) -> '(1 #t))
+(check-type (tup 1 2 3) : (⊗ Int Int Int) -> '(1 2 3))
+
+(check-type (let ([p (tup 1 2)]) p) : (⊗ Int Int) -> '(1 2))
+(typecheck-fail (let ([p (tup 1 2)]) ())
+                #:with-msg "p: linear variable unused")
+(typecheck-fail (let ([p (tup 1 2)]) (tup p p))
+                #:with-msg "p: linear variable used more than once")
+
+(check-type (let ([p (tup 1 ())]) (if #t p p)) : (⊗ Int Unit))
+(typecheck-fail (let ([p (tup 1 ())]) (if #t p (tup 2 ())))
+                #:with-msg "linear variable may be unused in certain branches")
+
+(check-type (λ ([x : Int]) (tup x x)) : (-o Int (⊗ Int Int)))
+(typecheck-fail (λ ([x : (⊗ Int Int)]) ())
+                #:with-msg "x: linear variable unused")
+
+(check-type (let ([p (tup 1 2)]) (λ ([x : Int]) p))
+            : (-o Int (⊗ Int Int)))
+
+(check-type (let* ([x 3] [y x]) y) : Int -> 3)
+(check-type (let* ([(x y) (tup 1 #f)]) x) : Int -> 1)
+(typecheck-fail (let* ([(x y) (tup (tup 1 2) 3)]) y)
+                #:with-msg "x: linear variable unused")

turnstile/examples/tests/linear/lin+var-tests.rkt

@@ -0,0 +1,67 @@
+#lang s-exp turnstile/examples/linear/lin+var
+(require turnstile/rackunit-typechecking)
+
+(check-type (var [left 3]) : (⊕ [left Int] [right String]))
+(check-type (var [right "a"]) : (⊕ [left Int] [right String]))
+
+(typecheck-fail (var [left 3] as (⊕ [yes] [no]))
+                #:with-msg "type \\(⊕ \\(yes\\) \\(no\\)\\) does not have variant named 'left'")
+
+(typecheck-fail (var [left 3] as (⊕ [left Int Int] [right String]))
+                #:with-msg "wrong number of arguments to variant: expected 2, got 1")
+
+(define-type-alias (Either A B) (⊕ [left A] [right B]))
+(define-type-alias (Option A) (⊕ [some A] [none]))
+
+(typecheck-fail (var [middle 3] as (Either Int Float))
+                #:with-msg "type \\(Either Int Float\\) does not have variant named 'middle'")
+
+(check-type (λ (x) x) : (→ (Either Int Float) (Either Int Float)))
+(check-type (λ (x) x) : (→ (Either Int Float) (⊕ [left Int] [right Float])))
+
+(typecheck-fail (let ([x (var [left 3] as (Either Int Int))]) 0)
+                #:with-msg "x: linear variable unused")
+
+(check-type (match (var [left 3] as (Either Int Int))
+              [(left x) x]
+              [(right y) (+ y 1)])
+            : Int ⇒ 3)
+
+(check-type (match (var [right 5] as (Either Int Int))
+              [(left x) x]
+              [(right y) (+ y 1)])
+            : Int ⇒ 6)
+
+(typecheck-fail (match (var [left 3] as (Either Int (-o Int Int)))
+                  [(left x) x]
+                  [(right f) 0])
+                #:with-msg "f: linear variable unused")
+
+(check-type (match (var [right (λ (x) (+ x x))] as (Either Int (-o Int Int)))
+              [(left x) x]
+              [(right f) (f 2)])
+            : Int ⇒ 4)
+
+(typecheck-fail (match (var [left 0] as (Either Int String))
+                  [(left x) x]
+                  [(right y) y])
+                #:with-msg "branches have incompatible types: Int and String")
+
+(typecheck-fail (match (var [some ()] as (Option Unit))
+                  [(left x) x]
+                  [(right y) y])
+                #:with-msg "type \\(Option Unit\\) does not have variant named 'left'")
+(%%reset-linear-mode)
+
+(typecheck-fail (match (var [left 0] as (Either Int Int))
+                  [(left x) x]
+                  [(right y z) y])
+                #:with-msg "wrong number of arguments to variant: expected 1, got 2")
+(%%reset-linear-mode)
+
+(typecheck-fail (let ([f (λ ([x : Int]) x)])
+                  (match (var [left 0] as (Either Int Int))
+                    [(left x) (f x)]
+                    [(right y) y]))
+                #:with-msg "f: linear variable may be unused in certain branches")
+(%%reset-linear-mode)

turnstile/examples/tests/linear/lin-tests.rkt

@@ -0,0 +1,76 @@
+#lang s-exp turnstile/examples/linear/lin
+(require turnstile/rackunit-typechecking
+         (only-in racket/base quote))
+
+(check-type #t : Bool)
+(check-type 4 : Int)
+(check-type () : Unit)
+
+(check-type (let ([x 3] [y 4]) y) : Int -> 4)
+
+(check-type (if #t 1 2) : Int -> 1)
+(typecheck-fail (if 1 2 3)
+                #:with-msg "expected Bool, given Int")
+(typecheck-fail (if #t 2 ())
+                #:with-msg "branches have incompatible types: Int and Unit")
+(%%reset-linear-mode)
+
+(check-type (λ ([x : Int]) x) : (-o Int Int))
+(check-type (λ ! ([x : Int]) x) : (→ Int Int))
+(check-type (λ (x) x) : (-o String String))
+(check-type (λ (x) x) : (→ String String))
+
+(check-type + : (→ Int Int Int))
+(check-type (+ 1 2) : Int -> 3)
+(check-type ((λ ([x : Int]) (+ x 1)) 4) : Int -> 5)
+
+
+(typecheck-fail (λ ([p : (-o Int Bool)]) 0)
+                #:with-msg "p: linear variable unused")
+
+(typecheck-fail (let ([f (λ ([x : Int]) x)])
+                  0)
+                #:with-msg "f: linear variable unused")
+
+(typecheck-fail (let ([f (λ ([x : Int]) x)])
+                  (f (f 3)))
+                #:with-msg "f: linear variable used more than once")
+
+(typecheck-fail (let ([f (λ ([x : Int]) x)])
+                  (if #t
+                      (f 3)
+                      4))
+                #:with-msg "f: linear variable may be unused in certain branches")
+
+(typecheck-fail (let ([f (λ ([x : Int]) x)])
+                  (λ ! ([x : Int]) f))
+                #:with-msg "f: linear variable may not be used by unrestricted function")
+(%%reset-linear-mode)
+
+(check-type (let ([twice (λ ! ([x : Int]) (+ x x))])
+              (+ (twice 8)
+                 (twice 9)))
+            : Int -> 34)
+
+(check-type (let ([f (λ ([x : Int]) #t)])
+              (begin (drop f)
+                     3))
+            : Int -> 3)
+
+(check-type (letrec ([{<= : (→ Int Int Bool)}
+                      (λ (n m)
+                         (if (zero? n)
+                             #t
+                             (if (zero? m)
+                                 #f
+                                 (<= (sub1 n) (sub1 m)))))])
+              (if (<= 4 1) 999
+                  (if (<= 3 3)
+                      0
+                      888)))
+            : Int -> 0)
+
+(typecheck-fail (letrec ([{f : (-o Int Int)}
+                          (λ (x) (f x))])
+                  (f 3))
+                #:with-msg "may not bind linear type \\(-o Int Int\\) in letrec")

turnstile/examples/tests/mlish-tests.rkt

@@ -295,7 +295,7 @@
    [Nil -> 3])
  : Int ⇒ 6)
             
-;; check expected-type propagation for other match paterns
+;; check expected-type propagation for other match patterns
 
 (define-type (Option A)
   (None)
@@ -450,6 +450,13 @@
 
 (define (ok [a : A] → (Result A B))
   (Ok a))
+
+;; Cannot infer concrete type for B in (Result A B).
+;; Need expected type (see (inst result-if-1 ...) example below)
+(typecheck-fail
+ (λ ([a : Int]) (ok (Cons a Nil)))
+ #:with-msg "Could not infer instantiation of polymorphic function ok")
+
 (define (error [b : B] → (Result A B))
   (Error b))
 
@@ -512,6 +519,7 @@
             : (→ (→ Int (Result (List Int) (List String)))
                  (→ String (Result (List Int) (List String)))
                  (Result (List Int) (List String))))
+
 (check-type (((inst result-if-1 Int String (List Int) (List String)) (Ok 1))
              (λ ([a : Int])    (ok (Cons a Nil)))
              (λ ([b : String]) (error (Cons b Nil))))
@@ -671,7 +679,7 @@
 (typecheck-fail (ann 1 : Complex) #:with-msg "unbound identifier")
 (typecheck-fail (ann 1 : 1) #:with-msg "not a well-formed type")
 (typecheck-fail (ann 1 : (λ ([x : Int]) x)) #:with-msg "not a well-formed type")
-(typecheck-fail (ann Int : Int) #:with-msg "expected Int, given #%type\n *expression: Int")
+(typecheck-fail (ann Int : Int) #:with-msg "expected Int, given an invalid expression\n *expression: Int")
 
 ; let
 (check-type (let () (+ 1 1)) : Int ⇒ 2)

turnstile/examples/tests/mlish/chameneos.mlish

@@ -118,9 +118,16 @@
   ;;          (list 66 0)
   ;;          (list 67 0)))
 
-(check-type (map (λ ([x : Result]) (proj x 0))
-                 (go 1000 (list Blue Red Yellow Red Yellow Blue)))
-  : (List Int) -> (list 333 333 333 333 334 334))
+(define res2 
+  (map (λ ([x : Result]) (proj x 0))
+       (go 1000 (list Blue Red Yellow Red Yellow Blue))))
+(check-type res2 : (List Int))
+(define (=333/4 [x : Int] -> Bool) (or (= x 333) (= x 334)))
+(define (andmap [p? : (→ X Bool)] [xs : (List X)] → Bool)
+  (match2 xs with
+   [nil -> #t]
+   [x :: rst -> (and (p? x) (andmap p? rst))]))         
+(check-type (andmap =333/4 res2) : Bool -> #t)
   ;; -> (list (list 333 0)
   ;;          (list 333 0)
   ;;          (list 333 0)

turnstile/examples/tests/pat-expander-tests-def.rkt

@@ -0,0 +1,171 @@
+#lang turnstile
+
+(provide (all-defined-out))
+
+(define-base-type Nothing)
+(define-base-type Bool)
+(define-base-type Int)
+(define-base-type String)
+(define-type-constructor Tuple #:arity >= 0)
+(define-type-constructor Listof #:arity = 1)
+(define-type-constructor Sequenceof #:arity >= 0)
+
+(begin-for-syntax
+  (define-splicing-syntax-class (for-clause-group env)
+    #:attributes [[clause- 1] [env.x 1] [env.τ 1]]
+    [pattern (~seq (~var clause (for-clause env))
+                   ...)
+      #:with [clause- ...] #'[clause.clause- ... ...]
+      #:with [[env.x env.τ] ...] #'[[clause.env.x clause.env.τ] ... ...]])
+
+  (define-splicing-syntax-class (guard-clause env)
+    #:attributes [[clause- 1]]
+    [pattern (~and (~seq #:when bool:expr)
+                   (~typecheck
+                    #:with [[x τ_x] ...] env
+                    [[x ≫ x- : τ_x] ... ⊢ bool ≫ bool- ⇐ Bool]))
+      #:with [clause- ...] #`[#:when (let- ([x- x] ...) bool-)]]
+    [pattern (~and (~seq #:unless bool:expr)
+                   (~typecheck
+                    #:with [[x τ_x] ...] env
+                    [[x ≫ x- : τ_x] ... ⊢ bool ≫ bool- ⇐ Bool]))
+      #:with [clause- ...] #`[#:unless (let- ([x- x] ...) bool-)]]
+    [pattern (~and (~seq #:break bool:expr)
+                   (~typecheck
+                    #:with [[x τ_x] ...] env
+                    [[x ≫ x- : τ_x] ... ⊢ bool ≫ bool- ⇐ Bool]))
+      #:with [clause- ...] #`[#:break (let- ([x- x] ...) bool-)]]
+    [pattern (~and (~seq #:final bool:expr)
+                   (~typecheck
+                    #:with [[x τ_x] ...] env
+                    [[x ≫ x- : τ_x] ... ⊢ bool ≫ bool- ⇐ Bool]))
+      #:with [clause- ...] #`[#:final (let- ([x- x] ...) bool-)]])
+
+  (define-splicing-syntax-class (for-clause env)
+    #:attributes [[clause- 1] [env.x 1] [env.τ 1]]
+    [pattern (~and [x:id seq:expr]
+                   (~typecheck
+                    #:with [[y τ_y] ...] env
+                    [[y ≫ y- : τ_y] ... ⊢ seq ≫ seq- ⇒ (~Sequenceof τ_x)]))
+      #:with [clause- ...] #'[[x (let- ([y- y] ...) seq-)]]
+      #:with [[env.x env.τ] ...] #'[[x τ_x]]]
+    [pattern (~and [(x:id ...) seq:expr]
+                   (~typecheck
+                    #:with [[y τ_y] ...] env
+                    [[y ≫ y- : τ_y] ... ⊢ seq ≫ seq- ⇒ (~Sequenceof τ_x ...)]))
+      #:fail-unless (stx-length=? #'[x ...] #'[τ_x ...])
+      (format "expected a ~v-valued sequence, given a ~v-valued one"
+              (stx-length #'[x ...])
+              (stx-length #'[τ_x ...]))
+      #:with [clause- ...] #'[[(x ...) (let- ([y- y] ...) seq-)]]
+      #:with [[env.x env.τ] ...] #'[[x τ_x] ...]])
+
+  (define-syntax-class (for-clauses env)
+    #:attributes [[clause- 1] [env.x 1] [env.τ 1]]
+    [pattern ((~var group (for-clause-group env)))
+      #:with [clause- ...] #'[group.clause- ...]
+      #:with [[env.x env.τ] ...] #'[[group.env.x group.env.τ] ...]]
+    [pattern ((~var fst (for-clause-group env))
+              (~var guard (guard-clause (stx-append env #'[[fst.env.x fst.env.τ] ...])))
+              .
+              (~var rst (for-clauses (stx-append env #'[[fst.env.x fst.env.τ] ...]))))
+      #:with [clause- ...] #'[fst.clause- ... guard.clause- ... rst.clause- ...]
+      #:with [[env.x env.τ] ...] #'[[fst.env.x fst.env.τ] ... [rst.env.x rst.env.τ] ...]])
+  )
+
+;; ------------------------------------------------------------------------
+
+;; for/list
+
+(define-typed-syntax for/list
+  [(_ (~var clauses (for-clauses #'[]))
+     body) ≫
+   [[clauses.env.x ≫ x- : clauses.env.τ] ...
+    ⊢ body ≫ body- ⇒ τ]
+   --------
+   [⊢ (for/list- (clauses.clause- ...)
+        (let- ([x- clauses.env.x] ...) body-))
+      ⇒ (Listof τ)]])
+
+(define-typed-syntax in-range
+  [(_ n:expr) ≫
+   [⊢ n ≫ n- ⇐ Int]
+   --------
+   [⊢ (in-range- n-) ⇒ (Sequenceof Int)]])
+
+(define-typed-syntax in-naturals
+  [(_) ≫ --- [⊢ (in-naturals-) ⇒ (Sequenceof Int)]]
+  [(_ n:expr) ≫
+   [⊢ n ≫ n- ⇐ Int]
+   --------
+   [⊢ (in-naturals- n-) ⇒ (Sequenceof Int)]])
+
+(define-typed-syntax in-list
+  [(_ lst:expr) ≫
+   [⊢ lst ≫ lst- ⇒ (~Listof τ)]
+   --------
+   [⊢ (in-list- lst-) ⇒ (Sequenceof τ)]])
+
+(define-typed-syntax in-indexed
+  [(_ seq:expr) ≫
+   [⊢ seq ≫ seq- ⇒ (~Sequenceof τ)]
+   --------
+   [⊢ (in-indexed- seq-) ⇒ (Sequenceof τ Int)]])
+
+;; ------------------------------------------------------------------------
+
+;; Constructing Literals, Tuples, and Lists
+
+(define-typed-syntax #%datum
+  [(_ . b:boolean) ≫ --- [⊢ (quote- b) ⇒ Bool]]
+  [(_ . i:integer) ≫ --- [⊢ (quote- i) ⇒ Int]]
+  [(_ . s:str) ≫ --- [⊢ (quote- s) ⇒ String]])
+
+(define-typed-syntax tuple
+  [(_ e:expr ...) ≫
+   [⊢ [e ≫ e- ⇒ τ] ...]
+   --------
+   [⊢ (vector-immutable- e- ...) ⇒ (Tuple τ ...)]])
+
+(define-typed-syntax list
+  [(_) ≫ --- [⊢ (quote- ()) ⇒ (Listof Nothing)]]
+  [(_ e0:expr e:expr ...) ≫
+   [⊢ e0 ≫ e0- ⇒ τ]
+   [⊢ [e ≫ e- ⇐ τ] ...]
+   --------
+   [⊢ (list- e0- e- ...) ⇒ (Listof τ)]])
+
+;; ------------------------------------------------------------------------
+
+;; Basic Bool Forms
+
+(define-typed-syntax not
+  [(_ b:expr) ≫ [⊢ b ≫ b- ⇐ Bool] --- [⊢ (not- b-) ⇒ Bool]])
+
+(define-typed-syntax and
+  [(_ b:expr ...) ≫
+   [⊢ [b ≫ b- ⇐ Bool] ...]
+   --------
+   [⊢ (and- b- ...) ⇒ Bool]])
+
+;; ------------------------------------------------------------------------
+
+;; Basic Int Forms
+
+(define-typed-syntax even?
+  [(_ i:expr) ≫ [⊢ i ≫ i- ⇐ Int] --- [⊢ (even?- i-) ⇒ Bool]])
+
+(define-typed-syntax odd?
+  [(_ i:expr) ≫ [⊢ i ≫ i- ⇐ Int] --- [⊢ (odd?- i-) ⇒ Bool]])
+
+;; ------------------------------------------------------------------------
+
+;; Basic String Forms
+
+(define-typed-syntax string=?
+  [(_ a:expr b:expr) ≫
+   [⊢ a ≫ a- ⇐ String]
+   [⊢ b ≫ b- ⇐ String]
+   --------
+   [⊢ (string=?- a- b-) ⇒ Bool]])
+

turnstile/examples/tests/pat-expander-tests.rkt

@@ -0,0 +1,143 @@
+#lang turnstile
+
+(require turnstile/rackunit-typechecking
+         "pat-expander-tests-def.rkt")
+
+;; The for/list macro defined in "pat-expander-tests-def.rkt" uses the
+;; ~typecheck pattern-expander to typecheck the for clauses within a
+;; syntax class.
+
+;; These tests make sure that #:when conditions can refer to
+;; identifiers defined in previous clauses.
+
+(check-type (for/list () 1) : (Listof Int) -> (list 1))
+(check-type (for/list () #t) : (Listof Bool) -> (list #t))
+(check-type (for/list () #f) : (Listof Bool) -> (list #f))
+
+(check-type (for/list (#:when #t) 1) : (Listof Int) -> (list 1))
+(check-type (for/list (#:when #f) 1) : (Listof Int) -> (list))
+(check-type (for/list ([x (in-range 5)]) x)
+            : (Listof Int)
+            -> (list 0 1 2 3 4))
+
+(check-type (for/list ([(s i) (in-indexed (in-list (list "a" "b" "c")))])
+              (tuple s i))
+            : (Listof (Tuple String Int))
+            -> (list (tuple "a" 0) (tuple "b" 1) (tuple "c" 2)))
+
+(check-type (for/list ([(s i) (in-indexed (in-list (list "a" "b" "c")))]
+                       #:when (even? i))
+              (tuple s i))
+            : (Listof (Tuple String Int))
+            -> (list (tuple "a" 0) (tuple "c" 2)))
+
+(check-type (for/list ([(s i) (in-indexed (in-list (list "a" "b" "c" "d" "e")))]
+                       #:when (even? i)
+                       [j (in-range i)])
+              (tuple s i j))
+            : (Listof (Tuple String Int Int))
+            -> (list (tuple "c" 2 0)
+                     (tuple "c" 2 1)
+                     (tuple "e" 4 0)
+                     (tuple "e" 4 1)
+                     (tuple "e" 4 2)
+                     (tuple "e" 4 3)))
+
+;; ------------------------------------------------------------------------
+
+;; Test based on section 11 of the racket guide
+
+(check-type (for/list ([book (in-list (list "Guide" "Reference" "Notes"))]
+                       #:when (not (string=? book "Notes"))
+                       [i (in-naturals 1)]
+                       [chapter (in-list (list "Intro" "Details" "Conclusion" "Index"))]
+                       #:when (not (string=? chapter "Index")))
+              (tuple book i chapter))
+            : (Listof (Tuple String Int String))
+            -> (list (tuple "Guide" 1 "Intro")
+                     (tuple "Guide" 2 "Details")
+                     (tuple "Guide" 3 "Conclusion")
+                     (tuple "Reference" 1 "Intro")
+                     (tuple "Reference" 2 "Details")
+                     (tuple "Reference" 3 "Conclusion")))
+
+(check-type (for/list ([book (in-list (list "Guide" "Story" "Reference"))]
+                       #:break (string=? book "Story")
+                       [chapter (in-list (list "Intro" "Details" "Conclusion"))])
+              (tuple book chapter))
+            : (Listof (Tuple String String))
+            -> (list (tuple "Guide" "Intro")
+                     (tuple "Guide" "Details")
+                     (tuple "Guide" "Conclusion")))
+
+(check-type (for/list ([book (in-list (list "Guide" "Story" "Reference"))]
+                       #:when #true
+                       [chapter (in-list (list "Intro" "Details" "Conclusion"))]
+                       #:break (and (string=? book "Story")
+                                    (string=? chapter "Conclusion")))
+              (tuple book chapter))
+            : (Listof (Tuple String String))
+            -> (list (tuple "Guide" "Intro")
+                     (tuple "Guide" "Details")
+                     (tuple "Guide" "Conclusion")
+                     (tuple "Story" "Intro")
+                     (tuple "Story" "Details")))
+
+(check-type (for/list ([book (in-list (list "Guide" "Story" "Reference"))]
+                       #:when #true
+                       [chapter (in-list (list "Intro" "Details" "Conclusion"))]
+                       #:final (and (string=? book "Story")
+                                    (string=? chapter "Conclusion")))
+              (tuple book chapter))
+            : (Listof (Tuple String String))
+            -> (list (tuple "Guide" "Intro")
+                     (tuple "Guide" "Details")
+                     (tuple "Guide" "Conclusion")
+                     (tuple "Story" "Intro")
+                     (tuple "Story" "Details")
+                     (tuple "Story" "Conclusion")))
+
+(check-type (for/list ([book (in-list (list "Guide" "Story" "Reference"))]
+                       #:final (string=? book "Story")
+                       [chapter (in-list (list "Intro" "Details" "Conclusion"))])
+              (tuple book chapter))
+            : (Listof (Tuple String String))
+            -> (list (tuple "Guide" "Intro")
+                     (tuple "Guide" "Details")
+                     (tuple "Guide" "Conclusion")
+                     (tuple "Story" "Intro")))
+
+;; ------------------------------------------------------------------------
+
+;; Tests based on section 3.18 of the racket reference
+
+(check-type (for/list ([i (in-list (list 1 2 3))]
+                       [j (in-list (list "a" "b" "c"))]
+                       #:when (odd? i)
+                       [k (in-list (list #t #f))])
+              (tuple i j k))
+            : (Listof (Tuple Int String Bool))
+            -> (list (tuple 1 "a" #t)
+                     (tuple 1 "a" #f)
+                     (tuple 3 "c" #t)
+                     (tuple 3 "c" #f)))
+
+(check-type (for/list ([i (in-list (list 1 2 3))]
+                       [j (in-list (list "a" "b" "c"))]
+                       #:break (not (odd? i))
+                       [k (in-list (list #t #f))])
+              (tuple i j k))
+            : (Listof (Tuple Int String Bool))
+            -> (list (tuple 1 "a" #true)
+                     (tuple 1 "a" #false)))
+
+(check-type (for/list ([i (in-list (list 1 2 3))]
+                       [j (in-list (list "a" "b" "c"))]
+                       #:final (not (odd? i))
+                       [k (in-list (list #t #f))])
+              (tuple i j k))
+            : (Listof (Tuple Int String Bool))
+            -> (list (tuple 1 "a" #true)
+                     (tuple 1 "a" #false)
+                     (tuple 2 "b" #true)))
+

turnstile/examples/tests/rackunit-kindchecking.rkt

@@ -0,0 +1,18 @@
+#lang racket/base
+(require (for-syntax rackunit syntax/srcloc) rackunit macrotypes/typecheck
+         (only-in "../fomega2.rkt" current-kind-eval kindcheck?))
+(provide check-kind)
+
+;; Note: this file is separate from macrotypes/examples/test/rackunit-kindcheck
+;; because each one uses different defs of current-kind-eval and kindcheck?
+(define-syntax (check-kind stx)
+  (syntax-parse stx #:datum-literals (⇒ ->)
+    [(_ τ tag:id k-expected)
+     #:with k (detach (expand/df #'(add-expected τ k-expected))
+                      (stx->datum #'tag))
+     #:fail-unless (kindcheck? #'k ((current-kind-eval) #'k-expected))
+                   (format
+                    "Type ~a [loc ~a:~a] has kind ~a, expected ~a"
+                    (syntax->datum #'τ) (syntax-line #'τ) (syntax-column #'τ)
+                    (type->str #'k) (type->str #'k-expected))
+     #'(void)]))

turnstile/examples/tests/rackunit-typechecking.rkt

@@ -1,17 +1,17 @@
 #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 typecheck-fail/toplvl
          (rename-out [typecheck-fail check-stx-err]))
 
 (begin-for-syntax
   (define (add-esc s) (string-append "\\" s))
-  (define escs (map add-esc '("(" ")" "[" "]")))
+  (define escs (map add-esc '("(" ")" "[" "]" "+" "*")))
   (define (replace-brackets str)
     (regexp-replace* "\\]" (regexp-replace* "\\[" str "(") ")"))
   (define (add-escs str)
     (replace-brackets
-        (foldl (lambda (c s) (regexp-replace* c s (add-esc c))) str escs)))
+     (foldl (lambda (c s) (regexp-replace* c s (add-esc c))) str escs)))
   (define (expected tys #:given [givens ""] #:note [note ""])
     (string-append  
      note ".*Expected.+argument\\(s\\) with type\\(s\\).+" 
@@ -19,19 +19,20 @@
      (string-join (map add-escs (string-split givens ", ")) ".*"))))
 
 (define-syntax (check-type stx)
-  (syntax-parse stx #:datum-literals (: ⇒ ->)
+  (syntax-parse stx #:datum-literals (⇒ ->)
     ;; duplicate code to avoid redundant expansions
-    [(_ e : τ-expected (~or ⇒ ->) v)
+    [(_ e tag:id τ-expected (~or ⇒ ->) v)
      #:with e+ (expand/df #'(add-expected e τ-expected))
-     #:with τ (typeof #'e+)
+     #:with τ (detach #'e+ (stx->datum #'tag))
      #:fail-unless (typecheck? #'τ ((current-type-eval) #'τ-expected))
                    (format
                     "Expression ~a [loc ~a:~a] has type ~a, expected ~a"
                     (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e)
                     (type->str #'τ) (type->str #'τ-expected))
      (syntax/loc stx (check-equal? e+ (add-expected v τ-expected)))]
-    [(_ e : τ-expected)
-     #:with τ (typeof (expand/df #'(add-expected e τ-expected)))
+    [(_ e tag:id τ-expected)
+     #:with e+ (expand/df #'(add-expected e τ-expected))
+     #:with τ (detach #'e+ (stx->datum #'tag))
      #:fail-unless
      (typecheck? #'τ ((current-type-eval) #'τ-expected))
      (format
@@ -67,6 +68,31 @@
      #'(void)]))
 
 (define-syntax (typecheck-fail stx)
+  (syntax-parse stx #:datum-literals (:)
+    [(_ e (~or
+           (~optional (~seq #:with-msg msg-pat) #:defaults ([msg-pat #'""]))
+           (~optional (~seq #:verb-msg vmsg) #:defaults ([vmsg #'""]))))
+     #:with msg:str
+            (if (attribute msg-pat)
+                (eval-syntax (datum->stx #'h (stx->datum #'msg-pat)))
+                (eval-syntax (datum->stx #'h `(add-escs ,(stx->datum #'vmsg)))))
+     #:when (with-check-info*
+             (list (make-check-expected (syntax-e #'msg))
+                   (make-check-expression (syntax->datum stx))
+                   (make-check-location (build-source-location-list stx))
+                   (make-check-name 'typecheck-fail)
+                   (make-check-params (list (syntax->datum #'e) (syntax-e #'msg))))
+             (λ ()
+               (check-exn
+                (λ (ex)
+                  (and (or (exn:fail? ex) (exn:test:check? ex))
+                       ; check err msg matches
+                       (regexp-match? (syntax-e #'msg) (exn-message ex))))
+                (λ ()
+                  (expand/df #'e)))))
+     #'(void)]))
+
+(define-syntax (typecheck-fail/toplvl stx)
   (syntax-parse stx #:datum-literals (:)
     [(_ e (~optional (~seq #:with-msg msg-pat) #:defaults ([msg-pat #'""])))
      #:with msg:str 
@@ -84,7 +110,7 @@
                        ; check err msg matches
                        (regexp-match? (syntax-e #'msg) (exn-message ex))))
                 (λ ()
-                  (expand/df #'e)))))
+                  (local-expand #'e 'top-level null)))))
      #'(void)]))
 
 (define-syntax (check-runtime-exn stx)

turnstile/examples/tests/stlc+union+case.rkt

@@ -37,6 +37,14 @@
 (define-type-alias NNN (U (U Nat Nat) (U (U Nat Nat Nat) (U Nat Nat))))
 (check-type ((λ ([x : NNN]) x) 1) : Nat -> 1)
 
+; check that pruning and collapsing don't throw away types when the union
+; contains another empty union
+(typecheck-fail
+ (λ ([x : (U (U) String)])
+   (ann x : (U)))
+ #:with-msg
+ "expected \\(U\\), given \\(U \\(U\\) String\\)")
+
 
 ;; tests from stlc+sub ---------------------
 (check-type 1 : Num)

turnstile/examples/tests/stlc+union.rkt

@@ -27,6 +27,14 @@
 (define-type-alias NNN (U (U Nat Nat) (U (U Nat Nat Nat) (U Nat Nat))))
 (check-type ((λ ([x : NNN]) x) 1) : Nat -> 1)
 
+; check that pruning and collapsing don't throw away types when the union
+; contains another empty union
+(typecheck-fail
+ (λ ([x : (U (U) String)])
+   (ann x : (U)))
+ #:with-msg
+ "expected \\(U\\), given \\(U \\(U\\) String\\)")
+
 
 ;; tests from stlc+sub ---------------------
 (check-type 1 : Num)

turnstile/examples/trivial.rkt

@@ -120,7 +120,7 @@
            ((current-type=?) t1 #'t2*)]
           [_ #f])))
   (current-type=? new-type=?)
-  (current-typecheck-relation (current-type=?))
+  (current-typecheck-relation new-type=?)
 
   ;; current-type?
   ;; TODO: disabling type validation for now
@@ -282,7 +282,7 @@
                   [x:id : ty])) ...)
       . es) ≫
    #:with (X ...) (generate-temporaries #'(x ...))
-   [([X ≫ X- : #%type] ...) ([x ≫ x- : X] ...) 
+   [([X ≫ X- :: #%type] ...) ([x ≫ x- : X] ...) 
     ⊢ (begin . es) ≫ e- ⇒ τ_out]
    ;; TODO: investigate why this extra syntax-local-introduce is needed?
    #:with τ_out* (syntax-local-introduce #'τ_out)
@@ -344,7 +344,7 @@
    #:with Bs** (prune-Bs #'Bs*)
 ;   #:when (begin (displayln "checking Cs:")
 ;                 (pretty-print (syntax->datum #'Cs*)))
-   #:with remaining-Cs (check-Cs #'Cs* stx)
+   #:with remaining-Cs (check-Cs #'Cs* this-syntax)
 ;   #:when (printf "remaining Cs: ~a\n"
 ;                  (syntax->datum #'remaining-Cs))
    #:with ty-out**

turnstile/examples/util/filter-maximal.rkt

@@ -0,0 +1,54 @@
+#lang racket/base
+
+(provide filter-maximal)
+
+(module+ test
+  (require rackunit
+           (only-in racket/list in-permutations)
+           (only-in racket/set set=? subset?)))
+
+;; filter-maximal : [Listof X] [X X -> Bool] -> [Listof X]
+;; <? is a partial ordering predicate
+(define (filter-maximal xs <?)
+  (reverse
+   (for/fold ([acc '()])
+             ([x (in-list xs)])
+     (merge-with x acc <?))))
+
+;; merge-with : X [Listof X] [X X -> Bool] -> [Listof X]
+;; <? is a partial ordering predicate
+(define (merge-with x ys <?)
+  (define (greater? y) (<? x y))
+  (cond [(ormap greater? ys) ys]
+        [else
+         (define (not-lesser? y) (not (<? y x)))
+         (cons x (filter not-lesser? ys))]))
+
+;; ----------------------------------------------------------------------------
+
+(module+ test
+  (define-check (check-filter-maximal lst <? expected)
+    (test-begin
+     (for ([p (in-permutations lst)])
+       (check set=? (filter-maximal p <?) expected))))
+
+  (check-equal? (filter-maximal '(1 2 3 2 3 2 1) <) '(3 3))
+  (check-equal? (filter-maximal '(1 2 3 2 3.0 2 1) <) '(3 3.0))
+  (check-equal? (filter-maximal '(1 2 3.0 2 3 2 1) <) '(3.0 3))
+
+  (check-equal? (filter-maximal '({} {a} {b} {c}) subset?) '({a} {b} {c}))
+  (check-equal? (filter-maximal '({b} {} {a} {c}) subset?) '({b} {a} {c}))
+  (check-equal? (filter-maximal '({c} {b} {a} {}) subset?) '({c} {b} {a}))
+
+  (check-filter-maximal '({} {a} {b}) subset? '({a} {b}))
+  (check-filter-maximal '({} {a} {b} {a b}) subset? '({a b}))
+  (check-filter-maximal '({} {a} {b} {c} {a b}) subset? '({a b} {c}))
+  (check-filter-maximal '({} {a} {b} {c} {a b} {c a} {b c}) subset?
+                        '({a b} {c a} {b c}))
+  (check-filter-maximal '({} {a} {b} {c} {a b} {c a} {b c}) subset?
+                        '({a b} {c a} {b c}))
+  (check-filter-maximal '({} {a} {b} {c} {b c d} {a b} {c a} {b c}) subset?
+                        '({a b} {c a} {b c d}))
+  (check-filter-maximal '({} {a} {b} {c} {a b c d} {a b} {c a} {b c}) subset?
+                        '({a b c d}))
+  )

turnstile/info.rkt

@@ -5,8 +5,10 @@
 
 (define compile-omit-paths 
   '("examples/rosette"
+    "examples/fomega3.rkt"
     "examples/tests"
-    "examples/trivial.rkt"))
+    "rackunit-typechecking.rkt"
+    "examples/trivial.rkt")) ; needs typed racket
 
 (define test-include-paths
   '("examples/tests/mlish")) ; to include .mlish files
@@ -16,8 +18,10 @@
     "examples/tests/rosette"             ; needs rosette
     "examples/tests/trivial-test.rkt"    ; needs typed/racket
     "examples/tests/mlish/sweet-map.rkt" ; needs sweet-exp
+    "examples/fomega3.rkt"
+    "examples/tests/fomega3-tests.rkt"
     "examples/tests/mlish/bg/README.md"))
 
 (define test-timeouts
-  '(("examples/tests/mlish/generic.mlish" 200)
+  '(("examples/tests/mlish/generic.mlish" 300)
     ("examples/tests/tlb-infer-tests.rkt" 1800)))

turnstile/mode.rkt

@@ -0,0 +1,70 @@
+#lang racket/base
+(provide (struct-out mode)
+         make-mode
+         current-mode
+         with-mode
+         make-param-mode)
+
+
+;; mode object. contains setup routine and teardown routine
+;; as fields.
+(struct mode (setup-fn teardown-fn))
+
+(define (make-mode #:setup [setup-fn void]
+                   #:teardown [teardown-fn void])
+  (mode setup-fn teardown-fn))
+
+
+;; apply the given mode for the successive expressions.
+;; e.g.
+;; (with-mode (mode (λ () (display "before "))
+;;                        (λ () (display "after\n")))
+;;   (display "middle "))
+;; ->
+;;   before middle after
+;;
+;; (with-mode <mode> <body> ...)
+(define-syntax-rule (with-mode mode-expr body ...)
+  (let* ([the-mode mode-expr])
+    ((mode-setup-fn the-mode))
+    (begin0 (parameterize ([current-mode the-mode]) body ...)
+      ((mode-teardown-fn the-mode)))))
+
+
+;; the current set mode. useful for #:submode/mode
+(define current-mode
+  (make-parameter (mode void void)))
+
+
+;; returns a mode that sets the given
+;; parameter to the given value, for its duration.
+;; similar to (parameterize ([P value]) ...)
+;;
+;; make-param-mode : ∀T. (parameterof T) T -> mode?
+(define (make-param-mode P value)
+  (let* ([swap! (λ ()
+                  (let ([cur (P)])
+                    (P value)
+                    (set! value cur)))])
+    (mode swap! swap!)))
+
+
+
+(module+ test
+  (require rackunit)
+
+  (define color (make-parameter 'red))
+
+  (define ->blue (make-param-mode color 'blue))
+  (define ->green (make-param-mode color 'green))
+
+  (with-mode ->blue
+    (check-equal? (color) 'blue))
+  (check-equal? (color) 'red)
+
+  (with-mode ->green
+    (check-equal? (color) 'green)
+    (with-mode ->blue
+      (check-equal? (color) 'blue))
+    (check-equal? (color) 'green))
+  )

turnstile/rackunit-typechecking.rkt

@@ -0,0 +1,4 @@
+#lang racket/base
+;; extends some rackunit forms to test type-checking
+(require "examples/tests/rackunit-typechecking.rkt")
+(provide (all-from-out "examples/tests/rackunit-typechecking.rkt"))

turnstile/scribblings/reference.scrbl

@@ -2,6 +2,7 @@
 
 @(require scribble/example racket/sandbox
           (for-label racket/base
+                     turnstile/mode
                      (except-in turnstile/turnstile ⊢ stx mk-~ mk-?))
           "doc-utils.rkt" "common.rkt")
 
@@ -34,7 +35,7 @@ and then press Control-@litchar{\}.
 
 @; define-typed-syntax---------------------------------------------------------
 @defform*[
-  #:literals (≫ ⊢ ⇒ ⇐ ≻ : --------)
+  #:literals (≫ ⊢ ⇒ ⇐ ≻ --------)
   ((define-typed-syntax (name-id . pattern) ≫
      premise ...
      --------
@@ -50,7 +51,7 @@ and then press Control-@litchar{\}.
           premise ...
           --------
           ⇐-conclusion]
-         [expr-pattern ⇐ key type-pattern ≫
+         [expr-pattern ⇐ key pattern ≫
           premise ...
           --------
           ⇐-conclusion]]
@@ -59,59 +60,122 @@ and then press Control-@litchar{\}.
    [expr-template (code:line @#,racket[quasisyntax] @#,tech:template)]
    [type-template (code:line @#,racket[quasisyntax] @#,tech:template)]
    [key identifier?]
-   [premise (code:line [⊢ tc ...] ooo ...)
-            (code:line [ctx ⊢ tc ...] ooo ...)
-            (code:line [ctx-elem ... ⊢ tc ...] ooo ...)
-            (code:line [ctx ctx ⊢ tc ...] ooo ...)
+   [premise (code:line [⊢ tc ... prem-options] ooo ...)
+            (code:line [ctx-elem ... ⊢ tc ... prem-options] ooo ...)
+            (code:line [ctx ⊢ tc ... prem-options] ooo ...)
+            (code:line [ctx ctx ⊢ tc ... prem-options] ooo ...)
             (code:line [⊢ . tc-elem] ooo ...)
-            (code:line [ctx ⊢ . tc-elem] ooo ...)
             (code:line [ctx-elem ... ⊢ . tc-elem] ooo ...)
+            (code:line [ctx ⊢ . tc-elem] ooo ...)
             (code:line [ctx ctx ⊢ . tc-elem] ooo ...)
             type-relation
+            (code:line #:mode mode-expr (premise ...))
+            (code:line #:submode fn-expr (premise ...))
             (code:line @#,racket[syntax-parse] @#,tech:pat-directive)]
    [ctx (ctx-elem ...)]
-   [ctx-elem (code:line [id ≫ id : type-template] ooo ...)]
+   [ctx-elem (code:line [id ≫ id key template ... ...] ooo ...)
+             (code:line id ooo ...)]
    [tc (code:line tc-elem ooo ...)]
    [tc-elem [expr-template ≫ expr-pattern ⇒ type-pattern]
-             [expr-template ≫ expr-pattern ⇒ key type-pattern]
-             [expr-template ≫ expr-pattern (⇒ key type-pattern) ooo ...]
+             [expr-template ≫ expr-pattern ⇒ key pattern]
+             [expr-template ≫ expr-pattern (⇒ key pattern) ooo ...]
              [expr-template ≫ expr-pattern ⇐ type-template]
-             [expr-template ≫ expr-pattern ⇐ key type-template]
-             [expr-template ≫ expr-pattern (⇐ key type-template) ooo ...]]
+             [expr-template ≫ expr-pattern ⇐ key template]
+             [expr-template ≫ expr-pattern (⇐ key template) ooo ...]]
    [type-relation (code:line [type-template τ= type-template] ooo ...)
                   (code:line [type-template τ= type-template #:for expr-template] ooo ...)
                   (code:line [type-template τ⊑ type-template] ooo ...)
                   (code:line [type-template τ⊑ type-template #:for expr-template] ooo ...)]
+   [prem-options (code:line)
+                 (code:line #:mode mode-expr)
+                 (code:line #:submode fn-expr)]
    [conclusion [⊢ expr-template ⇒ type-template]
-               [⊢ expr-template ⇒ key type-template]
-               [⊢ expr-template (⇒ key type-template) ooo ...]
+               [⊢ expr-template ⇒ key template]
+               [⊢ expr-template (⇒ key template) ooo ...]
                [≻ expr-template]
                [#:error expr-template]]
    [⇐-conclusion [⊢ expr-template]]
    [ooo ...])
  ]{
 
-Defines a macro that additionally performs typechecking. It uses
-@racket[syntax-parse] @tech:stx-pats and @tech:pat-directives and
- additionally allows writing type-judgement-like clauses that interleave
- typechecking and macro expansion.
+Generates a macro definition that also performs type checking. The macro is
+generated from @racket[syntax-parse] @tech:stx-pats and @tech:pat-directives,
+along with type-judgement-like clauses that interleave typechecking and macro
+expansion.  The resulting macro type checks its surface syntax as part of macro
+expansion and the resulting type is attached to the expanded expression.
 
-Type checking is computed as part of macro expansion and the resulting type is
-attached to an expanded expression. In addition, Turnstile supports
-bidirectional type checking clauses. For example @racket[[⊢ e ≫ e- ⇒ τ]]
-declares that expression @racket[e] expands to @racket[e-] and has type
-@racket[τ], where @racket[e] is the input and, @racket[e-] and @racket[τ]
-outputs. Syntactically, @racket[e] is a syntax template position and
-@racket[e-] @racket[τ] are syntax pattern positions.
+@; ----------------------------------------------------------------------------
+@bold{Premises}
 
-A programmer may use the generalized form @racket[[⊢ e ≫ e- (⇒ key τ) ...]] to
-specify propagation of arbitrary values, associated with any number of
-keys. For example, a type and effect system may wish to additionally propagate
-source locations of allocations and mutations. When no key is specified,
-@litchar{:}, i.e., the "type" key, is used.  Dually, one may write @racket[[⊢ e
+@italic{Bidirectional judgements}
+
+Turnstile @racket[define-typed-syntax] rules use bidirectional type checking
+judgements:
+@itemlist[
+  @item{@racket[[⊢ e ≫ e- ⇒ τ]] declares that expression @racket[e] expands to
+@racket[e-] and has type @racket[τ], where @racket[e] is the input and,
+@racket[e-] and @racket[τ] outputs. Syntactically, @racket[e] is a syntax
+template position and @racket[e-] and @racket[τ] are syntax pattern positions.}
+
+  @item{Dually, one may write @racket[[⊢ e
 ≫ e- ⇐ τ]] to check that @racket[e] has type @racket[τ]. Here, both @racket[e]
 and @racket[τ] are inputs (templates) and only @racket[e-] is an
-output (pattern).
+output (pattern).}]
+
+Each bidirectional arrow has a generalized form that associates a key with a
+value, e.g., @racket[[⊢ e ≫ e- (⇒ key pat) ...]]. A programmer may use this
+generalized form to specify propagation of arbitrary values, associated with
+any number of keys. For example, a type and effect system may wish to
+additionally propagate source locations of allocations and mutations. When no
+key is specified, @litchar{:}, i.e., the "type" key, is used.
+
+@italic{Contexts}
+
+A context may be specified to the left of the turnstile. A context element has
+shape @racket[[⊢ x ≫ x- key pat ... ...]] where @racket[x-] is a pattern
+matching the expansion of @racket[x] and the interleaved @racket[key ...] and
+@racket[pat ...] are arbitrary key-value pairs, e.g. a @litchar{:} key and type
+pattern.
+
+A context has @racket[let*] semantics where each binding is in scope for
+subsequent parts of the context. This means type and term variables may be in
+the same context (if properly ordered). In addition, Turnstile allows writing
+two separate contexts, grouped by parens, where bindings in first are in scope
+for the second. This is often convenient for scenarios that Racket's pattern
+language cannot express, e.g., when there two distinct groups of bindings, a
+pattern @racket[x ... y ...] will not work as expected.
+
+For convenience, lone identifiers written to the left of the turnstile are
+automatically treated as type variables.
+
+@italic{Modes}
+
+The keyword @racket[#:mode], when appearing at end of a typechecking rule,
+sets the parameter @racket[current-mode] to the @racket[mode] object supplied
+by @racket[_mode-expr], for the extent of that rule. @racket[#:mode], when
+appearing as its own premise, sets the @racket[current-mode] parameter for the
+extent of all the grouped sub-premises.
+
+The keyword @racket[#:submode] is similar to @racket[#:mode], but it calls
+@racket[(_fn-expr (current-mode))] to obtain the new mode object. Thus,
+@racket[#:mode (_fn-expr (current-mode))] is identical to @racket[#:submode
+_fn-expr].
+
+See @secref{Modes} for more details.
+
+WARNING: @racket[#:mode] is unaware of the backtracking behavior of
+@racket[syntax-parse]. If pattern backtracking escapes a @racket[#:mode] group, it may
+leave @racket[current-mode] in an undesirable state.
+
+
+@; ----------------------------------------------------------------------------
+@bold{Conclusion}
+
+Bidirectional judgements below the conclusion line invert their inputs and
+outputs so that both positions in @racket[[⊢ e- ⇒ τ]] are syntax templates and
+means that @racket[e-] is the output of the generated macro and it has type τ
+attached. The generalized key-value form of the bidirectional judgements may
+also be used in the conclusion.
 
 The @racket[≻] conclusion form is useful in many scenarios where the rule being
 implemented may not want to attach type information. E.g.,
@@ -180,6 +244,13 @@ attach type information to the top-level @tt{x} identifier, so the
 
 ]}
 
+@; ----------------------------------------------------------------------------
+@bold{Note}
+
+@racket[define-typed-syntax] is generated by
+@racket[define-syntax-category]. See @racket[define-syntax-category] for more
+information.
+
 @defform[(define-typerule ....)]{Alias for @racket[define-typed-syntax].}
 @defform[(define-syntax/typecheck ....)]{Alias for @racket[define-typed-syntax].}
 
@@ -189,11 +260,73 @@ A @racket[syntax-parse]-like form that supports
 @racket[define-typed-syntax]-style clauses. In particular, see the
 "rule" part of @racket[define-typed-syntax]'s grammar above.}
 
+@; ~typecheck and ~⊢
+
+@defform[(~typecheck premise ...)]{
+A @racket[syntax-parse] @tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{pattern expander}
+that supports typechecking syntax.
+
+For example the pattern
+
+@racketblock[
+  (~typecheck
+   [⊢ a ≫ a- ⇒ τ_a]
+   [⊢ b ≫ b- ⇐ τ_a])]
+
+typechecks @racket[a] and @racket[b], expecting @racket[b] to have the
+type of @racket[a], and binding @racket[a-] and @racket[b-] to the
+expanded versions.
+
+This is most useful in places where you want to do typechecking in
+something other than a type rule, like in a function or a syntax
+class.
+
+@(let ([ev (make-base-eval)])
+   (ev '(require turnstile/turnstile))
+   @examples[
+     #:eval ev
+     (begin-for-syntax
+       (struct clause [stx- result-type])
+       (code:comment "f : Stx -> Clause")
+       (define (f stx)
+         (syntax-parse stx
+           [(~and [condition:expr body:expr]
+                  (~typecheck
+                   [⊢ condition ≫ condition- ⇐ Bool]
+                   [⊢ body ≫ body- ⇒ τ_body]))
+            (clause #'[condition- body-] #'τ_body)])))
+     ])}
+
+@defform*[[(~⊢ tc ...)]]{
+A shorthand @tech[#:doc '(lib "syntax/scribblings/syntax.scrbl")]{pattern expander}
+for @racket[(~typcheck [⊢ tc ...])].
+
+For example the pattern @racket[(~⊢ a ≫ a- ⇒ τ_a)] typechecks
+@racket[a], binding the expanded version to @racket[a-] and the type
+to @racket[τ_a].
+
+@(let ([ev (make-base-eval)])
+   (ev '(require turnstile/turnstile))
+   @examples[
+     #:eval ev
+     (begin-for-syntax
+       (struct clause [stx- result-type])
+       (code:comment "f : Stx -> Clause")
+       (define (f stx)
+         (syntax-parse stx
+           [(~and [condition:expr body:expr]
+                  (~⊢ condition ≫ condition- ⇐ Bool)
+                  (~⊢ body ≫ body- ⇒ τ_body))
+            (clause #'[condition- body-] #'τ_body)])))
+     ])}
+
 @; define-primop --------------------------------------------------------------
 @defform*[((define-primop typed-op-id τ)
            (define-primop typed-op-id : τ)
            (define-primop typed-op-id op-id τ)
-           (define-primop typed-op-id op-id : τ))]{
+           (define-primop typed-op-id op-id : τ)
+           (define-primop typed-op-id #:as op-id τ)
+           (define-primop typed-op-id #:as op-id : τ))]{
 Defines @racket[typed-op-id] by attaching type @racket[τ] to (untyped) 
 identifier @racket[op-id], e.g.:
 
@@ -203,10 +336,30 @@ When not specified, @racket[op-id] is @racket[typed-op-id] suffixed with
 @litchar{-} (see @secref{racket-}).}
 
 @; define-syntax-category -----------------------------------------------------
-@defform[(define-syntax-category name-id)]{
+@defform*[((define-syntax-category name-id)
+           (define-syntax-category key1 name-id)
+           (define-syntax-category key1 name-id key2))]{
+
 Defines a new "category" of syntax by defining a series of forms and functions.
 Turnstile pre-declares @racket[(define-syntax-category type)], which in turn
- defines the following forms and functions:
+defines the forms and functions below.
+
+Each category of syntax is associated with two keys: @racket[key1] is used when
+attaching values in the category to other syntax, e.g., attaching types to
+terms, and @racket[key2] is used for attaching an additional syntax property to
+values in the category, e.g. using @racket[#%type] to indicate well-formedness.
+
+If no keys are specified, @racket[key1] is @litchar{:} and @racket[key2] is
+@litchar{::}. If only @racket[key1] is given, then @racket[key2] is
+@racket[key1] appended to itself.
+
+Defining another category, e.g., @racket[(define-syntax-category kind)],
+defines a separate set of forms and functions, e.g.,
+@racket[define-kinded-syntax], @racket[define-base-kind], @racket[kind=?], etc.
+
+@; ----------------------------------------------------------------------------
+@italic{The following forms and functions are automatically defined by a
+@racket[(define-syntax-category type)] declaration:}
 
 @margin-note{It's not important to immediately understand all these
 definitions. Some, like @racket[type?] and @racket[mk-type], are
@@ -216,35 +369,48 @@ are probably @racket[define-typed-syntax], and the type-defining forms
 @racket[define-binding-type].}
 
  @itemlist[
- @item{@racket[define-typed-syntax], as described above.
-   Uses @racket[current-typecheck-relation] for typechecking.}
+
+ @item{@racket[define-typed-syntax], as described above. Uses
+@racket[current-typecheck-relation] @racket[current-type-eval] for
+typechecking, and uses @litchar{:} as the key when an explicit key is not specificed in type judgements.}
+
  @item{@defform*[((define-base-type base-type-name-id)
-                  (define-base-type base-type-name-id : kind))]{
+                  (define-base-type base-type-name-id key tag))]{
    Defines a base type. @racket[(define-base-type τ)] in turn defines:
   @itemlist[@item{@racket[τ], an identifier macro representing type @racket[τ].}
             @item{@racket[τ?], a phase 1 predicate recognizing type @racket[τ].}
             @item{@racket[~τ], a phase 1 @tech:pat-expander recognizing type @racket[τ].}]}
 
-  The second form is useful when implementing your own kind system.
-   @racket[#%type] is used as the @tt{kind} when it's not specified.}
- @item{@defform[(define-base-types base-type-name-id ...)]{Defines multiple base types.}}
+  Types defined with @racket[define-base-type] are automatically tagged with a
+@racket[key2]-keyed (as specified in the @racket[define-syntax-category]
+declaration) @racket[#%type] syntax property, unless second form above is used,
+in which case the specified @tt{tag} is attached to the type using the
+specified @tt{key}.}
+
+ @item{@defform[(define-base-types base-type-name-id ...)]{Defines multiple base types, each using the default key.}}
+
  @item{
   @defform[(define-type-constructor name-id option ...)
             #:grammar
            ([option (code:line #:arity op n)
                     (code:line #:arg-variances expr)
                     (code:line #:extra-info stx)])]{
-    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.
-                  Validates inputs and expands to @racket[τ-], attaching kind.}
-            @item{@racket[τ-], an internal macro that expands to the internal
-                  (i.e., fully expanded) type representation. Does not validate
-                  inputs or attach kinds. This macro is useful when creating
-                  a separate kind system, see @racket[define-internal-type-constructor].}
-            @item{@racket[τ?], a phase 1 predicate recognizing type @racket[τ].}
-            @item{@racket[~τ], a phase 1 @tech:pat-expander recognizing type @racket[τ].}]
+    Defines a type constructor (that does not bind type variables).
+    Defining a type constructor @racket[τ] subsequently defines:
+  @itemlist[
+
+    @item{@racket[τ], a macro for constructing an instance of type @racket[τ],
+          with the specified arity.  Validates inputs and expands to
+          @racket[τ-], attaching @racket[#%type] at @tt{key2}.}
+
+    @item{@racket[τ-], an internal macro that expands to the internal
+          (i.e., fully expanded) type representation. Does not validate inputs
+          or attach any extra properties. This macro is useful when creating a
+          separate kind system, see @racket[define-internal-type-constructor].}
+
+    @item{@racket[τ?], a phase 1 predicate recognizing type @racket[τ].}
+          @item{@racket[~τ], a phase 1 @tech:pat-expander recognizing type
+          @racket[τ].}]
 
   The @racket[#:arity] argument specifies the valid shapes
     for the type. For example
@@ -274,16 +440,18 @@ are probably @racket[define-typed-syntax], and the type-defining forms
                          (list covariant))])))]
     
     The @racket[#:extra-info] argument is useful for attaching additional
-    metainformation to types, for example to implement pattern matching.}}
+    metainformation to types, for example to communicate accessors to a pattern
+    matching form.}}
  @item{
   @defform[(define-internal-type-constructor name-id option ...)
             #:grammar
-           ([option (code:line #:arity op n)
-                    (code:line #:arg-variances expr)
+           ([option (code:line #:arg-variances expr)
                     (code:line #:extra-info stx)])]{
-  Like @racket[define-type-constructor], except the surface macro is not defined.
-  Use this form, for example, when creating a separate kind system so that
-  you can still use other Turnstile conveniences like pattern expanders.}}
+
+  Like @racket[define-type-constructor], except the surface macro is not
+defined. Use this form, for example, when creating a separate kind system so
+that you can still use other Turnstile conveniences like pattern expanders.}}
+
  @item{
   @defform[(define-binding-type name-id option ...)
             #:grammar
@@ -311,22 +479,20 @@ are probably @racket[define-typed-syntax], and the type-defining forms
  @item{
   @defform[(define-internal-binding-type name-id option ...)
             #:grammar
-           ([option (code:line #:arity op n)
-                    (code:line #:bvs op n)
-                    (code:line #:arr kindcon)
+           ([option (code:line #:arr kindcon)
                     (code:line #:arg-variances expr)
                     (code:line #:extra-info stx)])]{
-  Analogous to @racket[define-internal-type-constructor].}}
+  Analogous to @racket[define-internal-type-constructor], but for binding types.}}
 @item{
-@defform[(type-out ty-id)]{
-A @racket[provide]-spec that, given @racket[ty-id], provides @racket[ty-id], 
+@defform[(type-out ty-id ...)]{
+A @racket[provide]-spec that, for each given @racket[ty-id], provides @racket[ty-id],
 and provides @racket[for-syntax] a predicate @racket[ty-id?] and a @tech:pat-expander @racket[~ty-id].}}
 
 @item{@defparam[current-type-eval type-eval type-eval]{
  A phase 1 parameter for controlling "type evaluation". A @racket[type-eval]
 function consumes and produces syntax. It is typically used to convert a type
 into a canonical representation. The @racket[(current-type-eval)] is called
-immediately before attacing a type to a syntax object, i.e., by
+immediately before attaching a type to a syntax object, i.e., by
 @racket[assign-type].
 
  It defaults to full expansion, i.e., @racket[(lambda (stx) (local-expand stx 'expression null))], and also stores extra surface syntax information used for error reporting.
@@ -415,11 +581,23 @@ equality, but includes alpha-equivalence.
     to validate types.
   Binds a @racket[norm] attribute to the type's expanded representation.}}
  @item{@defthing[type-bind stx-class]{A syntax class recognizing
-     syntax objects with shape @racket[[x:id (~datum :) τ:type]].}}
+     syntax objects with shape @racket[[x:id (~datum :) τ:type]].
+  Binds a @racket[x] attribute to the binding identifier, and a @racket[type] attribute
+  to the type's expanded representation.}}
  @item{@defthing[type-ctx stx-class]{A syntax class recognizing
-      syntax objects with shape @racket[(b:type-bind ...)].}}
+      syntax objects with shape @racket[(b:type-bind ...)].
+  Binds a @racket[x] attribute to the binding identifiers, and a @racket[type] attribute
+  to the expanded representation of the types.}}
  @item{@defthing[type-ann stx-class]{A syntax class recognizing
-       syntax objects with shape @racket[{τ:type}] where the braces are required.}}
+       syntax objects with shape @racket[{τ:type}] where the braces are required.
+  Binds a @racket[norm] attribute to the type's expanded representation.}}
+
+ @item{@defproc[(assign-type [e syntax?] [τ syntax?]) syntax?]{
+Phase 1 function that calls @racket[current-type-eval] on @racket[τ] and attaches it to @racket[e] using @tt{key1}.}}
+
+ @item{@defproc[(typeof [e expr-stx]) type-stx]{
+Phase 1 function returning type of @racket[e], at @tt{key1}.}}
+
  ]
 }
 
@@ -460,13 +638,14 @@ Reuses @racket[name]s from @racket[base-lang].}
 
 To help avoid name conflicts, Turnstile re-provides all Racket bindings with a
 @litchar{-} suffix. These bindings are automatically used in some cases, e.g.,
-@racket[define-primop], but in general are useful for avoiding name conflicts.
+@racket[define-primop], but in general are useful for avoiding name conflicts,
+particularly for commonly used macros like @racket[#%app].
 
 @; Sec: turnstile/lang ----------------------------------------------
 @section[#:tag "turnstilelang"]{@hash-lang[] @racketmodname[turnstile]/lang}
 
 Languages implemented using @hash-lang[] @racketmodname[turnstile]
-must additionally provide @racket[#%module-begin] and other forms required by
+must manually provide @racket[#%module-begin] and other forms required by
 Racket. 
 
 For convenience, Turnstile additionally supplies @hash-lang[]
@@ -482,28 +661,40 @@ necessary to call these directly, since @racket[define-typed-syntax] and other
 forms already do so, but some type systems may require extending some
 functionality.
 
-@defproc[(assign-type [e syntax?] [τ syntax?]) syntax?]{
-Phase 1 function that calls @racket[current-type-eval] on @racket[τ] and attaches it to @racket[e]}
-
-@defproc[(typeof [e expr-stx]) type-stx]{
-Phase 1 function returning type of @racket[e].}
-
 @defproc[(infer [es (listof expr-stx)]
                 [#:ctx ctx (listof bindings) null]
-                [#:tvctx tvctx (listof tyvar-bindings) null]) (list tvs xs es τs)]{
-Phase 1 function expanding a list of expressions, in the given contexts and computes their types.
- Returns the expanded expressions, their types, and expanded identifiers from the
- contexts, e.g. @racket[(infer (list #'(+ x 1)) #:ctx ([x : Int]))].}
+                [#:tvctx tvctx (listof tyvar-bindings) null]
+                [#:tag tag symbol? ':])
+                (list tvs xs es τs)]{
+
+Phase 1 function expanding a list of expressions, in the given contexts and
+computes their types. Returns the expanded expressions, their types, and
+expanded identifiers from the contexts, e.g.
+
+@racket[(infer (list #'(+ x 1)) #:ctx ([x : Int]))]
+
+might return
+
+@racket[(list #'() #'(x-) #'((#%plain-app x- 1)) #'(Int))].
+
+The context elements have the same shape as in @racket[define-typed-syntax].
+The contexts use @racket[let*] semantics, where each binding is in scope for
+subsequent bindings.
+
+Use the @tt{tag} keyword argument to specify the key for the
+returned "type". The default key is @litchar{:}. For example, a programmer may
+want to specify a @litchar{::} key when using @racket[infer] to compute the
+kinds on types.}
 
 @defproc[(subst [τ type-stx]
-                [x id]
+                [x identifier?]
                 [e expr-stx]
                 [cmp (-> identifier? identifier? boolean?) bound-identifier=?]) expr-stx]{
 Phase 1 function that replaces occurrences of @racket[x], as determined by @racket[cmp], with
  @racket[τ] in @racket[e].}
 
 @defproc[(substs [τs (listof type-stx)]
-                 [xs (listof id)]
+                 [xs (listof identifier?)]
                  [e expr-stx]
                  [cmp (-> identifier? identifier? boolean?) bound-identifier=?]) expr-stx]{
 Phase 1 function folding @racket[subst] over the given @racket[τs] and @racket[xs].}
@@ -527,12 +718,75 @@ The possible variances are:
 
 @defproc[(variance? [v any/c]) boolean/c]{
  Predicate that recognizes the variance values.}
-                                      
+
+
+@section{Modes}
+
+@defmodule[turnstile/mode #:use-sources (turnstile/mode)]
+@(define mode-ev
+   (let ([ev (make-base-eval)])
+     (ev '(require turnstile/mode))
+     ev))
+
+Modes are typically used by the @racket[#:mode] and @racket[#:submode]
+keywords in @racket[define-typed-syntax] (and related forms). When judgements
+are parameterized by a @racket[mode] value, the parameter
+@racket[current-mode] is set to that value for the extend of the
+sub-premises. Additionally, the function @racket[mode-setup-fn] is called
+before setting @racket[current-mode], and the function
+@racket[mode-teardown-fn] is called after @racket[current-mode] is restored to
+its previous value.
+
+@defstruct*[mode ([setup-fn (-> any)] [teardown-fn (-> any)])]{
+  Structure type for modes. Modes can be used to parameterize type judgements
+  or groups of type judgements, to give additional context and to help enable
+  flow-sensitive languages.
+
+  User defined modes should be defined as structs that inherit from @racket[mode].
+}
+
+@defproc[(make-mode [#:setup setup-fn (-> any) void]
+                    [#:teardown teardown-fn (-> any) void]) mode?]{
+  Constructs a new @racket[mode] object with the given setup and teardown functions.
+}
+
+@defparam[current-mode mode mode? #:value (make-mode)]{
+  A parameter that holds the current mode. Typically parameterized using the keywords
+  @racket[#:mode] and @racket[#:submode] from @racket[define-typed-syntax] forms.
+}
+
+@defform[(with-mode mode-expr body ...+)
+         #:contracts ([mode-expr mode?])]{
+  The result of @racket[with-mode] is the result of the last @racket[_body].
+  The parameter @racket[current-mode] is assigned to the result of
+  @racket[_mode-expr] for the extent of the @racket[_body] expressions. The
+  function @racket[mode-setup-fn] is called on the result of
+  @racket[_mode-expr] before @racket[current-mode] is set, and the function
+  @racket[mode-teardown-fn] is called after @racket[current-mode] is restored
+  to its previous value.
+
+  @examples[#:eval mode-ev
+    (define-struct (my-mode mode) ())
+    (define M (make-my-mode (λ () (displayln "M setup"))
+                            (λ () (displayln "M teardown"))))
+    (with-mode M
+      (displayln (current-mode)))]}
+
+@defproc[(make-param-mode [param parameter?] [value any/c]) mode?]{
+  Creates a @racket[mode] that assigns the given parameter to the given
+  value for the extent of the mode.
+
+  @examples[#:eval mode-ev
+    (define current-scope (make-parameter 'outer))
+    (with-mode (make-param-mode current-scope 'inner)
+      (displayln (current-scope)))]}
+
+
 @section{Miscellaneous Syntax Object Functions}
 
 These are all phase 1 functions.
 
-@defproc[(stx-length [stx syntax?]) Nat]{Analogous to @racket[length].}
+@defproc[(stx-length [stx syntax?]) exact-nonnegative-integer?]{Analogous to @racket[length].}
 @defproc[(stx-length=? [stx1 syntax?] [stx2 syntax?]) boolean?]{
  Returns true if two syntax objects are of equal length.}
 @defproc[(stx-andmap [p? (-> syntax? boolean?)] [stx syntax?]) (listof syntax?)]{

turnstile/turnstile.rkt

@@ -1,13 +1,16 @@
 #lang racket/base
 
-(provide (except-out (all-from-out macrotypes/typecheck) 
+(provide (except-out (all-from-out macrotypes/typecheck)
                      -define-typed-syntax -define-syntax-category)
-         define-typed-syntax define-syntax-category
+         define-typed-syntax
+         define-typed-variable-syntax
+         define-syntax-category
          (rename-out [define-typed-syntax define-typerule]
                      [define-typed-syntax define-syntax/typecheck])
-         (for-syntax syntax-parse/typed-syntax
+         (for-syntax syntax-parse/typecheck
+                     ~typecheck ~⊢
                      (rename-out
-                      [syntax-parse/typed-syntax syntax-parse/typecheck])))
+                      [syntax-parse/typecheck syntax-parse/typed-syntax])))
 
 (require (except-in (rename-in
                      macrotypes/typecheck
@@ -25,16 +28,18 @@
   ;;   xs-   ; a stx-list of the expanded versions of variables in the ctx
   ;;   es*-  ; a nested list a depth given by the depth argument, with the same structure
   ;;         ; as es*, containing the expanded es*, with the types attached
-  (define (infer/depth #:ctx ctx #:tvctx tvctx depth es* origs*)
+  (define (infer/depth #:ctx ctx #:tvctx tvctx depth es* origs*
+                       #:tag [tag (current-tag)])
     (define flat (stx-flatten/depth-lens depth))
     (define es (lens-view flat es*))
     (define origs (lens-view flat origs*))
     (define/with-syntax [tvxs- xs- es- _]
-      (infer #:tvctx tvctx #:ctx ctx (stx-map pass-orig es origs)))
-    (define es*- (lens-set flat es* #'es-))
+      (infer #:tvctx tvctx #:ctx ctx (stx-map pass-orig es origs) #:tag tag))
+    (define es*- (lens-set flat es* #`es-))
     (list #'tvxs- #'xs- es*-))
   ;; infers/depths
-  (define (infers/depths clause-depth tc-depth tvctxs/ctxs/ess/origss*)
+  (define (infers/depths clause-depth tc-depth tvctxs/ctxs/ess/origss*
+                         #:tag [tag (current-tag)])
     (define flat (stx-flatten/depth-lens clause-depth))
     (define tvctxs/ctxs/ess/origss
       (lens-view flat tvctxs/ctxs/ess/origss*))
@@ -42,7 +47,7 @@
       (for/list ([tvctx/ctx/es/origs (in-list (stx->list tvctxs/ctxs/ess/origss))])
         (match-define (list tvctx ctx es origs)
           (stx->list tvctx/ctx/es/origs))
-        (infer/depth #:tvctx tvctx #:ctx ctx tc-depth es origs)))
+        (infer/depth #:tvctx tvctx #:ctx ctx tc-depth es origs #:tag tag)))
     (define res
       (lens-set flat tvctxs/ctxs/ess/origss* tcs))
     res)
@@ -61,8 +66,9 @@
 (module syntax-classes racket/base
   (provide (all-defined-out))
   (require (for-meta 0 (submod ".." typecheck+))
-           (for-meta -1 (submod ".." typecheck+) 
-                     (except-in macrotypes/typecheck #%module-begin mk-~ mk-?))
+           (for-meta -1 (submod ".." typecheck+)
+                     (except-in macrotypes/typecheck #%module-begin mk-~ mk-?)
+                     "mode.rkt")
            (for-meta -2 (except-in macrotypes/typecheck #%module-begin)))
   (define-syntax-class ---
     [pattern dashes:id
@@ -86,50 +92,51 @@
   (define (add-lists stx n)
     (cond [(zero? n) stx]
           [else (add-lists (list stx) (sub1 n))]))
-  
+
   (define-splicing-syntax-class props
     [pattern (~and (~seq stuff ...) (~seq (~seq k:id v) ...))])
   (define-splicing-syntax-class ⇒-prop
     #:datum-literals (⇒)
     #:attributes (e-pat)
-    [pattern (~or (~seq ⇒ tag-pat ; implicit : tag
-                        (~parse tag #':) (tag-prop:⇒-prop) ...)
+    [pattern (~or (~seq ⇒ tag-pat ; implicit tag
+                          (~parse tag #',(current-tag))
+                          (tag-prop:⇒-prop) ...)
                   (~seq ⇒ tag:id tag-pat (tag-prop:⇒-prop) ...)) ; explicit tag
              #:with e-tmp (generate-temporary)
              #:with e-pat
              #'(~and e-tmp
                      (~parse
                       (~and tag-prop.e-pat ... tag-pat)
-                      (typeof #'e-tmp #:tag 'tag)))])
+                      (detach #'e-tmp `tag)))])
   (define-splicing-syntax-class ⇒-prop/conclusion
     #:datum-literals (⇒)
     #:attributes (tag tag-expr)
-    [pattern (~or (~seq ⇒ tag-stx 
-                        (~parse tag #':)
-                        (~parse (tag-prop.tag ...) #'())
-                        (~parse (tag-prop.tag-expr ...) #'()))
+    [pattern (~or (~seq ⇒ tag-stx ; implicit tag
+                          (~parse tag #',(current-tag))
+                          (~parse (tag-prop.tag ...) #'())
+                          (~parse (tag-prop.tag-expr ...) #'()))
                   (~seq ⇒ tag:id tag-stx (tag-prop:⇒-prop/conclusion) ...))
              #:with tag-expr
              (for/fold ([tag-expr #'#`tag-stx])
-                       ([k (in-list (syntax->list #'[tag-prop.tag ...]))]
-                        [v (in-list (syntax->list #'[tag-prop.tag-expr ...]))])
+                       ([k (in-stx-list #'[tag-prop.tag ...])]
+                        [v (in-stx-list #'[tag-prop.tag-expr ...])])
                (with-syntax ([tag-expr tag-expr] [k k] [v v])
-                 #'(assign-type tag-expr #:tag 'k v)))])
+                 #'(attach tag-expr `k ((current-ev) v))))])
   (define-splicing-syntax-class ⇐-prop
-    #:datum-literals (⇐ :)
+    #:datum-literals (⇐)
     #:attributes (τ-stx e-pat)
-    [pattern (~or (~seq ⇐ τ-stx)
-                  (~seq ⇐ : τ-stx))
+    [pattern (~or (~seq ⇐ τ-stx (~parse tag #',(current-tag)))
+                  (~seq ⇐ tag:id τ-stx))
              #:with e-tmp (generate-temporary)
              #:with τ-tmp (generate-temporary)
              #:with τ-exp (generate-temporary)
              #:with e-pat
-             #'(~and e-tmp
+             #`(~and e-tmp
                      (~parse τ-exp (get-expected-type #'e-tmp))
-                     (~parse τ-tmp (typeof #'e-tmp))
+                     (~parse τ-tmp (detach #'e-tmp `tag))
                      (~parse
                       (~post
-                       (~fail #:when (and (not (typecheck? #'τ-tmp #'τ-exp))
+                       (~fail #:when (and (not (check? #'τ-tmp #'τ-exp))
                                           (get-orig #'e-tmp))
                               (typecheck-fail-msg/1 #'τ-exp #'τ-tmp #'e-tmp)))
                       (get-orig #'e-tmp)))])
@@ -153,6 +160,12 @@
   (define-splicing-syntax-class id+props+≫
     #:datum-literals (≫)
     #:attributes ([x- 1] [ctx 1])
+    [pattern (~seq (~and X:id (~not _:elipsis)))
+             #:with [x- ...] #'[_]
+             #:with [ctx ...] #'[[X :: #%type]]]
+    [pattern (~seq X:id ooo:elipsis)
+             #:with [x- ...] #'[_ ooo]
+             #:with [ctx ...] #'[[X :: #%type] ooo]]
     [pattern (~seq [x:id ≫ x--:id props:props])
              #:with [x- ...] #'[x--]
              #:with [ctx ...] #'[[x props.stuff ...]]]
@@ -165,7 +178,7 @@
              #:with [x- ...] #'[ctx1.x- ... ...]
              #:with [ctx ...] #'[ctx1.ctx ... ...]])
   (define-syntax-class tc-elem
-    #:datum-literals (⊢ ⇒ ⇐ ≫ :)
+    #:datum-literals (⊢ ⇒ ⇐ ≫)
     #:attributes (e-stx e-stx-orig e-pat)
     [pattern [e-stx ≫ e-pat* props:⇒-props]
              #:with e-stx-orig #'e-stx
@@ -187,20 +200,21 @@
              #`(~post
                 #,(with-depth #'tc.e-pat #'[ooo ...]))])
   (define-syntax-class tc*
-    #:attributes (depth es-stx es-stx-orig es-pat)
+    #:attributes (depth es-stx es-stx-orig es-pat wrap-computation)
     [pattern tc:tc-elem
              #:with depth 0
              #:with es-stx #'tc.e-stx
              #:with es-stx-orig #'tc.e-stx-orig
-             #:with es-pat #'tc.e-pat]
-    [pattern (tc:tc ...)
+             #:with es-pat #'tc.e-pat
+             #:attr wrap-computation (λ (stx) stx)]
+    [pattern (tc:tc ... opts:tc-post-options ...)
              #:do [(define ds (stx-map syntax-e #'[tc.depth ...]))
                    (define max-d (apply max 0 ds))]
              #:with depth (add1 max-d)
              #:with [[es-stx* es-stx-orig* es-pat*] ...]
-             (for/list ([tc-es-stx (in-list (syntax->list #'[tc.es-stx ...]))]
-                        [tc-es-stx-orig (in-list (syntax->list #'[tc.es-stx-orig ...]))]
-                        [tc-es-pat (in-list (syntax->list #'[tc.es-pat ...]))]
+             (for/list ([tc-es-stx (in-stx-list #'[tc.es-stx ...])]
+                        [tc-es-stx-orig (in-stx-list #'[tc.es-stx-orig ...])]
+                        [tc-es-pat (in-stx-list #'[tc.es-pat ...])]
                         [d (in-list ds)])
                (list
                 (add-lists tc-es-stx (- max-d d))
@@ -208,7 +222,19 @@
                 (add-lists tc-es-pat (- max-d d))))
              #:with es-stx #'[es-stx* ...]
              #:with es-stx-orig #'[es-stx-orig* ...]
-             #:with es-pat #'[es-pat* ...]])
+             #:with es-pat #'[es-pat* ...]
+             #:attr wrap-computation
+             (λ (stx)
+               (foldr (λ (fun stx) (fun stx))
+                      stx
+                      (attribute opts.wrap)))])
+  (define-splicing-syntax-class tc-post-options
+    #:attributes (wrap)
+    [pattern (~seq #:mode mode-expr)
+             #:attr wrap (λ (stx) #`(with-mode mode-expr #,stx))]
+    [pattern (~seq #:submode fn-expr)
+             #:attr wrap (λ (stx) #`(with-mode (fn-expr (current-mode)) #,stx))]
+    )
   (define-splicing-syntax-class tc-clause
     #:attributes (pat)
     #:datum-literals (⊢)
@@ -226,58 +252,58 @@
               #'[ooo ...])
              #:with tvctxs/ctxs/ess/origs
              (with-depth
-              #'[(tvctx.ctx ...) (ctx.ctx ...) tc.es-stx tc.es-stx-orig]
+              #`[(tvctx.ctx ...) (ctx.ctx ...) tc.es-stx tc.es-stx-orig]
               #'[ooo ...])
-             #:with pat
-             #'(~post
-                (~post
-                 (~parse
-                  tcs-pat
-                  (infers/depths 'clause-depth 'tc.depth #'tvctxs/ctxs/ess/origs))))]
+             #:with inf #'(infers/depths 'clause-depth
+                                         'tc.depth
+                                         #`tvctxs/ctxs/ess/origs
+                                         #:tag (current-tag))
+             #:with inf+ ((attribute tc.wrap-computation) #'inf)
+             #:with pat #`(~post (~post (~parse tcs-pat inf+)))]
     )
   (define-splicing-syntax-class clause
     #:attributes (pat)
-    #:datum-literals (τ⊑ τ=)
+    #:datum-literals (τ⊑ τ=) ; TODO: drop the τ in τ⊑ and τ=
     [pattern :tc-clause]
     [pattern [a τ⊑ b]
              #:with pat
              #'(~post
-                (~fail #:unless (typecheck? #'a #'b)
+                (~fail #:unless (check? #'a #'b)
                        (typecheck-fail-msg/1/no-expr #'b #'a)))]
     [pattern [a τ⊑ b #:for e]
              #:with pat
              #'(~post
-                (~fail #:unless (typecheck? #'a #'b)
+                (~fail #:unless (check? #'a #'b)
                        (typecheck-fail-msg/1 #'b #'a #'e)))]
     [pattern (~seq [a τ⊑ b] ooo:elipsis)
              #:with pat
              #'(~post
-                (~fail #:unless (typechecks? #'[a ooo] #'[b ooo])
+                (~fail #:unless (checks? #'[a ooo] #'[b ooo])
                        (typecheck-fail-msg/multi/no-exprs #'[b ooo] #'[a ooo])))]
     [pattern (~seq [a τ⊑ b #:for e] ooo:elipsis)
              #:with pat
              #'(~post
-                (~fail #:unless (typechecks? #'[a ooo] #'[b ooo])
+                (~fail #:unless (checks? #'[a ooo] #'[b ooo])
                        (typecheck-fail-msg/multi #'[b ooo] #'[a ooo] #'[e ooo])))]
     [pattern [a τ= b]
              #:with pat
              #'(~post
-                (~fail #:unless ((current-type=?) #'a #'b)
+                (~fail #:unless ((current=?) #'a #'b)
                        (typecheck-fail-msg/1/no-expr #'b #'a)))]
     [pattern [a τ= b #:for e]
              #:with pat
              #'(~post
-                (~fail #:unless ((current-type=?) #'a #'b)
+                (~fail #:unless ((current=?) #'a #'b)
                        (typecheck-fail-msg/1 #'b #'a #'e)))]
     [pattern (~seq [a τ= b] ooo:elipsis)
              #:with pat
              #'(~post
-                (~fail #:unless (types=? #'[a ooo] #'[b ooo])
+                (~fail #:unless (=s? #'[a ooo] #'[b ooo])
                        (typecheck-fail-msg/multi/no-exprs #'[b ooo] #'[a ooo])))]
     [pattern (~seq [a τ= b #:for e] ooo:elipsis)
              #:with pat
              #'(~post
-                (~fail #:unless (types=? #'[a ooo] #'[b ooo])
+                (~fail #:unless (=s? #'[a ooo] #'[b ooo])
                        (typecheck-fail-msg/multi #'[b ooo] #'[a ooo] #'[e ooo])))]
     [pattern (~seq #:when condition:expr)
              #:with pat
@@ -294,9 +320,29 @@
     [pattern (~seq #:fail-unless condition:expr message:expr)
              #:with pat
              #'(~post (~fail #:unless condition message))]
+    [pattern (~seq #:mode mode-expr (sub-clause:clause ...))
+             #:with (the-mode tmp) (generate-temporaries #'(the-mode tmp))
+             #:with pat
+             #'(~and (~do (define the-mode mode-expr)
+                          ((mode-setup-fn the-mode))
+                          (define tmp (current-mode))
+                          (current-mode the-mode))
+                     sub-clause.pat ...
+                     (~do (current-mode tmp)
+                          ((mode-teardown-fn the-mode))))]
+    [pattern (~seq #:submode fn-expr (sub-clause:clause ...))
+             #:with (the-mode tmp) (generate-temporaries #'(the-mode tmp))
+             #:with pat
+             #'(~and (~do (define the-mode (fn-expr (current-mode)))
+                          ((mode-setup-fn the-mode))
+                          (define tmp (current-mode))
+                          (current-mode the-mode))
+                     sub-clause.pat ...
+                     (~do (current-mode tmp)
+                          ((mode-teardown-fn the-mode))))]
     )
   (define-syntax-class last-clause
-    #:datum-literals (⊢ ≫ ≻ ⇒ ⇐ :)
+    #:datum-literals (⊢ ≫ ≻ ⇒ ⇐)
     #:attributes ([pat 0] [stuff 1] [body 0])
     ;; ⇒ conclusion
     [pattern (~or [⊢ pat ≫ e-stx props:⇒-props/conclusion]
@@ -304,21 +350,25 @@
              #:with [stuff ...] #'[]
              #:with body:expr
              (for/fold ([body #'(quasisyntax/loc this-syntax e-stx)])
-                       ([k (in-list (syntax->list #'[props.tag ...]))]
-                        [v (in-list (syntax->list #'[props.tag-expr ...]))])
+                       ([k (in-stx-list #'[props.tag ...])]
+                        [v (in-stx-list #'[props.tag-expr ...])])
                (with-syntax ([body body] [k k] [v v])
-                 #'(assign-type body #:tag 'k v)))]
+                 #`(attach body `k ((current-ev) v))))]
     ;; ⇒ conclusion, implicit pat
     [pattern (~or [⊢ e-stx props:⇒-props/conclusion]
                   [⊢ [e-stx props:⇒-props/conclusion]])
              #:with :last-clause #'[⊢ [_ ≫ e-stx . props]]]
     ;; ⇐ conclusion
-    [pattern [⊢ (~and e-stx (~not [_ ≫ . rst]))]
-             #:with :last-clause #'[⊢ [_ ≫ e-stx ⇐ : _]]]
-    [pattern (~or [⊢ pat* ≫ e-stx ⇐ τ-pat]
-                  [⊢ pat* ≫ e-stx ⇐ : τ-pat]
-                  [⊢ [pat* ≫ e-stx ⇐ τ-pat]]
-                  [⊢ [pat* ≫ e-stx ⇐ : τ-pat]])
+    [pattern [⊢ (~and e-stx (~not [_ ≫ . rst]))] ;; TODO: this current tag isnt right?
+             #:with :last-clause #`[⊢ [_ ≫ e-stx ⇐ #,(datum->stx #'h (current-tag)) _]]]
+    [pattern (~or [⊢ pat* (~seq ≫ e-stx
+                                ⇐ τ-pat ; implicit tag
+                                  (~parse tag #',(current-tag)))]
+                  [⊢ pat* ≫ e-stx ⇐ tag:id τ-pat] ; explicit tag
+                  [⊢ [pat* (~seq ≫ e-stx
+                                 ⇐ τ-pat ; implicit tag
+                                   (~parse tag #',(current-tag)))]]
+                  [⊢ [pat* ≫ e-stx ⇐ tag:id τ-pat]]) ; explicit tag
              #:with stx (generate-temporary 'stx)
              #:with τ (generate-temporary #'τ-pat)
              #:with pat
@@ -330,7 +380,7 @@
                      (~parse τ-pat #'τ))
              #:with [stuff ...] #'[]
              #:with body:expr
-             #'(assign-type (quasisyntax/loc this-syntax e-stx) #`τ)]
+                    #'(attach (quasisyntax/loc this-syntax e-stx) `tag #`τ)]
     ;; macro invocations
     [pattern [≻ e-stx]
              #:with :last-clause #'[_ ≻ e-stx]]
@@ -346,11 +396,12 @@
              #:with body:expr
              ;; should never get here
              #'(error msg)])
-  (define-splicing-syntax-class pat #:datum-literals (⇐ :)
+  (define-splicing-syntax-class pat #:datum-literals (⇐)
     [pattern (~seq pat)
              #:attr transform-body identity]
-    [pattern (~or (~seq pat* left:⇐ τ-pat)
-                  (~seq pat* left:⇐ : τ-pat))
+    [pattern (~or (~seq pat* left:⇐ τ-pat ; implicit tag
+                        (~parse tag #',(current-tag)))
+                  (~seq pat* left:⇐ tag:id τ-pat)) ; explicit tag
              #:with stx (generate-temporary 'stx)
              #:with τ (generate-temporary #'τ-pat)
              #:with b (generate-temporary 'body)
@@ -363,11 +414,10 @@
                      (~parse τ-pat #'τ))
              #:attr transform-body
              (lambda (body)
-               #`(let ([b #,body])
-                   (when (and (typeof b)
-                              (not (typecheck? (typeof b) #'τ)))
-                     (raise-⇐-expected-type-error #'left b #'τ (typeof b)))
-                   (assign-type b #'τ)))])
+               #`(let* ([b #,body][ty-b (detach b `tag)])
+                   (when (and ty-b (not (check? ty-b #'τ)))
+                     (raise-⇐-expected-type-error #'left b #'τ ty-b))
+                   (attach b `tag #'τ)))])
   (define-syntax-class rule #:datum-literals (≫)
     [pattern [pat:pat ≫
               clause:clause ...
@@ -388,62 +438,80 @@
 (require (for-meta 1 'syntax-classes)
          (for-meta 2 'syntax-classes))
 
-(define-syntax define-typed-syntax
-  (lambda (stx)
-    (syntax-parse stx
-      ;; single-clause def
-      [(def (name:id . pats) . rst)
-       ;; cannot always bind name as pat var, eg #%app, so replace with _
-       #:with r:rule #'[(_ . pats) . rst]
-       #'(-define-typed-syntax name r.norm)]
-      ;; multi-clause def
-      [(def name:id
-         (~and (~seq kw-stuff ...) :stxparse-kws)
-         rule:rule
-         ...+)
-       #'(-define-typed-syntax
-          name
-          kw-stuff ...
-          rule.norm
-          ...)])))
-
 (begin-for-syntax
-  (define-syntax syntax-parse/typed-syntax
-    (lambda (stx)
-      (syntax-parse stx
-        [(stxparse
-          stx-expr
+  (define-syntax ~typecheck
+    (pattern-expander
+     (syntax-parser
+       [(_ clause:clause ...)
+        #'(~and clause.pat ...)])))
+  (define-syntax ~⊢
+    (pattern-expander
+     (syntax-parser
+       [(_ . stuff)
+        #'(~typecheck [⊢ . stuff])])))
+
+  (define-syntax syntax-parse/typecheck
+    (syntax-parser
+      [(_ stx-expr
           (~and (~seq kw-stuff ...) :stxparse-kws)
-          rule:rule
-          ...)
-         #'(syntax-parse
-               stx-expr
-             kw-stuff ...
-             rule.norm
-             ...)]))))
+          rule:rule ...)
+       #'(syntax-parse stx-expr kw-stuff ... rule.norm ...)])))
+
+;; macrotypes/typecheck.rkt already defines (-define-syntax-category type);
+;; - just add the "def-named-syntax" part of the def-stx-cat macro below
+;; TODO: eliminate code dup with def-named-stx in define-stx-cat below?
+(define-syntax define-typed-syntax
+  (syntax-parser
+    ;; single-clause def
+    [(_ (rulename:id . pats) . rst)
+     ;; using #'rulename as patvar may cause problems, eg #%app, so use _
+     #'(define-typed-syntax rulename [(_ . pats) . rst])]
+    ;; multi-clause def
+    ;; - let stx-parse/tychk match :rule (dont double-match)
+    [(_ rulename:id
+        (~and (~seq kw-stuff ...) :stxparse-kws)
+        rule ...+)
+     #'(define-syntax (rulename stx)
+         (parameterize ([current-check-relation (current-typecheck-relation)]
+                        [current-ev (current-type-eval)]
+                        [current-tag (type-key1)])
+           (syntax-parse/typecheck stx kw-stuff ... rule ...)))]))
+
+(define-syntax define-typed-variable-syntax
+  (syntax-parser
+    [(_ (~optional (~seq #:name name:id) #:defaults ([name (generate-temporary '#%var)]))
+        (~and (~seq kw-stuff ...) :stxparse-kws)
+        rule:rule ...+)
+     #'(begin
+         (define-typed-syntax name kw-stuff ... rule ...)
+         (begin-for-syntax
+           (current-var-assign (macro-var-assign #'name))))]))
 
 (define-syntax define-syntax-category
- (lambda (stx)
-   (syntax-parse stx
-    [(_ name:id)
+  (syntax-parser
+    [(_ name:id)        ; default key1 = ': for types
+     #'(define-syntax-category : name)]
+    [(_ key:id name:id) ; default key2 = ':: for kinds
+     #`(define-syntax-category key name #,(mkx2 #'key))]
+    [(_ key1:id name:id key2:id)
      #:with def-named-syntax (format-id #'name "define-~aed-syntax" #'name)
-     #:with check-relation (format-id #'name "current-~acheck-relation" #'name)
+     #:with new-check-rel (format-id #'name "current-~acheck-relation" #'name)
+     #:with new-eval (format-id #'name "current-~a-eval" #'name)
      #'(begin
-        (-define-syntax-category name)
-        (define-syntax (def-named-syntax stx)
-          (syntax-parse stx
+        (-define-syntax-category key1 name key2)
+        (define-syntax def-named-syntax
+          (syntax-parser
             ;; single-clause def
-           [(_ (rulename:id . pats) . rst)
-            ;; cannot bind name as pat var, eg #%app, so replace with _
-            #:with r #'[(_ . pats) . rst]
-            #'(define-syntax (rulename stxx)
-                (parameterize ([current-typecheck-relation (check-relation)])
-                  (syntax-parse/typed-syntax stxx r)))]
-           ;; multi-clause def
-           [(_ rulename:id
+            [(_ (rulename:id . pats) . rst)
+             ;; #'rulename as a pat var may cause problems, eg #%app, so use _
+             #'(def-named-syntax rulename [(_ . pats) . rst])]
+            ;; multi-clause def
+            [(_ rulename:id
               (~and (~seq kw-stuff (... ...)) :stxparse-kws)
-              rule:rule (... ...+))
-            #'(define-syntax (rulename stxx)
-                (parameterize ([current-typecheck-relation (check-relation)])
-                  (syntax-parse/typed-syntax stxx kw-stuff (... ...)
-                    rule (... ...))))])))])))
+              rule (... ...+)) ; let stx-parse/tychk match :rule stxcls
+            #'(define-syntax (rulename stx)
+                (parameterize ([current-check-relation (new-check-rel)]
+                               [current-ev (new-eval)]
+                               [current-tag 'key1])
+                  (syntax-parse/typecheck stx kw-stuff (... ...)
+                    rule (... ...))))])))]))