#lang typed-lang-builder
(require racket/fixnum racket/flonum
         (for-syntax macrotypes/type-constraints macrotypes/variance-constraints))

(extends "ext-stlc.rkt" #:except #%app λ → + - void = zero? sub1 add1 not let let* and #%datum begin
          #:rename [~→ ~ext-stlc:→])
(reuse inst #:from "sysf.rkt") 
(require (only-in "ext-stlc.rkt" → →?))
(require (only-in "sysf.rkt" ~∀ ∀ ∀? Λ))
(reuse × tup proj define-type-alias #:from "stlc+rec-iso.rkt")
(require (only-in "stlc+rec-iso.rkt" ~× ×?)) ; using current-type=? from here
(provide (rename-out [ext-stlc:and and] [ext-stlc:#%datum #%datum]))
(reuse member length reverse list-ref cons nil isnil head tail list #:from "stlc+cons.rkt")
(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list cons nil)))
(require (only-in "stlc+cons.rkt" ~List List? List))
(provide List)
(reuse ref deref := Ref #:from "stlc+box.rkt")
(require (rename-in (only-in "stlc+reco+var.rkt" tup proj ×)
           [tup rec] [proj get] [× ××]))
(provide rec get ××)
;; for pattern matching
(require (prefix-in stlc+cons: (only-in "stlc+cons.rkt" list)))
(require (prefix-in stlc+tup: (only-in "stlc+tup.rkt" tup)))

(module+ test
  (require (for-syntax rackunit)))

(provide → →/test match2 define-type)

;; ML-like language
;; - top level recursive functions
;; - user-definable algebraic datatypes
;; - pattern matching
;; - (local) type inference

;; creating possibly polymorphic types
;; ?∀ only wraps a type in a forall if there's at least one type variable
(define-syntax ?∀
  (lambda (stx)
    (syntax-case stx ()
      [(?∀ () body)
       #'body]
      [(?∀ (X ...) body)
       #'(∀ (X ...) body)])))

;; ?Λ only wraps an expression in a Λ if there's at least one type variable
(define-syntax ?Λ
  (lambda (stx)
    (syntax-case stx ()
      [(?Λ () body)
       #'body]
      [(?Λ (X ...) body)
       #'(Λ (X ...) body)])))

(begin-for-syntax 
  ;; matching possibly polymorphic types
  (define-syntax ~?∀
    (pattern-expander
     (lambda (stx)
       (syntax-case stx ()
         [(?∀ vars-pat body-pat)
          #'(~or (~∀ vars-pat body-pat)
                 (~and (~not (~∀ _ _))
                       (~parse vars-pat #'())
                       body-pat))]))))

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

  ;; 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 ...)
  ;;   tyXs = input and output types from fn type
  ;;          ie (typeof e_fn) = (-> . tyXs)
  ;; It infers the types of arguments from left-to-right,
  ;; and it expands and returns all of the arguments.
  ;; It returns list of 3 values if successful, else throws a type error
  ;;  - a list of all the arguments, expanded
  ;;  - a list of all the type variables
  ;;  - the constraints for substituting the types
  (define (solve Xs tyXs stx)
    (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)))
       (define initial-cs
         (if (and (syntax-e #'expected-ty) (stx-null? #'Vs))
             (add-constraints Xs '() (list (list #'expected-ty #'τ_outX)))
             #'()))
       (syntax-parse stx
         [(_ 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 ...)))])
                (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))
                                   (add-expected-ty a ty_in)
                                   a)))
                (values 
                 (cons #'a- as-)
                 (add-constraints Xs cs (list (list ty_in #'ty_a))
                                  (list (list (inst-type/cs/orig
                                               Xs cs ty_in
                                               (λ (id1 id2)
                                                 (equal? (syntax->datum id1)
                                                         (syntax->datum id2))))
                                              #'ty_a))))))

         (list (reverse as-) Xs cs)])]))

  (define (mk-app-poly-infer-error stx expected-tys given-tys e_fn)
    (format (string-append
             "Could not infer instantiation of polymorphic function ~s.\n"
             "  expected: ~a\n"
             "  given: ~a")
            (syntax->datum (get-orig e_fn))
            (string-join (stx-map type->str expected-tys) ", ")
            (string-join (stx-map type->str given-tys) ", ")))

  ;; covariant-Xs? : Type -> Bool
  ;; Takes a possibly polymorphic type, and returns true if all of the
  ;; type variables are in covariant positions within the type, false
  ;; otherwise.
  (define (covariant-Xs? ty)
    (syntax-parse ((current-type-eval) ty)
      [(~?∀ Xs ty)
       (for/and ([X (in-list (syntax->list #'Xs))])
         (covariant-X? X #'ty))]))

  ;; find-X-variance : Id Type [Variance] -> Variance
  ;; Returns the variance of X within the type ty
  (define (find-X-variance X ty [ctxt-variance covariant])
    (match (find-variances (list X) ty ctxt-variance)
      [(list variance) variance]))

  ;; covariant-X? : Id Type -> Bool
  ;; Returns true if every place X appears in ty is a covariant position, false otherwise.
  (define (covariant-X? X ty)
    (variance-covariant? (find-X-variance X ty covariant)))

  ;; contravariant-X? : Id Type -> Bool
  ;; Returns true if every place X appears in ty is a contravariant position, false otherwise.
  (define (contravariant-X? X ty)
    (variance-contravariant? (find-X-variance X ty covariant)))

  ;; find-variances : (Listof Id) Type [Variance] -> (Listof Variance)
  ;; Returns the variances of each of the Xs within the type ty,
  ;; where it's already within a context represented by ctxt-variance.
  (define (find-variances Xs ty [ctxt-variance covariant])
    (syntax-parse ty
      [A:id
       (for/list ([X (in-list Xs)])
         (cond [(free-identifier=? X #'A) ctxt-variance]
               [else irrelevant]))]
      [(~Any tycons)
       (make-list (length Xs) irrelevant)]
      [(~?∀ () (~Any tycons τ ...))
       #:when (get-arg-variances #'tycons)
       #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons))
       (define τ-ctxt-variances
         (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 #'[τ ...]))]
                  [τ-ctxt-variance (in-list τ-ctxt-variances)])
         (map variance-join
              acc
              (find-variances Xs τ τ-ctxt-variance)))]
      [ty
       #:when (not (for/or ([X (in-list Xs)])
                     (stx-contains-id? #'ty X)))
       (make-list (length Xs) irrelevant)]
      [_ (make-list (length Xs) invariant)]))

  ;; find-variances/exprs : (Listof Id) Type [Variance-Expr] -> (Listof Variance-Expr)
  ;; Like find-variances, but works with Variance-Exprs instead of
  ;; concrete variance values.
  (define (find-variances/exprs Xs ty [ctxt-variance covariant])
    (syntax-parse ty
      [A:id
       (for/list ([X (in-list Xs)])
         (cond [(free-identifier=? X #'A) ctxt-variance]
               [else irrelevant]))]
      [(~Any tycons)
       (make-list (length Xs) irrelevant)]
      [(~?∀ () (~Any tycons τ ...))
       #:when (get-arg-variances #'tycons)
       #:when (stx-length=? #'[τ ...] (get-arg-variances #'tycons))
       (define τ-ctxt-variances
         (for/list ([arg-variance (in-list (get-arg-variances #'tycons))])
           (variance-compose/expr ctxt-variance arg-variance)))
       (for/fold ([acc (make-list (length Xs) irrelevant)])
                 ([τ (in-list (syntax->list #'[τ ...]))]
                  [τ-ctxt-variance (in-list τ-ctxt-variances)])
         (map variance-join/expr
              acc
              (find-variances/exprs Xs τ τ-ctxt-variance)))]
      [ty
       #:when (not (for/or ([X (in-list Xs)])
                     (stx-contains-id? #'ty X)))
       (make-list (length Xs) irrelevant)]
      [_ (make-list (length Xs) invariant)]))

  ;; current-variance-constraints : (U False (Mutable-Setof Variance-Constraint))
  ;; If this is false, that means that infer-variances should return concrete Variance values.
  ;; If it's a mutable set, that means that infer-variances should mutate it and return false,
  ;; and type constructors should return the list of variance vars.
  (define current-variance-constraints (make-parameter #false))

  ;; infer-variances :
  ;; ((-> Stx) -> Stx) (Listof Variance-Var) (Listof Id) (Listof Type-Stx)
  ;; -> (U False (Listof Variance))
  (define (infer-variances with-variance-vars-okay variance-vars Xs τs)
    (cond
      [(current-variance-constraints)
       (define variance-constraints (current-variance-constraints))
       (define variance-exprs
         (for/fold ([exprs (make-list (length variance-vars) irrelevant)])
                   ([τ (in-list τs)])
           (define/syntax-parse (~?∀ Xs* τ*)
             ;; This can mutate variance-constraints!
             ;; This avoids causing an infinite loop by having the type
             ;; constructors provide with-variance-vars-okay so that within
             ;; this call they declare variance-vars for their variances.
             (with-variance-vars-okay
              (λ () ((current-type-eval) #`(∀ #,Xs #,τ)))))
           (map variance-join/expr
                exprs
                (find-variances/exprs (syntax->list #'Xs*) #'τ* covariant))))
       (for ([var (in-list variance-vars)]
             [expr (in-list variance-exprs)])
         (set-add! variance-constraints (variance= var expr)))
       #f]
      [else
       (define variance-constraints (mutable-set))
       ;; This will mutate variance-constraints!
       (parameterize ([current-variance-constraints variance-constraints])
         (infer-variances with-variance-vars-okay variance-vars Xs τs))
       (define mapping
         (solve-variance-constraints variance-vars
                                     (set->list variance-constraints)
                                     (variance-mapping)))
       (for/list ([var (in-list variance-vars)])
         (variance-mapping-ref mapping var))]))

  ;; make-arg-variances-proc :
  ;; (Listof Variance-Var) (Listof Id) (Listof Type-Stx) -> (Stx -> (U (Listof Variance)
  ;;                                                                   (Listof Variance-Var)))
  (define (make-arg-variances-proc arg-variance-vars Xs τs)
    ;; variance-vars-okay? : (Parameterof Boolean)
    ;; A parameter that determines whether or not it's okay for
    ;; this type constructor to return a list of Variance-Vars
    ;; for the variances.
    (define variance-vars-okay? (make-parameter #false))
    ;; with-variance-vars-okay : (-> A) -> A
    (define (with-variance-vars-okay f)
      (parameterize ([variance-vars-okay? #true])
        (f)))
    ;; arg-variances : (Boxof (U False (List Variance ...)))
    ;; If false, means that the arg variances have not been
    ;; computed yet. Otherwise, stores the complete computed
    ;; variances for the arguments to this type constructor.
    (define arg-variances (box #f))
    ;; arg-variances-proc : Stx -> (U (Listof Variance) (Listof Variance-Var))
    (define (arg-variance-proc stx)
      (or (unbox arg-variances)
          (cond
            [(variance-vars-okay?)
             arg-variance-vars]
            [else
             (define inferred-variances
               (infer-variances
                with-variance-vars-okay
                arg-variance-vars
                Xs
                τs))
             (cond [inferred-variances
                    (set-box! arg-variances inferred-variances)
                    inferred-variances]
                   [else
                    arg-variance-vars])])))
    arg-variance-proc)

  ;; compute unbound tyvars in one unexpanded type ty
  (define (compute-tyvar1 ty)
    (syntax-parse ty
      [X:id #'(X)]
      [() #'()]
      [(C t ...) (stx-appendmap compute-tyvar1 #'(t ...))]))
  ;; computes unbound ids in (unexpanded) tys, to be used as tyvars
  (define (compute-tyvars tys)
    (define Xs (stx-appendmap compute-tyvar1 tys))
    (filter 
     (lambda (X) 
       (with-handlers
        ([exn:fail:syntax:unbound? (lambda (e) #t)]
         [exn:fail:type:infer? (lambda (e) #t)])
        (let ([X+ ((current-type-eval) X)])
          (not (or (tyvar? X+) (type? X+))))))
     (stx-remove-dups Xs))))

;; define --------------------------------------------------
;; for function defs, define infers type variables
;; - since the order of the inferred type variables depends on expansion order,
;;   which is not known to programmers, to make the result slightly more
;;   intuitive, we arbitrarily sort the inferred tyvars lexicographically
(define-typed-syntax define
  [(define x:id e) ≫
   [⊢ [[e ≫ e-] ⇒ : τ]]
   [#:with y (generate-temporary)]
   --------
   [_ ≻ (begin-
          (define-syntax x (make-rename-transformer (⊢ y : τ)))
          (define- y e-))]]
  ; explicit "forall"
  [(define Ys (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) 
     e_body ... e) ≫
   [#:when (brace? #'Ys)]
   ;; TODO; remove this code duplication
   [#:with g (add-orig (generate-temporary #'f) #'f)]
   [#:with e_ann #'(add-expected e τ_out)]
   [#:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out))]
   ;; TODO: check that specified return type is correct
   ;; - currently cannot do it here; to do the check here, need all types of
   ;;  top-lvl fns, since they can call each other
   [#:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) 
           ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...)))]
   --------
   [_ ≻ (begin-
          (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected)))
          (define- g
            (Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]]
  ;; alternate type sig syntax, after parameter names
  [(define (f:id x:id ...) (~datum :) ty ... (~or (~datum ->) (~datum →)) ty_out . b) ≫
   --------
   [_ ≻ (define (f [x : ty] ... -> ty_out) . b)]]
  [(define (f:id [x:id (~datum :) τ] ... (~or (~datum ->) (~datum →)) τ_out) 
     e_body ... e) ≫
   [#:with Ys (compute-tyvars #'(τ ... τ_out))]
   [#:with g (add-orig (generate-temporary #'f) #'f)]
   [#:with e_ann (syntax/loc #'e (ann e : τ_out))] ; must be macro bc t_out may have unbound tvs
   [#:with (τ+orig ...) (stx-map (λ (t) (add-orig t t)) #'(τ ... τ_out))]
   ;; TODO: check that specified return type is correct
   ;; - currently cannot do it here; to do the check here, need all types of
   ;;  top-lvl fns, since they can call each other
   [#:with (~and ty_fn_expected (~?∀ _ (~ext-stlc:→ _ ... out_expected))) 
           (set-stx-prop/preserved 
            ((current-type-eval) #'(?∀ Ys (ext-stlc:→ τ+orig ...)))
            'orig
            (list #'(→ τ+orig ...)))]
   --------
   [_ ≻ (begin-
          (define-syntax f (make-rename-transformer (⊢ g : ty_fn_expected)))
          (define- g
            (?Λ Ys (ext-stlc:λ ([x : τ] ...) (ext-stlc:begin e_body ... e_ann)))))]])

;; define-type -----------------------------------------------
;; TODO: should validate τ as part of define-type definition (before it's used)
;; - not completely possible, since some constructors may not be defined yet,
;;   ie, mutually recursive datatypes
;; for now, validate types but punt if encountering unbound ids
(define-syntax (define-type stx)
  (syntax-parse stx
    [(define-type Name:id . rst)
     #:with NewName (generate-temporary #'Name)
     #:with Name2 (add-orig #'(NewName) #'Name)
     #`(begin-
         (define-type Name2 . #,(subst #'Name2 #'Name #'rst))
         (stlc+rec-iso:define-type-alias Name Name2))]
    [(define-type (Name:id X:id ...)
       ;; constructors must have the form (Cons τ ...)
       ;; but the first ~or clause accepts 0-arg constructors as ids;
       ;; the ~and is a workaround to bind the duplicate Cons ids (see Ryan's email)
       (~and (~or (~and IdCons:id 
                        (~parse (Cons [fld (~datum :) τ] ...) #'(IdCons)))
                  (Cons [fld (~datum :) τ] ...)
                  (~and (Cons τ ...)
                        (~parse (fld ...) (generate-temporaries #'(τ ...)))))) ...)
     ;; validate tys
     #:with (ty_flat ...) (stx-flatten #'((τ ...) ...))
     #:with (_ _ (_ _ (_ _ (_ _ ty+ ...))))
            (with-handlers 
              ([exn:fail:syntax:unbound?
                (λ (e) 
                  (define X (stx-car (exn:fail:syntax-exprs e)))
                  #`(lambda () (let-syntax () (let-syntax () (#%app void unbound)))))])
              (expand/df 
                #`(lambda (X ...)
                    (let-syntax
                      ([Name 
                        (syntax-parser 
                         [(_ X ...) (mk-type #'void)]
                         [stx 
                          (type-error 
                           #:src #'stx
                           #:msg 
                           (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))] ...)
                      (void ty_flat ...)))))
     #:when (or (equal? '(unbound) (syntax->datum #'(ty+ ...)))
                (stx-map 
                  (lambda (t+ t) (unless (type? t+)
                              (type-error #:src t
                                          #:msg "~a is not a valid type" t)))
                  #'(ty+ ...) #'(ty_flat ...)))
     #:with NameExpander (format-id #'Name "~~~a" #'Name)
     #:with NameExtraInfo (format-id #'Name "~a-extra-info" #'Name)
     #:with (StructName ...) (generate-temporaries #'(Cons ...))
     #:with ((e_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...))
     #:with ((e_arg- ...) ...) (stx-map generate-temporaries #'((τ ...) ...))
     #:with ((τ_arg ...) ...) (stx-map generate-temporaries #'((τ ...) ...))
     #:with ((exposed-acc ...) ...)
            (stx-map 
              (λ (C fs) (stx-map (λ (f) (format-id C "~a-~a" C f)) fs))
              #'(Cons ...) #'((fld ...) ...))
     #:with ((acc ...) ...) (stx-map (λ (S fs) (stx-map (λ (f) (format-id S "~a-~a" S f)) fs))
                                     #'(StructName ...) #'((fld ...) ...))
     #:with (Cons? ...) (stx-map mk-? #'(StructName ...))
     #:with (exposed-Cons? ...) (stx-map mk-? #'(Cons ...))
     #`(begin-
         (define-syntax (NameExtraInfo stx)
           (syntax-parse stx
             [(_ X ...) #'(('Cons 'StructName Cons? [acc τ] ...) ...)]))
         (begin-for-syntax
           ;; arg-variance-vars : (List Variance-Var ...)
           (define arg-variance-vars
             (list (variance-var (syntax-e (generate-temporary 'X))) ...)))
         (define-type-constructor Name
           #:arity = #,(stx-length #'(X ...))
           #:arg-variances (make-arg-variances-proc arg-variance-vars
                                                    (list #'X ...)
                                                    (list #'τ ... ...))
           #:extra-info 'NameExtraInfo
           #:no-provide)
         (struct- StructName (fld ...) #:reflection-name 'Cons #:transparent) ...
         (define-syntax (exposed-acc stx) ; accessor for records
           (syntax-parse stx
            [_:id
             (⊢ acc (?∀ (X ...) (ext-stlc:→ (Name X ...) τ)))]
            [(o . rst) ; handle if used in fn position
             #:with app (datum->syntax #'o '#%app)
             #`(app 
                #,(assign-type #'acc #'(?∀ (X ...) (ext-stlc:→ (Name X ...) τ))) 
                . rst)])) ... ...
         (define-syntax (exposed-Cons? stx) ; predicates for each variant
           (syntax-parse stx
            [_:id (⊢ Cons? (?∀ (X ...) (ext-stlc:→ (Name X ...) Bool)))]
            [(o . rst) ; handle if used in fn position
             #:with app (datum->syntax #'o '#%app)
             #`(app 
                #,(assign-type #'Cons? #'(?∀ (X ...) (ext-stlc:→ (Name X ...) Bool))) 
                . rst)])) ...
         (define-syntax (Cons stx)
           (syntax-parse/typed-syntax stx
             ; no args and not polymorphic
             [C:id ≫
              [#:when (and (stx-null? #'(X ...)) (stx-null? #'(τ ...)))]
              --------
              [_ ≻ (C)]]
             ; no args but polymorphic, check expected type
             [C:id ⇐ : (NameExpander τ-expected-arg (... ...)) ≫
              [#:when (stx-null? #'(τ ...))]
              --------
              [⊢ [[_ ≫ (StructName)] ⇐ : _]]]
             ; id with multiple expected args, HO fn
             [C:id ≫
              [#:when (not (stx-null? #'(τ ...)))]
              --------
              [⊢ [[_ ≫ StructName] ⇒ : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...)))]]]
             [(C τs e_arg ...) ≫
              [#:when (brace? #'τs)] ; commit to this clause
              [#:with [X* (... ...)] #'[X ...]]
              [#:with [e_arg* (... ...)] #'[e_arg ...]]
              [#:with {~! τ_X:type (... ...)} #'τs]
              [#:with (τ_in:type (... ...)) ; instantiated types
               (inst-types/cs #'(X ...) #'([X* τ_X.norm] (... ...)) #'(τ ...))]
              [⊢ [[e_arg* ≫ e_arg*-] ⇐ : τ_in.norm] (... ...)]
              [#:with [e_arg- ...] #'[e_arg*- (... ...)]]
              --------
              [⊢ [[_ ≫ (StructName e_arg- ...)] ⇒ : (Name τ_X.norm (... ...))]]]
             [(C . args) ≫ ; no type annotations, must infer instantiation
              [#:with StructName/ty 
               (set-stx-prop/preserved
                (⊢ StructName : (?∀ (X ...) (ext-stlc:→ τ ... (Name X ...))))
                'orig
                (list #'C))]
              --------
              [_ ≻ (mlish:#%app StructName/ty . args)]]))
         ...)]))

;; match --------------------------------------------------
(begin-for-syntax
  (define (get-ctx pat ty)
    (unify-pat+ty (list pat ty)))
  (define (unify-pat+ty pat+ty)
    (syntax-parse pat+ty
     [(pat ty) #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens)
      (syntax-parse #'pat
        [{(~datum _)} #'()]
        [{(~literal stlc+cons:nil)}  #'()]
        [{A:id} ; disambiguate 0-arity constructors (that don't need parens)
         #:when (get-extra-info #'ty)
         #'()]
        ;; comma tup syntax always has parens
        [{(~and ps (p1 (unq p) ...))}
         #:when (not (stx-null? #'(p ...)))
         #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...)))
         (unify-pat+ty #'(ps ty))]
        [{p ...} 
         (unify-pat+ty #'((p ...) ty))])] ; pair
      [((~datum _) ty) #'()]
      [((~or (~literal stlc+cons:nil)) ty) #'()]
      [(A:id ty) ; disambiguate 0-arity constructors (that don't need parens)
       #:with (_ (_ (_ C) . _) ...) (get-extra-info #'ty)
       #:when (member (syntax->datum #'A) (syntax->datum #'(C ...)))
       #'()]
      [(x:id ty)  #'((x ty))]
      [((p1 (unq p) ...) ty) ; comma tup stx
       #:when (not (stx-null? #'(p ...)))
       #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...)))
       #:with (~× t ...) #'ty
       #:with (pp ...) #'(p1 p ...)
       (unifys #'([pp t] ...))]
      [(((~literal stlc+tup:tup) p ...) ty) ; tup
       #:with (~× t ...) #'ty
       (unifys #'([p t] ...))]
      [(((~literal stlc+cons:list) p ...) ty) ; known length list
       #:with (~List t) #'ty
       (unifys #'([p t] ...))]
     [(((~seq p (~datum ::)) ... rst) ty) ; nicer cons stx
      #:with (~List t) #'ty
       (unifys #'([p t] ... [rst ty]))]
      [(((~literal stlc+cons:cons) p ps) ty) ; arb length list
       #:with (~List t) #'ty
       (unifys #'([p t] [ps ty]))]
      [((Name p ...) ty)
       #:with (_ (_ Cons) _ _ [_ _ τ] ...)
              (stx-findf
                (syntax-parser
                 [(_ 'C . rst) 
                  (equal? (syntax->datum #'Name) (syntax->datum #'C))])
                (stx-cdr (get-extra-info #'ty)))
       (unifys #'([p τ] ...))]
      [p+t #:fail-when #t (format "could not unify ~a" (syntax->datum #'p+t))
       #'()]))
  (define (unifys p+tys) (stx-appendmap unify-pat+ty p+tys))
  
  (define (compile-pat p ty)
    (syntax-parse p
     [pat #:when (brace? #'pat) ; handle root pattern specially (to avoid some parens)
      (syntax-parse #'pat
        [{(~datum _)} #'_]
        [{(~literal stlc+cons:nil)}  (syntax/loc p (list))]
        [{A:id} ; disambiguate 0-arity constructors (that don't need parens)
         #:when (get-extra-info ty)
         (compile-pat #'(A) ty)]
        ;; comma tup stx always has parens
        [{(~and ps (p1 (unq p) ...))}
         #:when (not (stx-null? #'(p ...)))
         #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...)))
         (compile-pat #'ps ty)]
        [{pat ...} (compile-pat (syntax/loc p (pat ...)) ty)])]
     [(~datum _) #'_]
     [(~literal stlc+cons:nil) ; nil
      #'(list)]
     [A:id ; disambiguate 0-arity constructors (that don't need parens)
      #:with (_ (_ (_ C) . _) ...) (get-extra-info ty)
      #:when (member (syntax->datum #'A) (syntax->datum #'(C ...)))
      (compile-pat #'(A) ty)]
     [x:id p]
     [(p1 (unq p) ...) ; comma tup stx
      #:when (not (stx-null? #'(p ...)))
      #:when (andmap (lambda (u) (equal? u 'unquote)) (syntax->datum #'(unq ...)))
      #:with (~× t ...) ty
      #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'(p1 p ...) #'(t ...))
      #'(list p- ...)]
     [((~literal stlc+tup:tup) . pats)
      #:with (~× . tys) ty
      #:with (p- ...) (stx-map (lambda (p t) (compile-pat p t)) #'pats #'tys)
      (syntax/loc p (list p- ...))]
     [((~literal stlc+cons:list) . ps)
      #:with (~List t) ty
      #:with (p- ...) (stx-map (lambda (p) (compile-pat p #'t)) #'ps)
      (syntax/loc p (list p- ...))]
     [((~seq pat (~datum ::)) ... last) ; nicer cons stx
      #:with (~List t) ty
      #:with (p- ...) (stx-map (lambda (pp) (compile-pat pp #'t)) #'(pat ...))
      #:with last- (compile-pat #'last ty)
      (syntax/loc p (list-rest p- ... last-))]
     [((~literal stlc+cons:cons) p ps)
      #:with (~List t) ty
      #:with p- (compile-pat #'p #'t)
      #:with ps- (compile-pat #'ps ty)
      #'(cons p- ps-)]
     [(Name . pats)
      #:with (_ (_ Cons) (_ StructName) _ [_ _ τ] ...)
             (stx-findf
               (syntax-parser
                [(_ 'C . rst) 
                 (equal? (syntax->datum #'Name) (syntax->datum #'C))])
               (stx-cdr (get-extra-info ty)))
      #:with (p- ...) (stx-map compile-pat #'pats #'(τ ...))
      (syntax/loc p (StructName p- ...))]))

  ;; pats = compiled pats = racket pats
  (define (check-exhaust pats ty)
    (define (else-pat? p)
      (syntax-parse p [(~literal _) #t] [_ #f]))
    (define (nil-pat? p)
      (syntax-parse p
        [((~literal list)) #t]
        [_ #f]))
    (define (non-nil-pat? p)
      (syntax-parse p
        [((~literal list-rest) . rst) #t]
        [((~literal cons) . rst) #t]
        [_ #f]))
    (define (tup-pat? p)
      (syntax-parse p
        [((~literal list) . _) #t] [_ #f]))
    (cond
     [(or (stx-ormap else-pat? pats) (stx-ormap identifier? pats)) #t]
     [(List? ty) ; lists
      (unless (stx-ormap nil-pat? pats)
        (error 'match2 (let ([last (car (stx-rev pats))])
                         (format "(~a:~a) missing nil clause for list expression"
                                 (syntax-line last) (syntax-column last)))))
      (unless (stx-ormap non-nil-pat? pats)
        (error 'match2 (let ([last (car (stx-rev pats))])
                         (format "(~a:~a) missing clause for non-empty, arbitrary length list"
                                 (syntax-line last) (syntax-column last)))))
      #t]
     [(×? ty) ; tuples
      (unless (stx-ormap tup-pat? pats)
        (error 'match2 (let ([last (car (stx-rev pats))])
                         (format "(~a:~a) missing pattern for tuple expression"
                                 (syntax-line last) (syntax-column last)))))
      (syntax-parse pats
        [((_ p ...) ...)
         (syntax-parse ty
           [(~× t ...)
            (apply stx-andmap 
                   (lambda (t . ps) (check-exhaust ps t)) 
                   #'(t ...) 
                   (syntax->list #'((p ...) ...)))])])]
     [else ; algebraic datatypes
      (syntax-parse (get-extra-info ty)
        [(_ (_ (_ C) (_ Cstruct) . rst) ...)
         (syntax-parse pats
           [((Cpat _ ...) ...)
            (define Cs (syntax->datum #'(C ...)))
            (define Cstructs (syntax->datum #'(Cstruct ...)))
            (define Cpats (syntax->datum #'(Cpat ...)))
            (unless (set=? Cstructs Cpats)
              (error 'match2
                (let ([last (car (stx-rev pats))])
                  (format "(~a:~a) clauses not exhaustive; missing: ~a"
                          (syntax-line last) (syntax-column last)
                          (string-join      
                            (for/list ([C Cs][Cstr Cstructs] #:unless (member Cstr Cpats))
                              (symbol->string C))
                            ", ")))))
            #t])]
        [_ #t])]))

  ;; TODO: do get-ctx and compile-pat in one pass
  (define (compile-pats pats ty)
    (stx-map (lambda (p) (list (get-ctx p ty) (compile-pat p ty))) pats))
  )

(define-typed-syntax match2 #:datum-literals (with ->)
  [(match2 e with . clauses) ≫
   [#:fail-unless (not (null? (syntax->list #'clauses))) "no clauses"]
   [⊢ [[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 ...})]))
                      #'((p ...) ...)) ]
   [#:with ([(~and ctx ([x ty] ...)) pat-] ...) (compile-pats #'(pat ...) #'τ_e)]
   [#:with ty-expected (get-expected-type stx)]
   [() ([x : ty ≫ x-] ...)
    ⊢ [[(add-expected e_body ty-expected) ≫ e_body-] ⇒ : ty_body]]
   ...
   [#:when (check-exhaust #'(pat- ...) #'τ_e)]
   --------
   [⊢ [[_ ≫ (match- e- [pat- (let- ([x- x] ...) e_body-)] ...)]
       ⇒ : (⊔ ty_body ...)]]])

(define-typed-syntax match #:datum-literals (with -> ::)
  ;; e is a tuple
  [(match e with . clauses) ≫
   [#: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 ([x ... -> e_body]) #'clauses]
   [#:with (~× ty ...) #'τ_e]
   [#:fail-unless (stx-length=? #'(ty ...) #'(x ...))
                  "match clause pattern not compatible with given tuple"]
   [() ([x : ty ≫ x-] ...)
    ⊢ [[(add-expected e_body t_expect) ≫ e_body-] ⇒ : ty_body]]
   [#:with (acc ...) (for/list ([(a i) (in-indexed (syntax->list #'(x ...)))])
                       #`(lambda (s) (list-ref s #,(datum->syntax #'here i))))]
   [#:with z (generate-temporary)]
   --------
   [⊢ [[_ ≫ (let- ([z e-])
              (let- ([x- (acc z)] ...) e_body-))]
       ⇒ : ty_body]]]
  ;; e is a list
  [(match e with . clauses) ≫
   [#: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 ([(~or (~and (~and xs [x ...]) (~parse rst (generate-temporary)))
                  (~and (~seq (~seq x ::) ... rst:id) (~parse xs #'())))
             -> e_body] ...+)
    #'clauses]
   [#:fail-unless (stx-ormap 
                   (lambda (xx) (and (brack? xx) (zero? (stx-length xx)))) 
                   #'(xs ...))
    "match: missing empty list case"]
   [#:fail-unless (not (and (stx-andmap brack? #'(xs ...))
                            (= 1 (stx-length #'(xs ...)))))
    "match: missing non-empty list case"]
   [#:with (~List ty) #'τ_e]
   [() ([x : ty ≫ x-] ... [rst : (List ty) ≫ rst-])
    ⊢ [[(add-expected e_body t_expect) ≫ e_body-] ⇒ : ty_body]]
   ...
   [#:with (len ...) (stx-map (lambda (p) #`#,(stx-length p)) #'((x ...) ...))]
   [#:with (lenop ...) (stx-map (lambda (p) (if (brack? p) #'=- #'>=-)) #'(xs ...))]
   [#:with (pred? ...) (stx-map
                        (lambda (l lo) #`(λ- (lst) (#,lo (length lst) #,l)))
                        #'(len ...) #'(lenop ...))]
   [#:with ((acc1 ...) ...) (stx-map 
                             (lambda (xs)
                               (for/list ([(x i) (in-indexed (syntax->list xs))])
                                 #`(lambda- (lst) (list-ref- lst #,(datum->syntax #'here i)))))
                             #'((x ...) ...))]
   [#:with (acc2 ...) (stx-map (lambda (l) #`(lambda- (lst) (list-tail- lst #,l))) #'(len ...))]
   --------
   [⊢ [[_ ≫ (let- ([z e-])
              (cond-
                [(pred? z)
                 (let- ([x- (acc1 z)] ... [rst- (acc2 z)]) e_body-)] ...))]
       ⇒ : (⊔ ty_body ...)]]]
  ;; e is a variant
  [(match e with . clauses) ≫
   [#: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 ([Clause:id x:id ... 
                       (~optional (~seq #:when e_guard) #:defaults ([e_guard #'(ext-stlc:#%datum . #t)]))
                       -> e_c_un] ...+) ; un = unannotated with expected ty
    #'clauses]
   ;; length #'clauses may be > length #'info, due to guards
   [#:with info-body (get-extra-info #'τ_e)]
   [#:with (_ (_ (_ ConsAll) . _) ...) #'info-body]
   [#:fail-unless (set=? (syntax->datum #'(Clause ...))
                         (syntax->datum #'(ConsAll ...)))
    (type-error #:src stx
                #:msg (string-append
                       "match: clauses not exhaustive; missing: "
                       (string-join      
                        (map symbol->string
                             (set-subtract 
                              (syntax->datum #'(ConsAll ...))
                              (syntax->datum #'(Clause ...))))
                        ", ")))]
   [#:with ((_ _ _ Cons? [_ acc τ] ...) ...)
    (map ; ok to compare symbols since clause names can't be rebound
     (lambda (Cl) 
       (stx-findf
        (syntax-parser
          [(_ 'C . rst) (equal? Cl (syntax->datum #'C))])
        (stx-cdr #'info-body))) ; drop leading #%app
     (syntax->datum #'(Clause ...)))]
   ;; this commented block experiments with expanding to unsafe ops
   ;; [#:with ((acc ...) ...) (stx-map 
   ;;                          (lambda (accs)
   ;;                           (for/list ([(a i) (in-indexed (syntax->list accs))])
   ;;                             #`(lambda (s) (unsafe-struct*-ref s #,(datum->syntax #'here i)))))
   ;;                          #'((acc-fn ...) ...))]
   [#:with (e_c ...+) (stx-map (lambda (ec) (add-expected-ty ec #'t_expect)) #'(e_c_un ...))]
   [() ([x : τ ≫ x-] ...)
    ⊢ [[e_guard ≫ e_guard-] ⇐ : Bool] [[e_c ≫ e_c-] ⇒ : τ_ec]]
   ...
   [#:with z (generate-temporary)] ; dont duplicate eval of test expr
   --------
   [⊢ [[_ ≫ (let- ([z e-])
              (cond-
                [(and- (Cons? z) 
                       (let- ([x- (acc z)] ...) e_guard-))
                 (let- ([x- (acc z)] ...) e_c-)] ...))]
       ⇒ : (⊔ τ_ec ...)]]])

; special arrow that computes free vars; for use with tests
; (because we can't write explicit forall
(define-syntax →/test 
  (syntax-parser
    [(→/test (~and Xs (X:id ...)) . rst)
     #:when (brace? #'Xs)
     #'(?∀ (X ...) (ext-stlc:→ . rst))]
    [(→/test . rst)
     #:with Xs (compute-tyvars #'rst)
     #'(?∀ Xs (ext-stlc:→ . rst))]))

; redefine these to use lifted →
(define-primop + : (→ Int Int Int))
(define-primop - : (→ Int Int Int))
(define-primop * : (→ Int Int Int))
(define-primop max : (→ Int Int Int))
(define-primop min : (→ Int Int Int))
(define-primop void : (→ Unit))
(define-primop = : (→ Int Int Bool))
(define-primop <= : (→ Int Int Bool))
(define-primop < : (→ Int Int Bool))
(define-primop > : (→ Int Int Bool))
(define-primop modulo : (→ Int Int Int))
(define-primop zero? : (→ Int Bool))
(define-primop sub1 : (→ Int Int))
(define-primop add1 : (→ Int Int))
(define-primop not : (→ Bool Bool))
(define-primop abs : (→ Int Int))
(define-primop even? : (→ Int Bool))
(define-primop odd? : (→ Int Bool))

; all λs have type (?∀ (X ...) (→ τ_in ... τ_out))
(define-typed-syntax λ #:datum-literals (:)
  [(λ (x:id ...) body) ⇐ : (~?∀ (X ...) (~ext-stlc:→ τ_in ... τ_out)) ≫
   [#: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 : #%type ≫ X-] ...) ([x : τ_in ≫ x-] ...)
    ⊢ [[body ≫ body-] ⇐ : τ_out]]
   --------
   [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇐ : _]]]
  [(λ ([x : τ_x] ...) body) ⇐ : (~?∀ (V ...) (~ext-stlc:→ τ_in ... τ_out)) ≫
   [#:with [X ...] (compute-tyvars #'(τ_x ...))]
   [([X : #%type ≫ X-] ...) ()
    ⊢ [[τ_x ≫ τ_x-] ⇐ : #%type] ...]
   [τ_in τ⊑ τ_x- #:for x] ...
   ;; TODO is there a way to have λs that refer to ids defined after them?
   [([V : #%type ≫ V-] ... [X- : #%type ≫ 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 : #%type ≫ X-] ...) ([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)))]
   --------
   [⊢ [[_ ≫ (λ- (x- ...) body-)] ⇒ : τ_fn]]])


;; #%app --------------------------------------------------
(define-typed-syntax mlish:#%app #:export-as #%app
  [(_ e_fn e_arg ...) ≫
   ;; 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)]
   ;; instantiate polymorphic function type
   [#:with [τ_in ... τ_out] (inst-types/cs #'Xs* #'cs #'tyX_args)]
   [#:with (unsolved-X ...) (find-free-Xs #'Xs* #'τ_out)]
   ;; arity check
   [#:fail-unless (stx-length=? #'[τ_in ...] #'[e_arg ...])
    (num-args-fail-msg #'e_fn #'[τ_in ...] #'[e_arg ...])]
   ;; compute argument types
   [#:with (τ_arg ...) (stx-map typeof #'(e_arg- ...))]
   ;; typecheck args
   [τ_arg τ⊑ τ_in #:for e_arg] ...
   [#:with τ_out* (if (stx-null? #'(unsolved-X ...))
                      #'τ_out
                      (syntax-parse #'τ_out
                        [(~?∀ (Y ...) τ_out)
                         #:fail-unless (→? #'τ_out)
                         (mk-app-poly-infer-error stx #'(τ_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)))
                         #'(∀ (unsolved-X ... Y ...) τ_out)]))]
   --------
   [⊢ [[_ ≫ (#%app- e_fn- e_arg- ...)] ⇒ : τ_out*]]])


;; cond and other conditionals
(define-typed-syntax cond
  [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t)))
               test)
          b ... body] ...+)
   ⇐ : τ_expected ≫
   [⊢ [[test ≫ test-] ⇐ : Bool] ...]
   [⊢ [[(begin b ... body) ≫ body-] ⇐ : τ_expected] ...]
   --------
   [⊢ [[_ ≫ (cond- [test- body-] ...)] ⇐ : _]]]
  [(cond [(~or (~and (~datum else) (~parse test #'(ext-stlc:#%datum . #t)))
               test)
          b ... body] ...+) ≫
   [⊢ [[test ≫ test-] ⇐ : Bool] ...]
   [⊢ [[(begin b ... body) ≫ body-] ⇒ : τ_body] ...]
   --------
   [⊢ [[_ ≫ (cond- [test- body-] ...)] ⇒ : (⊔ τ_body ...)]]])
(define-typed-syntax when
  [(when test body ...) ≫
   [⊢ [[test ≫ test-] ⇒ : _]]
   [⊢ [[body ≫ body-] ⇒ : _] ...]
   --------
   [⊢ [[_ ≫ (when- test- body- ... (void-))] ⇒ : Unit]]])
(define-typed-syntax unless
  [(unless test body ...) ≫
   [⊢ [[test ≫ test-] ⇒ : _]]
   [⊢ [[body ≫ body-] ⇒ : _] ...]
   --------
   [⊢ [[_ ≫ (unless- test- body- ... (void-))] ⇒ : Unit]]])

;; sync channels and threads
(define-type-constructor Channel)

(define-typed-syntax make-channel
  [(make-channel (~and tys {ty})) ≫
   [#:when (brace? #'tys)]
   --------
   [⊢ [[_ ≫ (make-channel-)] ⇒ : (Channel ty)]]])
(define-typed-syntax channel-get
  [(channel-get c) ⇐ : ty ≫
   [⊢ [[c ≫ c-] ⇐ : (Channel ty)]]
   --------
   [⊢ [[_ ≫ (channel-get- c-)] ⇐ : _]]]
  [(channel-get c) ≫
   [⊢ [[c ≫ c-] ⇒ : (~Channel ty)]]
   --------
   [⊢ [[_ ≫ (channel-get- c-)] ⇒ : ty]]])
(define-typed-syntax channel-put
  [(channel-put c v) ≫
   [⊢ [[c ≫ c-] ⇒ : (~Channel ty)]]
   [⊢ [[v ≫ v-] ⇐ : ty]]
   --------
   [⊢ [[_ ≫ (channel-put- c- v-)] ⇒ : Unit]]])

(define-base-type Thread)

;; threads
(define-typed-syntax thread
  [(thread th) ≫
   [⊢ [[th ≫ th-] ⇒ : (~?∀ () (~ext-stlc:→ τ_out))]]
   --------
   [⊢ [[_ ≫ (thread- th-)] ⇒ : Thread]]])

(define-primop random : (→ Int Int))
(define-primop integer->char : (→ Int Char))
(define-primop string->list : (→ String (List Char)))
(define-primop string->number : (→ String Int))
;(define-primop number->string : (→ Int String))
(define-typed-syntax number->string
  [number->string:id ≫
   --------
   [⊢ [[_ ≫ number->string-] ⇒ : (→ Int String)]]]
  [(number->string n) ≫
   --------
   [_ ≻ (number->string n (ext-stlc:#%datum . 10))]]
  [(number->string n rad) ≫
   [⊢ [[n ≫ n-] ⇐ : Int]]
   [⊢ [[rad ≫ rad-] ⇐ : Int]]
   --------
   [⊢ [[_ ≫ (number->string- n rad)] ⇒ : String]]])
(define-primop string : (→ Char String))
(define-primop sleep : (→ Int Unit))
(define-primop string=? : (→ String String Bool))
(define-primop string<=? : (→ String String Bool))

(define-typed-syntax string-append
  [(string-append str ...) ≫
   [⊢ [[str ≫ str-] ⇐ : String] ...]
   --------
   [⊢ [[_ ≫ (string-append- str- ...)] ⇒ : String]]])

;; vectors
(define-type-constructor Vector)

(define-typed-syntax vector
  [(vector (~and tys {ty})) ≫
   [#:when (brace? #'tys)]
   --------
   [⊢ [[_ ≫ (vector-)] ⇒ : (Vector ty)]]]
  [(vector v ...) ⇐ : (Vector ty) ≫
   [⊢ [[v ≫ v-] ⇐ : ty] ...]
   --------
   [⊢ [[_ ≫ (vector- v- ...)] ⇐ : _]]]
  [(vector v ...) ≫
   [⊢ [[v ≫ v-] ⇒ : ty] ...]
   [#:when (same-types? #'(ty ...))]
   [#:with one-ty (stx-car #'(ty ...))]
   --------
   [⊢ [[_ ≫ (vector- v- ...)] ⇒ : (Vector one-ty)]]])
(define-typed-syntax make-vector
  [(make-vector n) ≫
   --------
   [_ ≻ (make-vector n (ext-stlc:#%datum . 0))]]
  [(make-vector n e) ≫
   [⊢ [[n ≫ n-] ⇐ : Int]]
   [⊢ [[e ≫ e-] ⇒ : ty]]
   --------
   [⊢ [[_ ≫ (make-vector- n- e-)] ⇒ : (Vector ty)]]])
(define-typed-syntax vector-length
  [(vector-length e) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Vector _)]]
   --------
   [⊢ [[_ ≫ (vector-length- e-)] ⇒ : Int]]])
(define-typed-syntax vector-ref
  [(vector-ref e n) ⇐ : ty ≫
   [⊢ [[e ≫ e-] ⇐ : (Vector ty)]]
   [⊢ [[n ≫ n-] ⇐ : Int]]
   --------
   [⊢ [[_ ≫ (vector-ref- e- n-)] ⇐ : _]]]
  [(vector-ref e n) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]]
   [⊢ [[n ≫ n-] ⇐ : Int]]
   --------
   [⊢ [[_ ≫ (vector-ref- e- n-)] ⇒ : ty]]])
(define-typed-syntax vector-set!
  [(vector-set! e n v) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]]
   [⊢ [[n ≫ n-] ⇐ : Int]]
   [⊢ [[v ≫ v-] ⇐ : ty]]
   --------
   [⊢ [[_ ≫ (vector-set!- e- n- v-)] ⇒ : Unit]]])
(define-typed-syntax vector-copy!
  [(vector-copy! dest start src) ≫
   [⊢ [[dest ≫ dest-] ⇒ : (~Vector ty)]]
   [⊢ [[start ≫ start-] ⇐ : Int]]
   [⊢ [[src ≫ src-] ⇐ : (Vector ty)]]
   --------
   [⊢ [[_ ≫ (vector-copy!- dest- start- src-)] ⇒ : Unit]]])


;; sequences and for loops

(define-type-constructor Sequence)

(define-typed-syntax in-range
  [(in-range end) ≫
   --------
   [_ ≻ (in-range (ext-stlc:#%datum . 0) end (ext-stlc:#%datum . 1))]]
  [(in-range start end) ≫
   --------
   [_ ≻ (in-range start end (ext-stlc:#%datum . 1))]]
  [(in-range start end step) ≫
   [⊢ [[start ≫ start-] ⇐ : Int]]
   [⊢ [[end ≫ end-] ⇐ : Int]]
   [⊢ [[step ≫ step-] ⇐ : Int]]
   --------
   [⊢ [[_ ≫ (in-range- start- end- step-)] ⇒ : (Sequence Int)]]])

(define-typed-syntax in-naturals
 [(in-naturals) ≫
  --------
  [_ ≻ (in-naturals (ext-stlc:#%datum . 0))]]
 [(in-naturals start) ≫
  [⊢ [[start ≫ start-] ⇐ : Int]]
  --------
  [⊢ [[_ ≫ (in-naturals- start-)] ⇒ : (Sequence Int)]]])


(define-typed-syntax in-vector
  [(in-vector e) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Vector ty)]]
   --------
   [⊢ [[_ ≫ (in-vector- e-)] ⇒ : (Sequence ty)]]])

(define-typed-syntax in-list
  [(in-list e) ≫
   [⊢ [[e ≫ e-] ⇒ : (~List ty)]]
   --------
   [⊢ [[_ ≫ (in-list- e-)] ⇒ : (Sequence ty)]]])

(define-typed-syntax in-lines
  [(in-lines e) ≫
   [⊢ [[e ≫ e-] ⇐ : String]]
   --------
   [⊢ [[_ ≫ (in-lines- (open-input-string- e-))] ⇒ : (Sequence String)]]])

(define-typed-syntax for
  [(for ([x:id e]...) b ... body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...)
    ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇒ : _]]
   --------
   [⊢ [[_ ≫ (for- ([x- e-] ...) b- ... body-)] ⇒ : Unit]]])
(define-typed-syntax for*
  [(for* ([x:id e]...) b ... body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...)
    ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇒ : _]]
   --------
   [⊢ [[_ ≫ (for*- ([x- e-] ...) b- ... body-)] ⇒ : Unit]]])

(define-typed-syntax for/list
  [(for/list ([x:id e]...) body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]]
   --------
   [⊢ [[_ ≫ (for/list- ([x- e-] ...) body-)] ⇒ : (List ty_body)]]])
(define-typed-syntax for/vector
  [(for/vector ([x:id e]...) body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]]
   --------
   [⊢ [[_ ≫ (for/vector- ([x- e-] ...) body-)] ⇒ : (Vector ty_body)]]])
(define-typed-syntax for*/vector
  [(for*/vector ([x:id e]...) body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]]
   --------
   [⊢ [[_ ≫ (for*/vector- ([x- e-] ...) body-)] ⇒ : (Vector ty_body)]]])
(define-typed-syntax for*/list
  [(for*/list ([x:id e]...) body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : ty_body]]
   --------
   [⊢ [[_ ≫ (for*/list- ([x- e-] ...) body-)] ⇒ : (List ty_body)]]])
(define-typed-syntax for/fold
  [(for/fold ([acc init]) ([x:id e] ...) body) ⇐ : τ_expected ≫
   [⊢ [[init ≫ init-] ⇐ : τ_expected]]
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([acc : τ_expected ≫ acc-] [x : ty ≫ x-] ...)
    ⊢ [[body ≫ body-] ⇐ : τ_expected]]
   --------
   [⊢ [[_ ≫ (for/fold- ([acc- init-]) ([x- e-] ...) body-)] ⇐ : _]]]
  [(for/fold ([acc init]) ([x:id e] ...) body) ≫
   [⊢ [[init ≫ init-] ⇒ : τ_init]]
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([acc : τ_init ≫ acc-] [x : ty ≫ x-] ...)
    ⊢ [[body ≫ body-] ⇐ : τ_init]]
   --------
   [⊢ [[_ ≫ (for/fold- ([acc- init-]) ([x- e-] ...) body-)] ⇒ : τ_init]]])

(define-typed-syntax for/hash
  [(for/hash ([x:id e]...) body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...) ⊢ [[body ≫ body-] ⇒ : (~× ty_k ty_v)]]
   --------
   [⊢ [[_ ≫ (for/hash- ([x- e-] ...)
              (let- ([t body-])
                (values- (car- t) (cadr- t))))]
       ⇒ : (Hash ty_k ty_v)]]])

(define-typed-syntax for/sum
  [(for/sum ([x:id e]... 
             (~optional (~seq #:when guard) #:defaults ([guard #'#t])))
     body) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Sequence ty)] ...]
   [() ([x : ty ≫ x-] ...)
    ⊢ [[guard ≫ guard-] ⇒ : _] [[body ≫ body-] ⇐ : Int]]
   --------
   [⊢ [[_ ≫ (for/sum- ([x- e-] ... #:when guard-) body-)] ⇒ : Int]]])

; printing and displaying
(define-typed-syntax printf
  [(printf str e ...) ≫
   [⊢ [[str ≫ s-] ⇐ : String]]
   [⊢ [[e ≫ e-] ⇒ : ty] ...]
   --------
   [⊢ [[_ ≫ (printf- s- e- ...)] ⇒ : Unit]]])
(define-typed-syntax format
  [(format str e ...) ≫
   [⊢ [[str ≫ s-] ⇐ : String]]
   [⊢ [[e ≫ e-] ⇒ : ty] ...]
   --------
   [⊢ [[_ ≫ (format- s- e- ...)] ⇒ : String]]])
(define-typed-syntax display
  [(display e) ≫
   [⊢ [[e ≫ e-] ⇒ : _]]
   --------
   [⊢ [[_ ≫ (display- e-)] ⇒ : Unit]]])
(define-typed-syntax displayln
  [(displayln e) ≫
   [⊢ [[e ≫ e-] ⇒ : _]]
   --------
   [⊢ [[_ ≫ (displayln- e-)] ⇒ : Unit]]])
(define-primop newline : (→ Unit))

(define-typed-syntax list->vector
  [(list->vector e) ⇐ : (~Vector ty) ≫
   [⊢ [[e ≫ e-] ⇐ : (List ty)]]
   --------
   [⊢ [[_ ≫ (list->vector- e-)] ⇐ : _]]]
  [(list->vector e) ≫
   [⊢ [[e ≫ e-] ⇒ : (~List ty)]]
   --------
   [⊢ [[_ ≫ (list->vector- e-)] ⇒ : (Vector ty)]]])

(define-typed-syntax let
  [(let name:id (~datum :) ty:type ~! ([x:id e] ...) b ... body) ≫
   [⊢ [[e ≫ e-] ⇒ : ty_e] ...]
   [() ([name : (→ ty_e ... ty.norm) ≫ name-] [x : ty_e ≫ x-] ...)
    ⊢ [[b ≫ b-] ⇒ : _] ... [[body ≫ body-] ⇐ : ty.norm]]
   --------
   [⊢ [[_ ≫ (letrec- ([name- (λ- (x- ...) b- ... body-)])
              (name- e- ...))]
       ⇒ : ty.norm]]]
  [(let ([x:id e] ...) body ...) ≫
   --------
   [_ ≻ (ext-stlc:let ([x e] ...) (begin body ...))]])
(define-typed-syntax let*
  [(let* ([x:id e] ...) body ...) ≫
   --------
   [_ ≻ (ext-stlc:let* ([x e] ...) (begin body ...))]])

(define-typed-syntax begin
  [(begin body ... b) ⇐ : τ_expected ≫
   [⊢ [[body ≫ body-] ⇒ : _] ...]
   [⊢ [[b ≫ b-] ⇐ : τ_expected]]
   --------
   [⊢ [[_ ≫ (begin- body- ... b-)] ⇐ : _]]]
  [(begin body ... b) ≫
   [⊢ [[body ≫ body-] ⇒ : _] ...]
   [⊢ [[b ≫ b-] ⇒ : τ]]
   --------
   [⊢ [[_ ≫ (begin- body- ... b-)] ⇒ : τ]]])

;; hash
(define-type-constructor Hash #:arity = 2)

(define-typed-syntax in-hash
  [(in-hash e) ≫
   [⊢ [[e ≫ e-] ⇒ : (~Hash ty_k ty_v)]]
   --------
   [⊢ [[_ ≫ (hash-map- e- list-)] ⇒ : (Sequence (stlc+rec-iso:× ty_k ty_v))]]])

; mutable hashes
(define-typed-syntax hash
  [(hash (~and tys {ty_key ty_val})) ≫
   [#:when (brace? #'tys)]
   --------
   [⊢ [[_ ≫ (make-hash-)] ⇒ : (Hash ty_key ty_val)]]]
  [(hash (~seq k v) ...) ≫
   [⊢ [[k ≫ k-] ⇒ : ty_k] ...]
   [⊢ [[v ≫ v-] ⇒ : ty_v] ...]
   [#:when (same-types? #'(ty_k ...))]
   [#:when (same-types? #'(ty_v ...))]
   [#:with ty_key (stx-car #'(ty_k ...))]
   [#:with ty_val (stx-car #'(ty_v ...))]
   --------
   [⊢ [[_ ≫ (make-hash- (list- (cons- k- v-) ...))] ⇒ : (Hash ty_key ty_val)]]])
(define-typed-syntax hash-set!
  [(hash-set! h k v) ≫
   [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]]
   [⊢ [[k ≫ k-] ⇐ : ty_k]]
   [⊢ [[v ≫ v-] ⇐ : ty_v]]
   --------
   [⊢ [[_ ≫ (hash-set!- h- k- v-)] ⇒ : Unit]]])
(define-typed-syntax hash-ref
  [(hash-ref h k) ≫
   [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]]
   [⊢ [[k ≫ k-] ⇐ : ty_k]]
   --------
   [⊢ [[_ ≫ (hash-ref- h- k-)] ⇒ : ty_v]]]
  [(hash-ref h k fail) ≫
   [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k ty_v)]]
   [⊢ [[k ≫ k-] ⇐ : ty_k]]
   [⊢ [[fail ≫ fail-] ⇐ : (→ ty_v)]]
   --------
   [⊢ [[_ ≫ (hash-ref- h- k- fail-)] ⇒ : ty_val]]])
(define-typed-syntax hash-has-key?
  [(hash-has-key? h k) ≫
   [⊢ [[h ≫ h-] ⇒ : (~Hash ty_k _)]]
   [⊢ [[k ≫ k-] ⇐ : ty_k]]
   --------
   [⊢ [[_ ≫ (hash-has-key?- h- k-)] ⇒ : Bool]]])

(define-typed-syntax hash-count
  [(hash-count h) ≫
   [⊢ [[h ≫ h-] ⇒ : (~Hash _ _)]]
   --------
   [⊢ [[_ ≫ (hash-count- h-)] ⇒ : Int]]])

(define-base-type String-Port)
(define-base-type Input-Port)
(define-primop open-output-string : (→ String-Port))
(define-primop get-output-string : (→ String-Port String))
(define-primop string-upcase : (→ String String))

(define-typed-syntax write-string
 [(write-string str out) ≫
  --------
  [_ ≻ (write-string str out (ext-stlc:#%datum . 0) (string-length str))]]
 [(write-string str out start end) ≫
  [⊢ [[str ≫ str-] ⇐ : String]]
  [⊢ [[out ≫ out-] ⇐ : String-Port]]
  [⊢ [[start ≫ start-] ⇐ : Int]]
  [⊢ [[end ≫ end-] ⇐ : Int]]
  --------
  [⊢ [[_ ≫ (begin- (write-string- str- out- start- end-) (void-))] ⇒ : Unit]]])

(define-typed-syntax string-length
 [(string-length str) ≫
  [⊢ [[str ≫ str-] ⇐ : String]]
  --------
  [⊢ [[_ ≫ (string-length- str-)] ⇒ : Int]]])
(define-primop make-string : (→ Int String))
(define-primop string-set! : (→ String Int Char Unit))
(define-primop string-ref : (→ String Int Char))
(define-typed-syntax string-copy!
  [(string-copy! dest dest-start src) ≫
   --------
   [_ ≻ (string-copy!
         dest dest-start src (ext-stlc:#%datum . 0) (string-length src))]]
  [(string-copy! dest dest-start src src-start src-end) ≫
   [⊢ [[dest ≫ dest-] ⇐ : String]]
   [⊢ [[src ≫ src-] ⇐ : String]]
   [⊢ [[dest-start ≫ dest-start-] ⇐ : Int]]
   [⊢ [[src-start ≫ src-start-] ⇐ : Int]]
   [⊢ [[src-end ≫ src-end-] ⇐ : Int]]
   --------
   [⊢ [[_ ≫ (string-copy!- dest- dest-start- src- src-start- src-end-)] ⇒ : Unit]]])

(define-primop fl+ : (→ Float Float Float))
(define-primop fl- : (→ Float Float Float))
(define-primop fl* : (→ Float Float Float))
(define-primop fl/ : (→ Float Float Float))
(define-primop flsqrt : (→ Float Float))
(define-primop flceiling : (→ Float Float))
(define-primop inexact->exact : (→ Float Int))
(define-primop exact->inexact : (→ Int Float))
(define-primop char->integer : (→ Char Int))
(define-primop real->decimal-string : (→ Float Int String))
(define-primop fx->fl : (→ Int Float))
(define-typed-syntax quotient+remainder
  [(quotient+remainder x y) ≫
   [⊢ [[x ≫ x-] ⇐ : Int]]
   [⊢ [[y ≫ y-] ⇐ : Int]]
   --------
   [⊢ [[_ ≫ (let-values- ([[a b] (quotient/remainder- x- y-)])
              (list- a b))]
       ⇒ : (stlc+rec-iso:× Int Int)]]])
(define-primop quotient : (→ Int Int Int))

(define-typed-syntax set!
  [(set! x:id e) ≫
   [⊢ [[x ≫ x-] ⇒ : ty_x]]
   [⊢ [[e ≫ e-] ⇐ : ty_x]]
   --------
   [⊢ [[_ ≫ (set!- x e-)] ⇒ : Unit]]])

(define-typed-syntax provide-type
  [(provide-type ty ...) ≫
   --------
   [_ ≻ (provide- ty ...)]])

(define-typed-syntax provide
  [(provide x:id ...) ≫
   [⊢ [[x ≫ x-] ⇒ : ty_x] ...]
   ; TODO: use hash-code to generate this tmp
   [#:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...))]
   --------
   [_ ≻ (begin-
          (provide- x ...)
          (stlc+rec-iso:define-type-alias x-ty ty_x) ...
          (provide- x-ty ...))]])
(define-typed-syntax require-typed
  [(require-typed x:id ... #:from mod) ≫
   [#:with (x-ty ...) (stx-map (lambda (y) (format-id y "~a-ty" y)) #'(x ...))]
   [#:with (y ...) (generate-temporaries #'(x ...))]
   --------
   [_ ≻ (begin-
          (require- (rename-in (only-in mod x ... x-ty ...) [x y] ...))
          (define-syntax x (make-rename-transformer (assign-type #'y #'x-ty))) ...)]])

(define-base-type Regexp)
(define-primop regexp-match : (→ Regexp String (List String)))
(define-primop regexp : (→ String Regexp))

(define-typed-syntax equal?
  [(equal? e1 e2) ≫
   [⊢ [[e1 ≫ e1-] ⇒ : ty1]]
   [⊢ [[e2 ≫ e2-] ⇐ : ty1]]
   --------
   [⊢ [[_ ≫ (equal?- e1- e2-)] ⇒ : Bool]]])

(define-typed-syntax read-int
  [(read-int) ≫
   --------
   [⊢ [[_ ≫ (let- ([x (read-)])
              (cond- [(exact-integer?- x) x]
                     [else (error- 'read-int "expected an int, given: ~v" x)]))]
       ⇒ : Int]]])

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module+ test
  (begin-for-syntax
    (check-true  (covariant-Xs? #'Int))
    (check-true  (covariant-Xs? #'(stlc+box:Ref Int)))
    (check-true  (covariant-Xs? #'(→ Int Int)))
    (check-true  (covariant-Xs? #'(∀ (X) X)))
    (check-false (covariant-Xs? #'(∀ (X) (stlc+box:Ref X))))
    (check-false (covariant-Xs? #'(∀ (X) (→ X X))))
    (check-false (covariant-Xs? #'(∀ (X) (→ X Int))))
    (check-true  (covariant-Xs? #'(∀ (X) (→ Int X))))
    (check-true  (covariant-Xs? #'(∀ (X) (→ (→ X Int) X))))
    (check-false (covariant-Xs? #'(∀ (X) (→ (→ (→ X Int) Int) X))))
    (check-false (covariant-Xs? #'(∀ (X) (→ (stlc+box:Ref X) Int))))
    (check-false (covariant-Xs? #'(∀ (X Y) (→ X Y))))
    (check-true  (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) Y))))
    (check-false (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Y Int)))))
    (check-true  (covariant-Xs? #'(∀ (X Y) (→ (→ X Int) (→ Int Y)))))
    (check-false (covariant-Xs? #'(∀ (A B) (→ (→ Int (stlc+rec-iso:× A B))
                                              (→ String (stlc+rec-iso:× A B))
                                              (stlc+rec-iso:× A B)))))
    (check-true  (covariant-Xs? #'(∀ (A B) (→ (→ (stlc+rec-iso:× A B) Int)
                                              (→ (stlc+rec-iso:× A B) String)
                                              (stlc+rec-iso:× A B)))))
    ))