+\subsection{'hole' type variables}
+%* *
+%************************************************************************
+
+\begin{code}
+data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference
+ | Check ty -- The type to check during type checking
+
+newHole :: TcM (TcRef ty)
+newHole = newMutVar (error "Empty hole in typechecker")
+
+readExpectedType :: Expected ty -> TcM ty
+readExpectedType (Infer hole) = readMutVar hole
+readExpectedType (Check ty) = returnM ty
+
+zapExpectedType :: Expected TcType -> Kind -> TcM TcTauType
+-- In the inference case, ensure we have a monotype
+-- (including an unboxed tuple)
+zapExpectedType (Infer hole) kind
+ = do { ty <- newTyVarTy kind ;
+ writeMutVar hole ty ;
+ return ty }
+
+zapExpectedType (Check ty) kind
+ | typeKind ty `isSubKind` kind = return ty
+ | otherwise = do { ty1 <- newTyVarTy kind
+ ; unifyTauTy ty1 ty
+ ; return ty }
+ -- The unify is to ensure that 'ty' has the desired kind
+ -- For example, in (case e of r -> b) we push an OpenTypeKind
+ -- type variable
+
+zapExpectedTo :: Expected TcType -> TcTauType -> TcM ()
+zapExpectedTo (Infer hole) ty2 = writeMutVar hole ty2
+zapExpectedTo (Check ty1) ty2 = unifyTauTy ty1 ty2
+
+zapExpectedBranches :: [a] -> Expected TcType -> TcM (Expected TcType)
+-- Zap the expected type to a monotype if there is more than one branch
+zapExpectedBranches branches exp_ty
+ | lengthExceeds branches 1 = zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' ->
+ return (Check exp_ty')
+ | otherwise = returnM exp_ty
+
+instance Outputable ty => Outputable (Expected ty) where
+ ppr (Check ty) = ptext SLIT("Expected type") <+> ppr ty
+ ppr (Infer hole) = ptext SLIT("Inferring type")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Unify-fun]{@unifyFunTy@}
+%* *
+%************************************************************************
+
+@subFunTy@ and @unifyFunTy@ is used to avoid the fruitless
+creation of type variables.
+
+* subFunTy is used when we might be faced with a "hole" type variable,
+ in which case we should create two new holes.
+
+* unifyFunTy is used when we expect to encounter only "ordinary"
+ type variables, so we should create new ordinary type variables
+
+\begin{code}
+subFunTys :: [pat]
+ -> Expected TcRhoType -- Fail if ty isn't a function type
+ -> ([(pat, Expected TcRhoType)] -> Expected TcRhoType -> TcM a)
+ -> TcM a
+
+subFunTys pats (Infer hole) thing_inside
+ = -- This is the interesting case
+ mapM new_pat_hole pats `thenM` \ pats_w_holes ->
+ newHole `thenM` \ res_hole ->
+
+ -- Do the business
+ thing_inside pats_w_holes (Infer res_hole) `thenM` \ answer ->
+
+ -- Extract the answers
+ mapM read_pat_hole pats_w_holes `thenM` \ arg_tys ->
+ readMutVar res_hole `thenM` \ res_ty ->
+
+ -- Write the answer into the incoming hole
+ writeMutVar hole (mkFunTys arg_tys res_ty) `thenM_`
+
+ -- And return the answer
+ returnM answer
+ where
+ new_pat_hole pat = newHole `thenM` \ hole -> return (pat, Infer hole)
+ read_pat_hole (pat, Infer hole) = readMutVar hole
+
+subFunTys pats (Check ty) thing_inside
+ = go pats ty `thenM` \ (pats_w_tys, res_ty) ->
+ thing_inside pats_w_tys res_ty
+ where
+ go [] ty = return ([], Check ty)
+ go (pat:pats) ty = unifyFunTy ty `thenM` \ (arg,res) ->
+ go pats res `thenM` \ (pats_w_tys, final_res) ->
+ return ((pat, Check arg) : pats_w_tys, final_res)
+
+unifyFunTy :: TcRhoType -- Fail if ty isn't a function type
+ -> TcM (TcType, TcType) -- otherwise return arg and result types
+
+unifyFunTy ty@(TyVarTy tyvar)
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
+ case maybe_ty of
+ Just ty' -> unifyFunTy ty'
+ Nothing -> unify_fun_ty_help ty
+
+unifyFunTy ty
+ = case tcSplitFunTy_maybe ty of
+ Just arg_and_res -> returnM arg_and_res
+ Nothing -> unify_fun_ty_help ty
+
+unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification
+ = newTyVarTy argTypeKind `thenM` \ arg ->
+ newTyVarTy openTypeKind `thenM` \ res ->
+ unifyTauTy ty (mkFunTy arg res) `thenM_`
+ returnM (arg,res)
+\end{code}
+
+\begin{code}
+----------------------
+zapToListTy, zapToPArrTy :: Expected TcType -- expected list type
+ -> TcM TcType -- list element type
+unifyListTy, unifyPArrTy :: TcType -> TcM TcType
+zapToListTy = zapToXTy listTyCon
+unifyListTy = unifyXTy listTyCon
+zapToPArrTy = zapToXTy parrTyCon
+unifyPArrTy = unifyXTy parrTyCon
+
+----------------------
+zapToXTy :: TyCon -- T :: *->*
+ -> Expected TcType -- Expected type (T a)
+ -> TcM TcType -- Element type, a
+
+zapToXTy tc (Check ty) = unifyXTy tc ty
+zapToXTy tc (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ;
+ writeMutVar hole (mkTyConApp tc [elt_ty]) ;
+ return elt_ty }
+
+----------------------
+unifyXTy :: TyCon -> TcType -> TcM TcType
+unifyXTy tc ty@(TyVarTy tyvar)
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
+ case maybe_ty of
+ Just ty' -> unifyXTy tc ty'
+ other -> unify_x_ty_help tc ty
+
+unifyXTy tc ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (tycon, [arg_ty]) | tycon == tc -> returnM arg_ty
+ other -> unify_x_ty_help tc ty
+
+unify_x_ty_help tc ty -- Revert to ordinary unification
+ = newTyVarTy liftedTypeKind `thenM` \ elt_ty ->
+ unifyTauTy ty (mkTyConApp tc [elt_ty]) `thenM_`
+ returnM elt_ty
+\end{code}
+
+\begin{code}
+----------------------
+zapToTupleTy :: Boxity -> Arity -> Expected TcType -> TcM [TcType]
+zapToTupleTy boxity arity (Check ty) = unifyTupleTy boxity arity ty
+zapToTupleTy boxity arity (Infer hole) = do { (tup_ty, arg_tys) <- new_tuple_ty boxity arity ;
+ writeMutVar hole tup_ty ;
+ return arg_tys }
+
+unifyTupleTy boxity arity ty@(TyVarTy tyvar)
+ = getTcTyVar tyvar `thenM` \ maybe_ty ->
+ case maybe_ty of
+ Just ty' -> unifyTupleTy boxity arity ty'
+ other -> unify_tuple_ty_help boxity arity ty
+
+unifyTupleTy boxity arity ty
+ = case tcSplitTyConApp_maybe ty of
+ Just (tycon, arg_tys)
+ | isTupleTyCon tycon
+ && tyConArity tycon == arity
+ && tupleTyConBoxity tycon == boxity
+ -> returnM arg_tys
+ other -> unify_tuple_ty_help boxity arity ty
+
+unify_tuple_ty_help boxity arity ty
+ = new_tuple_ty boxity arity `thenM` \ (tup_ty, arg_tys) ->
+ unifyTauTy ty tup_ty `thenM_`
+ returnM arg_tys
+
+new_tuple_ty boxity arity
+ = newTyVarTys arity kind `thenM` \ arg_tys ->
+ return (mkTyConApp tup_tc arg_tys, arg_tys)
+ where
+ tup_tc = tupleTyCon boxity arity
+ kind | isBoxed boxity = liftedTypeKind
+ | otherwise = argTypeKind -- Components of an unboxed tuple
+ -- can be unboxed, but not unboxed tuples
+\end{code}
+
+
+%************************************************************************
+%* *