+
+%************************************************************************
+%* *
+\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}
+
+
+%************************************************************************
+%* *
+\subsection{Subsumption}
+%* *
+%************************************************************************
+
+All the tcSub calls have the form
+
+ tcSub expected_ty offered_ty
+which checks
+ offered_ty <= expected_ty
+
+That is, that a value of type offered_ty is acceptable in
+a place expecting a value of type expected_ty.
+
+It returns a coercion function
+ co_fn :: offered_ty -> expected_ty
+which takes an HsExpr of type offered_ty into one of type
+expected_ty.
+
+\begin{code}
+tcSubExp :: Expected TcRhoType -> TcRhoType -> TcM ExprCoFn
+tcSubOff :: TcSigmaType -> Expected TcSigmaType -> TcM ExprCoFn
+\end{code}
+
+These two check for holes
+
+\begin{code}
+tcSubExp expected_ty offered_ty
+ = traceTc (text "tcSubExp" <+> (ppr expected_ty $$ ppr offered_ty)) `thenM_`
+ checkHole expected_ty offered_ty tcSub
+
+tcSubOff expected_ty offered_ty
+ = checkHole offered_ty expected_ty (\ off exp -> tcSub exp off)
+
+-- checkHole looks for a hole in its first arg;
+-- If so, and it is uninstantiated, it fills in the hole
+-- with its second arg
+-- Otherwise it calls thing_inside, passing the two args, looking
+-- through any instantiated hole
+
+checkHole (Infer hole) other_ty thing_inside
+ = do { writeMutVar hole other_ty; return idCoercion }
+
+checkHole (Check ty) other_ty thing_inside
+ = thing_inside ty other_ty