-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 (mkTupleTy boxity arity arg_tys, arg_tys)
- where
- kind | isBoxed boxity = liftedTypeKind
- | otherwise = openTypeKind
+----------------------
+zapToTyConApp :: TyCon -- T :: k1 -> ... -> kn -> *
+ -> Expected TcSigmaType -- Expected type (T a b c)
+ -> TcM [TcType] -- Element types, a b c
+ -- Insists that the Expected type is not a forall-type
+
+zapToTyConApp tc (Check ty)
+ = unifyTyConApp tc ty -- NB: fails for a forall-type
+zapToTyConApp tc (Infer hole)
+ = do { (tc_app, elt_tys) <- newTyConApp tc
+ ; writeMutVar hole tc_app
+ ; return elt_tys }
+
+zapToListTy :: Expected TcType -> TcM TcType -- Special case for lists
+zapToListTy exp_ty = do { [elt_ty] <- zapToTyConApp listTyCon exp_ty
+ ; return elt_ty }
+
+----------------------
+unifyTyConApp :: TyCon -> TcType -> TcM [TcType]
+unifyTyConApp tc ty = unify_tc_app True tc ty
+ -- Add a boolean flag to remember whether to use
+ -- the type refinement or not
+
+unifyListTy :: TcType -> TcM TcType -- Special case for lists
+unifyListTy exp_ty = do { [elt_ty] <- unifyTyConApp listTyCon exp_ty
+ ; return elt_ty }
+
+----------
+unify_tc_app use_refinement tc (NoteTy _ ty)
+ = unify_tc_app use_refinement tc ty
+
+unify_tc_app use_refinement tc ty@(TyVarTy tyvar)
+ = do { details <- condLookupTcTyVar use_refinement tyvar
+ ; case details of
+ IndirectTv use' ty' -> unify_tc_app use' tc ty'
+ other -> unify_tc_app_help tc ty
+ }
+
+unify_tc_app use_refinement tc ty
+ | Just (tycon, arg_tys) <- tcSplitTyConApp_maybe ty,
+ tycon == tc
+ = ASSERT( tyConArity tycon == length arg_tys ) -- ty::*
+ mapM (wobblify use_refinement) arg_tys
+
+unify_tc_app use_refinement tc ty = unify_tc_app_help tc ty
+
+----------
+unify_tc_app_help tc ty -- Revert to ordinary unification
+ = do { (tc_app, arg_tys) <- newTyConApp tc
+ ; if not (isTauTy ty) then -- Can happen if we call zapToTyConApp tc (forall a. ty)
+ unifyMisMatch ty tc_app
+ else do
+ { unifyTauTy ty tc_app
+ ; returnM arg_tys } }
+
+
+----------------------
+unifyAppTy :: TcType -- Expected type function: m
+ -> TcType -- Type to split: m a
+ -> TcM TcType -- Type arg: a
+unifyAppTy tc ty = unify_app_ty True tc ty
+
+unify_app_ty use tc (NoteTy _ ty) = unify_app_ty use tc ty
+
+unify_app_ty use tc ty@(TyVarTy tyvar)
+ = do { details <- condLookupTcTyVar use tyvar
+ ; case details of
+ IndirectTv use' ty' -> unify_app_ty use' tc ty'
+ other -> unify_app_ty_help tc ty
+ }
+
+unify_app_ty use tc ty
+ | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+ = do { unifyTauTy tc fun_ty
+ ; wobblify use arg_ty }
+
+ | otherwise = unify_app_ty_help tc ty
+
+unify_app_ty_help tc ty -- Revert to ordinary unification
+ = do { arg_ty <- newTyFlexiVarTy (kindFunResult (typeKind tc))
+ ; unifyTauTy (mkAppTy tc arg_ty) ty
+ ; return arg_ty }
+
+
+----------------------
+wobblify :: Bool -- True <=> don't wobblify
+ -> TcTauType
+ -> TcM TcTauType
+-- Return a wobbly type. At the moment we do that by
+-- allocating a fresh meta type variable.
+wobblify True ty = return ty
+wobblify False ty = do { uniq <- newUnique
+ ; tv <- newMetaTyVar (mkSysTvName uniq FSLIT("w"))
+ (typeKind ty)
+ (Indirect ty)
+ ; return (mkTyVarTy tv) }
+
+----------------------
+newTyConApp :: TyCon -> TcM (TcTauType, [TcTauType])
+newTyConApp tc = do { (tvs, args, _) <- tcInstTyVars (tyConTyVars tc)
+ ; return (mkTyConApp tc args, args) }