-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
+ -- It's used for wired-in tycons, so we call checkWiredInTyCOn
+ -- Precondition: never called with FunTyCon
+zapToTyConApp tc (Check ty)
+ = ASSERT( not (isFunTyCon tc) ) -- Never called with FunTyCon
+ do { checkWiredInTyCon tc ; unifyTyConApp tc ty } -- NB: fails for a forall-type
+
+zapToTyConApp tc (Infer hole)
+ = do { (_, elt_tys, _) <- tcInstTyVars (tyConTyVars tc)
+ ; let tc_app = mkTyConApp tc elt_tys
+ ; writeMutVar hole tc_app
+ ; traceTc (text "zap" <+> ppr tc)
+ ; checkWiredInTyCon tc
+ ; 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
+ = ASSERT( not (isFunTyCon tc) ) -- Never called with FunTyCon
+ unify_tc_app (tyConArity tc) 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 n_args use_refinement tc (NoteTy _ ty)
+ = unify_tc_app n_args use_refinement tc ty
+
+unify_tc_app n_args use_refinement tc (TyConApp tycon arg_tys)
+ | tycon == tc
+ = ASSERT( n_args == length arg_tys ) -- ty::*
+ mapM (wobblify use_refinement) arg_tys
+
+unify_tc_app n_args use_refinement tc (AppTy fun_ty arg_ty)
+ = do { arg_ty' <- wobblify use_refinement arg_ty
+ ; arg_tys <- unify_tc_app (n_args - 1) use_refinement tc fun_ty
+ ; return (arg_tys ++ [arg_ty']) }
+
+unify_tc_app n_args use_refinement tc ty@(TyVarTy tyvar)
+ = do { traceTc (text "unify_tc_app: tyvar" <+> pprTcTyVar tyvar)
+ ; details <- condLookupTcTyVar use_refinement tyvar
+ ; case details of
+ IndirectTv use' ty' -> unify_tc_app n_args use' tc ty'
+ other -> unify_tc_app_help n_args tc ty
+ }
+
+unify_tc_app n_args use_refinement tc ty = unify_tc_app_help n_args tc ty
+
+unify_tc_app_help n_args tc ty -- Revert to ordinary unification
+ = do { (_, elt_tys, _) <- tcInstTyVars (take n_args (tyConTyVars tc))
+ ; let tc_app = mkTyConApp tc elt_tys
+ ; 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 elt_tys } }
+
+
+----------------------
+unifyAppTy :: TcType -- Type to split: m a
+ -> TcM (TcType, TcType) -- (m,a)
+-- Assumes (m:*->*)
+
+unifyAppTy ty = unify_app_ty True ty
+
+unify_app_ty use (NoteTy _ ty) = unify_app_ty use ty
+
+unify_app_ty use ty@(TyVarTy tyvar)
+ = do { details <- condLookupTcTyVar use tyvar
+ ; case details of
+ IndirectTv use' ty' -> unify_app_ty use' ty'
+ other -> unify_app_ty_help ty
+ }
+
+unify_app_ty use ty
+ | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty
+ = do { fun' <- wobblify use fun_ty
+ ; arg' <- wobblify use arg_ty
+ ; return (fun', arg') }
+
+ | otherwise = unify_app_ty_help ty
+
+unify_app_ty_help ty -- Revert to ordinary unification
+ = do { fun_ty <- newTyFlexiVarTy (mkArrowKind liftedTypeKind liftedTypeKind)
+ ; arg_ty <- newTyFlexiVarTy liftedTypeKind
+ ; unifyTauTy (mkAppTy fun_ty arg_ty) ty
+ ; return (fun_ty, 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 -- Don't wobblify
+
+wobblify False ty@(TyVarTy tv)
+ | isMetaTyVar tv = return ty -- Already wobbly
+
+wobblify False ty = do { uniq <- newUnique
+ ; tv <- newMetaTyVar (mkSysTvName uniq FSLIT("w"))
+ (typeKind ty)
+ (Indirect ty)
+ ; return (mkTyVarTy tv) }