X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcUnify.lhs;h=395df1e7a43cab6a923638911d345b3c7dbf975e;hb=8e67f5502e2e316245806ee3735a2f41a844b611;hp=e4116e2ff769e247a8f1b2ac4ecf462fbffc59e2;hpb=9eb59090515da91f12fad9415800ae7059a08811;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index e4116e2..395df1e 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -6,60 +6,64 @@ \begin{code} module TcUnify ( -- Full-blown subsumption - tcSubOff, tcSubExp, tcGen, subFunTy, TcHoleType, - checkSigTyVars, checkSigTyVarsWrt, sigCtxt, findGlobals, + tcSubPat, tcSubExp, tcGen, + checkSigTyVars, checkSigTyVarsWrt, bleatEscapedTvs, sigCtxt, -- Various unifications - unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy, - unifyKind, unifyKinds, unifyOpenTypeKind, unifyFunKind, - - -- Coercions - Coercion, ExprCoFn, PatCoFn, - (<$>), (<.>), mkCoercion, - idCoercion, isIdCoercion - + unifyTauTy, unifyTauTyList, unifyTheta, + unifyKind, unifyKinds, unifyFunKind, + checkExpectedKind, + + -------------------------------- + -- Holes + Expected(..), tcInfer, readExpectedType, + zapExpectedType, zapExpectedTo, zapExpectedBranches, + subFunTys, unifyFunTys, + zapToListTy, unifyListTy, + zapToTyConApp, unifyTyConApp, + unifyAppTy ) where #include "HsVersions.h" - -import HsSyn ( HsExpr(..) ) -import TcHsSyn ( TypecheckedHsExpr, TcPat, mkHsLet ) -import TypeRep ( Type(..), SourceType(..), TyNote(..), openKindCon ) +-- gaw 2004 +import HsSyn ( HsExpr(..) , MatchGroup(..), hsLMatchPats ) +import TcHsSyn ( mkHsLet, mkHsDictLam, + ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) +import TypeRep ( Type(..), PredType(..), TyNote(..) ) import TcRnMonad -- TcType, amongst others import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, - TcTyVarSet, TcThetaType, TyVarDetails(SigTv), - isTauTy, isSigmaTy, + TcTyVarSet, TcThetaType, Expected(..), + SkolemInfo( GenSkol ), MetaDetails(..), + pprSkolemTyVar, isTauTy, isSigmaTy, mkFunTys, mkTyConApp, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, - tcGetTyVar_maybe, tcGetTyVar, - mkTyConApp, mkFunTy, tyVarsOfType, mkPhiTy, - typeKind, tcSplitFunTy_maybe, mkForAllTys, - isHoleTyVar, isSkolemTyVar, isUserTyVar, + tyVarsOfType, mkPhiTy, mkTyVarTy, mkPredTy, + typeKind, tcSplitFunTy_maybe, mkForAllTys, mkAppTy, tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars, - eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind, - hasMoreBoxityInfo, allDistinctTyVars - ) -import qualified Type ( getTyVar_maybe ) + pprType, tidySkolemTyVar, isSkolemTyVar ) +import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind, + openTypeKind, liftedTypeKind, mkArrowKind, kindFunResult, + isOpenTypeKind, argTypeKind, isLiftedTypeKind, isUnliftedTypeKind, + isSubKind, pprKind, splitKindFunTys ) import Inst ( newDicts, instToId, tcInstCall ) -import TcMType ( getTcTyVar, putTcTyVar, tcInstType, readHoleResult, newKindVar, - newTyVarTy, newTyVarTys, newOpenTypeKind, newHoleTyVarTy, - zonkTcType, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcTyVar ) +import TcMType ( condLookupTcTyVar, LookupTyVarResult(..), + putMetaTyVar, tcSkolType, newKindVar, tcInstTyVars, newMetaTyVar, + newTyFlexiVarTy, zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV, + readKindVar, writeKindVar ) import TcSimplify ( tcSimplifyCheck ) -import TysWiredIn ( listTyCon, parrTyCon, mkListTy, mkPArrTy, mkTupleTy ) -import TcEnv ( TcTyThing(..), tcGetGlobalTyVars, findGlobals ) -import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity ) -import PprType ( pprType ) -import Id ( Id, mkSysLocal, idType ) +import TcEnv ( tcGetGlobalTyVars, findGlobals ) +import TyCon ( TyCon, tyConArity, tyConTyVars ) +import TysWiredIn ( listTyCon ) +import Id ( Id, mkSysLocal ) import Var ( Var, varName, tyVarKind ) import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems ) import VarEnv -import Name ( isSystemName, getSrcLoc ) +import Name ( isSystemName, mkSysTvName ) import ErrUtils ( Message ) -import BasicTypes ( Boxity, Arity, isBoxed ) -import Util ( equalLength, notNull ) -import Maybe ( isNothing ) +import SrcLoc ( noLoc ) +import BasicTypes ( Arity ) +import Util ( notNull, equalLength ) import Outputable \end{code} @@ -69,6 +73,267 @@ Notes on holes %************************************************************************ %* * +\subsection{'hole' type variables} +%* * +%************************************************************************ + +\begin{code} +newHole = newMutVar (error "Empty hole in typechecker") + +tcInfer :: (Expected ty -> TcM a) -> TcM (a,ty) +tcInfer tc_infer + = do { hole <- newHole + ; res <- tc_infer (Infer hole) + ; res_ty <- readMutVar hole + ; return (res, res_ty) } + +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 <- newTyFlexiVarTy kind ; + writeMutVar hole ty ; + return ty } + +zapExpectedType (Check ty) kind + | typeKind ty `isSubKind` kind = return ty + | otherwise = do { ty1 <- newTyFlexiVarTy 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 + +zapExpectedBranches :: MatchGroup id -> Expected TcRhoType -> TcM (Expected TcRhoType) +-- If there is more than one branch in a case expression, +-- and exp_ty is a 'hole', all branches must be types, not type schemes, +-- otherwise the order in which we check them would affect the result. +zapExpectedBranches (MatchGroup [match] _) exp_ty + = return exp_ty -- One branch +zapExpectedBranches matches (Check ty) + = return (Check ty) +zapExpectedBranches matches (Infer hole) + = do { -- Many branches, and inference mode, + -- so switch to checking mode with a monotype + ty <- newTyFlexiVarTy openTypeKind + ; writeMutVar hole ty + ; return (Check ty) } + +zapExpectedTo :: Expected TcType -> TcTauType -> TcM () +zapExpectedTo (Check ty1) ty2 = unifyTauTy ty1 ty2 +zapExpectedTo (Infer hole) ty2 = do { ty2' <- zonkTcType ty2; writeMutVar hole ty2' } + -- See Note [Zonk return type] + +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 :: MatchGroup name + -> Expected TcRhoType -- Fail if ty isn't a function type + -> ([Expected TcRhoType] -> Expected TcRhoType -> TcM a) + -> TcM a + +subFunTys (MatchGroup (match:null_matches) _) (Infer hole) thing_inside + = -- This is the interesting case + ASSERT( null null_matches ) + do { pat_holes <- mapM (\ _ -> newHole) (hsLMatchPats match) + ; res_hole <- newHole + + -- Do the business + ; res <- thing_inside (map Infer pat_holes) (Infer res_hole) + + -- Extract the answers + ; arg_tys <- mapM readMutVar pat_holes + ; res_ty <- readMutVar res_hole + + -- Write the answer into the incoming hole + ; writeMutVar hole (mkFunTys arg_tys res_ty) + + -- And return the answer + ; return res } + +subFunTys (MatchGroup (match:matches) _) (Check ty) thing_inside + = ASSERT( all ((== length (hsLMatchPats match)) . length . hsLMatchPats) matches ) + -- Assertion just checks that all the matches have the same number of pats + do { (pat_tys, res_ty) <- unifyFunTys (length (hsLMatchPats match)) ty + ; thing_inside (map Check pat_tys) (Check res_ty) } + +unifyFunTys :: Arity -> TcRhoType -> TcM ([TcSigmaType], TcRhoType) +-- Fail if ty isn't a function type, otherwise return arg and result types +-- The result types are guaranteed wobbly if the argument is wobbly +-- +-- Does not allocate unnecessary meta variables: if the input already is +-- a function, we just take it apart. Not only is this efficient, it's important +-- for (a) higher rank: the argument might be of form +-- (forall a. ty) -> other +-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd +-- blow up with the meta var meets the forall +-- +-- (b) GADTs: if the argument is not wobbly we do not want the result to be + +unifyFunTys arity ty = unify_fun_ty True arity ty + +unify_fun_ty use_refinement arity ty + | arity == 0 + = do { res_ty <- wobblify use_refinement ty + ; return ([], ty) } + +unify_fun_ty use_refinement arity (NoteTy _ ty) + = unify_fun_ty use_refinement arity ty + +unify_fun_ty use_refinement arity ty@(TyVarTy tv) + = do { details <- condLookupTcTyVar use_refinement tv + ; case details of + IndirectTv use' ty' -> unify_fun_ty use' arity ty' + other -> unify_fun_help arity ty + } + +unify_fun_ty use_refinement arity ty + = case tcSplitFunTy_maybe ty of + Just (arg,res) -> do { arg' <- wobblify use_refinement arg + ; (args', res') <- unify_fun_ty use_refinement (arity-1) res + ; return (arg':args', res') } + + Nothing -> unify_fun_help arity ty + -- Usually an error, but ty could be (a Int Bool), which can match + +unify_fun_help :: Arity -> TcRhoType -> TcM ([TcSigmaType], TcRhoType) +unify_fun_help arity ty + = do { args <- mappM newTyFlexiVarTy (replicate arity argTypeKind) + ; res <- newTyFlexiVarTy openTypeKind + ; unifyTauTy ty (mkFunTys args res) + ; return (args, res) } +\end{code} + +\begin{code} +---------------------- +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) } +\end{code} + + +%************************************************************************ +%* * \subsection{Subsumption} %* * %************************************************************************ @@ -88,46 +353,64 @@ which takes an HsExpr of type offered_ty into one of type expected_ty. \begin{code} -type TcHoleType = TcSigmaType -- Either a TcSigmaType, - -- or else a hole +----------------------- +-- tcSubExp is used for expressions +tcSubExp :: Expected TcRhoType -> TcRhoType -> TcM ExprCoFn + +tcSubExp (Infer hole) offered_ty + = do { offered' <- zonkTcType offered_ty + -- Note [Zonk return type] + -- zonk to take advantage of the current GADT type refinement. + -- If we don't we get spurious "existential type variable escapes": + -- case (x::Maybe a) of + -- Just b (y::b) -> y + -- We need the refinement [b->a] to be applied to the result type + ; writeMutVar hole offered' + ; return idCoercion } + +tcSubExp (Check expected_ty) offered_ty + = tcSub expected_ty offered_ty -tcSubExp :: TcHoleType -> TcSigmaType -> TcM ExprCoFn -tcSubOff :: TcSigmaType -> TcHoleType -> TcM ExprCoFn -tcSub :: TcSigmaType -> TcSigmaType -> TcM ExprCoFn +----------------------- +-- tcSubPat is used for patterns +tcSubPat :: TcSigmaType -- Pattern type signature + -> Expected TcSigmaType -- Type from context + -> TcM () +-- In patterns we insist on an exact match; hence no CoFn returned +-- See Note [Pattern coercions] in TcPat +-- However, we can't call unify directly, because both types might be +-- polymorphic; hence the call to tcSub, followed by a check for +-- the identity coercion + +tcSubPat sig_ty (Infer hole) + = do { sig_ty' <- zonkTcType sig_ty + ; writeMutVar hole sig_ty' -- See notes with tcSubExp above + ; return () } + +tcSubPat sig_ty (Check exp_ty) + = do { co_fn <- tcSub sig_ty exp_ty + + ; if isIdCoercion co_fn then + return () + else + unifyMisMatch sig_ty exp_ty } \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 (TyVarTy tv) other_ty thing_inside - | isHoleTyVar tv - = getTcTyVar tv `thenM` \ maybe_ty -> - case maybe_ty of - Just ty -> thing_inside ty other_ty - Nothing -> traceTc (text "checkHole" <+> ppr tv) `thenM_` - putTcTyVar tv other_ty `thenM_` - returnM idCoercion - -checkHole ty other_ty thing_inside - = thing_inside ty other_ty -\end{code} + +%************************************************************************ +%* * + tcSub: main subsumption-check code +%* * +%************************************************************************ No holes expected now. Add some error-check context info. \begin{code} +----------------- +tcSub :: TcSigmaType -> TcSigmaType -> TcM ExprCoFn -- Locally used only + -- tcSub exp act checks that + -- act <= exp tcSub expected_ty actual_ty = traceTc (text "tcSub" <+> details) `thenM_` addErrCtxtM (unifyCtxt "type" expected_ty actual_ty) @@ -135,11 +418,8 @@ tcSub expected_ty actual_ty where details = vcat [text "Expected:" <+> ppr expected_ty, text "Actual: " <+> ppr actual_ty] -\end{code} -tc_sub carries the types before and after expanding type synonyms - -\begin{code} +----------------- tc_sub :: TcSigmaType -- expected_ty, before expanding synonyms -> TcSigmaType -- ..and after -> TcSigmaType -- actual_ty, before @@ -179,9 +459,9 @@ tc_sub exp_sty expected_ty act_sty actual_ty tc_sub exp_sty expected_ty act_sty actual_ty | isSigmaTy actual_ty - = tcInstCall Rank2Origin actual_ty `thenM` \ (inst_fn, body_ty) -> + = tcInstCall InstSigOrigin actual_ty `thenM` \ (inst_fn, _, body_ty) -> tc_sub exp_sty expected_ty body_ty body_ty `thenM` \ co_fn -> - returnM (co_fn <.> mkCoercion inst_fn) + returnM (co_fn <.> inst_fn) ----------------------------------- -- Function case @@ -201,7 +481,7 @@ tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res) -- when the arg/res is not a tau-type? -- NO! e.g. f :: ((forall a. a->a) -> Int) -> Int -- then x = (f,f) --- is perfectly fine, because we can instantiat f's type to a monotype +-- is perfectly fine, because we can instantiate f's type to a monotype -- -- However, we get can get jolly unhelpful error messages. -- e.g. foo = id runST @@ -215,36 +495,22 @@ tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res) -- -- I'm not quite sure what to do about this! -tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ (TyVarTy tv) - = ASSERT( not (isHoleTyVar tv) ) - getTcTyVar tv `thenM` \ maybe_ty -> - case maybe_ty of - Just ty -> tc_sub exp_sty exp_ty ty ty - Nothing -> imitateFun tv exp_sty `thenM` \ (act_arg, act_res) -> - tcSub_fun exp_arg exp_res act_arg act_res - -tc_sub _ (TyVarTy tv) act_sty act_ty@(FunTy act_arg act_res) - = ASSERT( not (isHoleTyVar tv) ) - getTcTyVar tv `thenM` \ maybe_ty -> - case maybe_ty of - Just ty -> tc_sub ty ty act_sty act_ty - Nothing -> imitateFun tv act_sty `thenM` \ (exp_arg, exp_res) -> - tcSub_fun exp_arg exp_res act_arg act_res +tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ act_ty + = do { ([act_arg], act_res) <- unifyFunTys 1 act_ty + ; tcSub_fun exp_arg exp_res act_arg act_res } + +tc_sub _ exp_ty act_sty act_ty@(FunTy act_arg act_res) + = do { ([exp_arg], exp_res) <- unifyFunTys 1 exp_ty + ; tcSub_fun exp_arg exp_res act_arg act_res } ----------------------------------- -- Unification case -- If none of the above match, we revert to the plain unifier tc_sub exp_sty expected_ty act_sty actual_ty - = uTys exp_sty expected_ty act_sty actual_ty `thenM_` + = uTys True exp_sty expected_ty True act_sty actual_ty `thenM_` returnM idCoercion \end{code} -%************************************************************************ -%* * -\subsection{Functions} -%* * -%************************************************************************ - \begin{code} tcSub_fun exp_arg exp_res act_arg act_res = tc_sub act_arg act_arg exp_arg exp_arg `thenM` \ co_fn_arg -> @@ -260,7 +526,7 @@ tcSub_fun exp_arg exp_res act_arg act_res | otherwise = mkCoercion co_fn co_fn e = DictLam [arg_id] - (co_fn_res <$> (HsApp e (co_fn_arg <$> (HsVar arg_id)))) + (noLoc (co_fn_res <$> (HsApp (noLoc e) (noLoc (co_fn_arg <$> HsVar arg_id))))) -- Slight hack; using a "DictLam" to get an ordinary simple lambda -- HsVar arg_id :: HsExpr exp_arg -- co_fn_arg $it :: HsExpr act_arg @@ -268,22 +534,6 @@ tcSub_fun exp_arg exp_res act_arg act_res -- co_fn_res $it :: HsExpr exp_res in returnM coercion - -imitateFun :: TcTyVar -> TcType -> TcM (TcType, TcType) -imitateFun tv ty - = ASSERT( not (isHoleTyVar tv) ) - -- NB: tv is an *ordinary* tyvar and so are the new ones - - -- Check that tv isn't a type-signature type variable - -- (This would be found later in checkSigTyVars, but - -- we get a better error message if we do it here.) - checkM (not (isSkolemTyVar tv)) - (failWithTcM (unifyWithSigErr tv ty)) `thenM_` - - newTyVarTy openTypeKind `thenM` \ arg -> - newTyVarTy openTypeKind `thenM` \ res -> - putTcTyVar tv (mkFunTy arg res) `thenM_` - returnM (arg,res) \end{code} @@ -304,10 +554,26 @@ tcGen :: TcSigmaType -- expected_ty tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall-type -- If not, the call is a no-op - = tcInstType SigTv expected_ty `thenM` \ (forall_tvs, theta, phi_ty) -> + = do { -- We want the GenSkol info in the skolemised type variables to + -- mention the *instantiated* tyvar names, so that we get a + -- good error message "Rigid variable 'a' is bound by (forall a. a->a)" + -- Hence the tiresome but innocuous fixM + ((forall_tvs, theta, rho_ty), skol_info) <- fixM (\ ~(_, skol_info) -> + do { (forall_tvs, theta, rho_ty) <- tcSkolType skol_info expected_ty + ; span <- getSrcSpanM + ; let skol_info = GenSkol forall_tvs (mkPhiTy theta rho_ty) span + ; return ((forall_tvs, theta, rho_ty), skol_info) }) + +#ifdef DEBUG + ; traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs, + text "expected_ty" <+> ppr expected_ty, + text "inst ty" <+> ppr forall_tvs <+> ppr theta <+> ppr rho_ty, + text "free_tvs" <+> ppr free_tvs, + text "forall_tvs" <+> ppr forall_tvs]) +#endif -- Type-check the arg and unify with poly type - getLIE (thing_inside phi_ty) `thenM` \ (result, lie) -> + ; (result, lie) <- getLIE (thing_inside rho_ty) -- Check that the "forall_tvs" havn't been constrained -- The interesting bit here is that we must include the free variables @@ -320,30 +586,19 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- Conclusion: include the free vars of the expected_ty in the -- list of "free vars" for the signature check. - newDicts SignatureOrigin theta `thenM` \ dicts -> - tcSimplifyCheck sig_msg forall_tvs dicts lie `thenM` \ inst_binds -> - -#ifdef DEBUG - zonkTcTyVars forall_tvs `thenM` \ forall_tys -> - traceTc (text "tcGen" <+> vcat [text "extra_tvs" <+> ppr extra_tvs, - text "expected_ty" <+> ppr expected_ty, - text "inst ty" <+> ppr forall_tvs <+> ppr theta <+> ppr phi_ty, - text "free_tvs" <+> ppr free_tvs, - text "forall_tys" <+> ppr forall_tys]) `thenM_` -#endif - - checkSigTyVarsWrt free_tvs forall_tvs `thenM` \ zonked_tvs -> + ; dicts <- newDicts (SigOrigin skol_info) theta + ; inst_binds <- tcSimplifyCheck sig_msg forall_tvs dicts lie - traceTc (text "tcGen:done") `thenM_` + ; checkSigTyVarsWrt free_tvs forall_tvs + ; traceTc (text "tcGen:done") - let + ; let -- This HsLet binds any Insts which came out of the simplification. -- It's a bit out of place here, but using AbsBind involves inventing -- a couple of new names which seems worse. - dict_ids = map instToId dicts - co_fn e = TyLam zonked_tvs (DictLam dict_ids (mkHsLet inst_binds e)) - in - returnM (mkCoercion co_fn, result) + dict_ids = map instToId dicts + co_fn e = TyLam forall_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e))) + ; returnM (mkCoercion co_fn, result) } where free_tvs = tyVarsOfType expected_ty `unionVarSet` extra_tvs sig_msg = ptext SLIT("expected type of an expression") @@ -353,39 +608,6 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall %************************************************************************ %* * -\subsection{Coercion functions} -%* * -%************************************************************************ - -\begin{code} -type Coercion a = Maybe (a -> a) - -- Nothing => identity fn - -type ExprCoFn = Coercion TypecheckedHsExpr -type PatCoFn = Coercion TcPat - -(<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition -Nothing <.> Nothing = Nothing -Nothing <.> Just f = Just f -Just f <.> Nothing = Just f -Just f1 <.> Just f2 = Just (f1 . f2) - -(<$>) :: Coercion a -> a -> a -Just f <$> e = f e -Nothing <$> e = e - -mkCoercion :: (a -> a) -> Coercion a -mkCoercion f = Just f - -idCoercion :: Coercion a -idCoercion = Nothing - -isIdCoercion :: Coercion a -> Bool -isIdCoercion = isNothing -\end{code} - -%************************************************************************ -%* * \subsection[Unify-exported]{Exported unification functions} %* * %************************************************************************ @@ -403,7 +625,13 @@ unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred ASSERT2( isTauTy ty1, ppr ty1 ) ASSERT2( isTauTy ty2, ppr ty2 ) addErrCtxtM (unifyCtxt "type" ty1 ty2) $ - uTys ty1 ty1 ty2 ty2 + uTys True ty1 ty1 True ty2 ty2 + +unifyTheta :: TcThetaType -> TcThetaType -> TcM () +unifyTheta theta1 theta2 + = do { checkTc (equalLength theta1 theta2) + (ptext SLIT("Contexts differ in length")) + ; unifyTauTyLists True (map mkPredTy theta1) True (map mkPredTy theta2) } \end{code} @unifyTauTyList@ unifies corresponding elements of two lists of @@ -412,11 +640,17 @@ of equal length. We charge down the list explicitly so that we can complain if their lengths differ. \begin{code} -unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM () -unifyTauTyLists [] [] = returnM () -unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenM_` - unifyTauTyLists tys1 tys2 -unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!" +unifyTauTyLists :: Bool -> -- Allow refinements on tys1 + [TcTauType] -> + Bool -> -- Allow refinements on tys2 + [TcTauType] -> TcM () +-- Precondition: lists must be same length +-- Having the caller check gives better error messages +-- Actually the caller neve does need to check; see Note [Tycon app] +unifyTauTyLists r1 [] r2 [] = returnM () +unifyTauTyLists r1 (ty1:tys1) r2 (ty2:tys2) = uTys r1 ty1 ty1 r2 ty2 ty2 `thenM_` + unifyTauTyLists r1 tys1 r2 tys2 +unifyTauTyLists r1 ty1s r2 ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!" \end{code} @unifyTauTyList@ takes a single list of @TauType@s and unifies them @@ -446,60 +680,54 @@ de-synonym'd version. This way we get better error messages. We call the first one \tr{ps_ty1}, \tr{ps_ty2} for ``possible synomym''. \begin{code} -uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 +uTys :: Bool -- Allow refinements to ty1 + -> TcTauType -> TcTauType -- Error reporting ty1 and real ty1 -- ty1 is the *expected* type - + -> Bool -- Allow refinements to ty2 -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2 -- ty2 is the *actual* type -> TcM () -- Always expand synonyms (see notes at end) -- (this also throws away FTVs) -uTys ps_ty1 (NoteTy n1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (NoteTy n2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys r1 ps_ty1 (NoteTy n1 ty1) r2 ps_ty2 ty2 = uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 +uTys r1 ps_ty1 ty1 r2 ps_ty2 (NoteTy n2 ty2) = uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 -- Variables; go for uVar -uTys ps_ty1 (TyVarTy tyvar1) ps_ty2 ty2 = uVar False tyvar1 ps_ty2 ty2 -uTys ps_ty1 ty1 ps_ty2 (TyVarTy tyvar2) = uVar True tyvar2 ps_ty1 ty1 +uTys r1 ps_ty1 (TyVarTy tyvar1) r2 ps_ty2 ty2 = uVar False r1 tyvar1 r2 ps_ty2 ty2 +uTys r1 ps_ty1 ty1 r2 ps_ty2 (TyVarTy tyvar2) = uVar True r2 tyvar2 r1 ps_ty1 ty1 -- "True" means args swapped -- Predicates -uTys _ (SourceTy (IParam n1 t1)) _ (SourceTy (IParam n2 t2)) - | n1 == n2 = uTys t1 t1 t2 t2 -uTys _ (SourceTy (ClassP c1 tys1)) _ (SourceTy (ClassP c2 tys2)) - | c1 == c2 = unifyTauTyLists tys1 tys2 -uTys _ (SourceTy (NType tc1 tys1)) _ (SourceTy (NType tc2 tys2)) - | tc1 == tc2 = unifyTauTyLists tys1 tys2 +uTys r1 _ (PredTy (IParam n1 t1)) r2 _ (PredTy (IParam n2 t2)) + | n1 == n2 = uTys r1 t1 t1 r2 t2 t2 +uTys r1 _ (PredTy (ClassP c1 tys1)) r2 _ (PredTy (ClassP c2 tys2)) + | c1 == c2 = unifyTauTyLists r1 tys1 r2 tys2 + -- Guaranteed equal lengths because the kinds check -- Functions; just check the two parts -uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) - = uTys fun1 fun1 fun2 fun2 `thenM_` uTys arg1 arg1 arg2 arg2 +uTys r1 _ (FunTy fun1 arg1) r2 _ (FunTy fun2 arg2) + = uTys r1 fun1 fun1 r2 fun2 fun2 `thenM_` uTys r1 arg1 arg1 r2 arg2 arg2 -- Type constructors must match -uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2) - | con1 == con2 && equalLength tys1 tys2 - = unifyTauTyLists tys1 tys2 - - | con1 == openKindCon - -- When we are doing kind checking, we might match a kind '?' - -- against a kind '*' or '#'. Notably, CCallable :: ? -> *, and - -- (CCallable Int) and (CCallable Int#) are both OK - = unifyOpenTypeKind ps_ty2 +uTys r1 ps_ty1 (TyConApp con1 tys1) r2 ps_ty2 (TyConApp con2 tys2) + | con1 == con2 = unifyTauTyLists r1 tys1 r2 tys2 + -- See Note [TyCon app] -- Applications need a bit of care! -- They can match FunTy and TyConApp, so use splitAppTy_maybe -- NB: we've already dealt with type variables and Notes, -- so if one type is an App the other one jolly well better be too -uTys ps_ty1 (AppTy s1 t1) ps_ty2 ty2 +uTys r1 ps_ty1 (AppTy s1 t1) r2 ps_ty2 ty2 = case tcSplitAppTy_maybe ty2 of - Just (s2,t2) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2 + Just (s2,t2) -> uTys r1 s1 s1 r2 s2 s2 `thenM_` uTys r1 t1 t1 r2 t2 t2 Nothing -> unifyMisMatch ps_ty1 ps_ty2 -- Now the same, but the other way round -- Don't swap the types, because the error messages get worse -uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2) +uTys r1 ps_ty1 ty1 r2 ps_ty2 (AppTy s2 t2) = case tcSplitAppTy_maybe ty1 of - Just (s1,t1) -> uTys s1 s1 s2 s2 `thenM_` uTys t1 t1 t2 t2 + Just (s1,t1) -> uTys r1 s1 s1 r2 s2 s2 `thenM_` uTys r1 t1 t1 r2 t2 t2 Nothing -> unifyMisMatch ps_ty1 ps_ty2 -- Not expecting for-alls in unification @@ -507,9 +735,19 @@ uTys ps_ty1 ty1 ps_ty2 (AppTy s2 t2) -- than a panic message! -- Anything else fails -uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 +uTys r1 ps_ty1 ty1 r2 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 \end{code} +Note [Tycon app] +~~~~~~~~~~~~~~~~ +When we find two TyConApps, the argument lists are guaranteed equal +length. Reason: intially the kinds of the two types to be unified is +the same. The only way it can become not the same is when unifying two +AppTys (f1 a1):=:(f2 a2). In that case there can't be a TyConApp in +the f1,f2 (because it'd absorb the app). If we unify f1:=:f2 first, +which we do, that ensures that f1,f2 have the same kind; and that +means a1,a2 have the same kind. And now the argument repeats. + Notes on synonyms ~~~~~~~~~~~~~~~~~ @@ -577,75 +815,94 @@ back into @uTys@ if it turns out that the variable is already bound. \begin{code} uVar :: Bool -- False => tyvar is the "expected" -- True => ty is the "expected" thing + -> Bool -- True, allow refinements to tv1, False don't -> TcTyVar + -> Bool -- Allow refinements to ty2? -> TcTauType -> TcTauType -- printing and real versions -> TcM () -uVar swapped tv1 ps_ty2 ty2 +uVar swapped r1 tv1 r2 ps_ty2 ty2 = traceTc (text "uVar" <+> ppr swapped <+> ppr tv1 <+> (ppr ps_ty2 $$ ppr ty2)) `thenM_` - getTcTyVar tv1 `thenM` \ maybe_ty1 -> - case maybe_ty1 of - Just ty1 | swapped -> uTys ps_ty2 ty2 ty1 ty1 -- Swap back - | otherwise -> uTys ty1 ty1 ps_ty2 ty2 -- Same order - other -> uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 + condLookupTcTyVar r1 tv1 `thenM` \ details -> + case details of + IndirectTv r1' ty1 | swapped -> uTys r2 ps_ty2 ty2 r1' ty1 ty1 -- Swap back + | otherwise -> uTys r1' ty1 ty1 r2 ps_ty2 ty2 -- Same order + FlexiTv -> uFlexiVar swapped tv1 r2 ps_ty2 ty2 + RigidTv -> uRigidVar swapped tv1 r2 ps_ty2 ty2 -- Expand synonyms; ignore FTVs -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 (NoteTy n2 ty2) - = uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2 - - - -- The both-type-variable case -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) - +uFlexiVar :: Bool -> TcTyVar -> + Bool -> -- Allow refinements to ty2 + TcTauType -> TcTauType -> TcM () +-- Invariant: tv1 is Flexi +uFlexiVar swapped tv1 r2 ps_ty2 (NoteTy n2 ty2) + = uFlexiVar swapped tv1 r2 ps_ty2 ty2 + +uFlexiVar swapped tv1 r2 ps_ty2 ty2@(TyVarTy tv2) -- Same type variable => no-op | tv1 == tv2 = returnM () -- Distinct type variables - -- ASSERT maybe_ty1 /= Just | otherwise - = getTcTyVar tv2 `thenM` \ maybe_ty2 -> - case maybe_ty2 of - Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2' - - Nothing | update_tv2 - - -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) - putTcTyVar tv2 (TyVarTy tv1) `thenM_` - returnM () - | otherwise - - -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) - putTcTyVar tv1 ps_ty2 `thenM_` - returnM () + = condLookupTcTyVar r2 tv2 `thenM` \ details -> + case details of + IndirectTv b ty2' -> uFlexiVar swapped tv1 b ty2' ty2' + FlexiTv | update_tv2 -> putMetaTyVar tv2 (TyVarTy tv1) + | otherwise -> updateFlexi swapped tv1 ty2 + RigidTv -> updateFlexi swapped tv1 ty2 + -- Note that updateFlexi does a sub-kind check + -- We might unify (a b) with (c d) where b::*->* and d::*; this should fail where k1 = tyVarKind tv1 k2 = tyVarKind tv2 - update_tv2 = (k2 `eqKind` openTypeKind) || (not (k1 `eqKind` openTypeKind) && nicer_to_update_tv2) - -- Try to get rid of open type variables as soon as poss + update_tv2 = k1 `isSubKind` k2 && (k1 /= k2 || nicer_to_update_tv2) + -- Update the variable with least kind info + -- See notes on type inference in Kind.lhs + -- The "nicer to" part only applies if the two kinds are the same, + -- so we can choose which to do. + + nicer_to_update_tv2 = isSystemName (varName tv2) + -- Try to update sys-y type variables in preference to sig-y ones + + -- First one is flexi, second one isn't a type variable +uFlexiVar swapped tv1 r2 ps_ty2 non_var_ty2 + = -- Do the occurs check, and check that we are not + -- unifying a type variable with a polytype + -- Returns a zonked type ready for the update + do { ty2 <- checkValue tv1 r2 ps_ty2 non_var_ty2 + ; updateFlexi swapped tv1 ty2 } - nicer_to_update_tv2 = isUserTyVar tv1 - -- Don't unify a signature type variable if poss - || isSystemName (varName tv2) - -- Try to update sys-y type variables in preference to sig-y ones +-- Ready to update tv1, which is flexi; occurs check is done +updateFlexi swapped tv1 ty2 + = do { checkKinds swapped tv1 ty2 + ; putMetaTyVar tv1 ty2 } - -- Second one isn't a type variable -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 non_var_ty2 - = -- Check that tv1 isn't a type-signature type variable - checkM (not (isSkolemTyVar tv1)) - (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenM_` - -- Do the occurs check, and check that we are not - -- unifying a type variable with a polytype - -- Returns a zonked type ready for the update - checkValue tv1 ps_ty2 non_var_ty2 `thenM` \ ty2 -> +uRigidVar :: Bool -> TcTyVar + -> Bool -> -- Allow refinements to ty2 + TcTauType -> TcTauType -> TcM () +-- Invariant: tv1 is Rigid +uRigidVar swapped tv1 r2 ps_ty2 (NoteTy n2 ty2) + = uRigidVar swapped tv1 r2 ps_ty2 ty2 - -- Check that the kinds match - checkKinds swapped tv1 ty2 `thenM_` + -- The both-type-variable case +uRigidVar swapped tv1 r2 ps_ty2 ty2@(TyVarTy tv2) + -- Same type variable => no-op + | tv1 == tv2 + = returnM () + + -- Distinct type variables + | otherwise + = condLookupTcTyVar r2 tv2 `thenM` \ details -> + case details of + IndirectTv b ty2' -> uRigidVar swapped tv1 b ty2' ty2' + FlexiTv -> updateFlexi swapped tv2 (TyVarTy tv1) + RigidTv -> unifyMisMatch (TyVarTy tv1) (TyVarTy tv2) - -- Perform the update - putTcTyVar tv1 ty2 `thenM_` - returnM () + -- Second one isn't a type variable +uRigidVar swapped tv1 r2 ps_ty2 non_var_ty2 + = unifyMisMatch (TyVarTy tv1) ps_ty2 \end{code} \begin{code} @@ -653,7 +910,7 @@ checkKinds swapped tv1 ty2 -- We're about to unify a type variable tv1 with a non-tyvar-type ty2. -- ty2 has been zonked at this stage, which ensures that -- its kind has as much boxity information visible as possible. - | tk2 `hasMoreBoxityInfo` tk1 = returnM () + | tk2 `isSubKind` tk1 = returnM () | otherwise -- Either the kinds aren't compatible @@ -661,7 +918,7 @@ checkKinds swapped tv1 ty2 -- or we are unifying a lifted type variable with an -- unlifted type: e.g. (id 3#) is illegal = addErrCtxtM (unifyKindCtxt swapped tv1 ty2) $ - unifyMisMatch k1 k2 + unifyKindMisMatch k1 k2 where (k1,k2) | swapped = (tk2,tk1) @@ -671,7 +928,7 @@ checkKinds swapped tv1 ty2 \end{code} \begin{code} -checkValue tv1 ps_ty2 non_var_ty2 +checkValue tv1 r2 ps_ty2 non_var_ty2 -- Do the occurs check, and check that we are not -- unifying a type variable with a polytype -- Return the type to update the type variable with, or fail @@ -695,12 +952,12 @@ checkValue tv1 ps_ty2 non_var_ty2 -- Rather, we should bind t to () (= non_var_ty2). -- -- That's why we have this two-state occurs-check - = zonkTcType ps_ty2 `thenM` \ ps_ty2' -> + = zonk_tc_type r2 ps_ty2 `thenM` \ ps_ty2' -> case okToUnifyWith tv1 ps_ty2' of { Nothing -> returnM ps_ty2' ; -- Success other -> - zonkTcType non_var_ty2 `thenM` \ non_var_ty2' -> + zonk_tc_type r2 non_var_ty2 `thenM` \ non_var_ty2' -> case okToUnifyWith tv1 non_var_ty2' of Nothing -> -- This branch rarely succeeds, except in strange cases -- like that in the example above @@ -708,6 +965,11 @@ checkValue tv1 ps_ty2 non_var_ty2 Just problem -> failWithTcM (unifyCheck problem tv1 ps_ty2') } + where + zonk_tc_type refine ty + = zonkType (\tv -> return (TyVarTy tv)) refine ty + -- We may already be inside a wobbly type t2, and + -- should take that into account here data Problem = OccurCheck | NotMonoType @@ -726,7 +988,7 @@ okToUnifyWith tv ty ok (FunTy t1 t2) = ok t1 `and` ok t2 ok (TyConApp _ ts) = oks ts ok (ForAllTy _ _) = Just NotMonoType - ok (SourceTy st) = ok_st st + ok (PredTy st) = ok_st st ok (NoteTy (FTVNote _) t) = ok t ok (NoteTy (SynNote t1) t2) = ok t1 `and` ok t2 -- Type variables may be free in t1 but not t2 @@ -736,207 +998,138 @@ okToUnifyWith tv ty ok_st (ClassP _ ts) = oks ts ok_st (IParam _ t) = ok t - ok_st (NType _ ts) = oks ts Nothing `and` m = m Just p `and` m = Just p \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} -subFunTy :: TcHoleType -- Fail if ty isn't a function type - -- If it's a hole, make two holes, feed them to... - -> (TcHoleType -> TcHoleType -> TcM a) -- the thing inside - -> TcM a -- and bind the function type to the hole - -subFunTy ty@(TyVarTy tyvar) thing_inside - | isHoleTyVar tyvar - = -- This is the interesting case - getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of { - Just ty' -> subFunTy ty' thing_inside ; - Nothing -> - - newHoleTyVarTy `thenM` \ arg_ty -> - newHoleTyVarTy `thenM` \ res_ty -> - - -- Do the business - thing_inside arg_ty res_ty `thenM` \ answer -> - - -- Extract the answers - readHoleResult arg_ty `thenM` \ arg_ty' -> - readHoleResult res_ty `thenM` \ res_ty' -> - - -- Write the answer into the incoming hole - putTcTyVar tyvar (mkFunTy arg_ty' res_ty') `thenM_` - - -- And return the answer - returnM answer } - -subFunTy ty thing_inside - = unifyFunTy ty `thenM` \ (arg,res) -> - thing_inside arg res - - -unifyFunTy :: TcRhoType -- Fail if ty isn't a function type - -> TcM (TcType, TcType) -- otherwise return arg and result types - -unifyFunTy ty@(TyVarTy tyvar) - = ASSERT( not (isHoleTyVar 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 openTypeKind `thenM` \ arg -> - newTyVarTy openTypeKind `thenM` \ res -> - unifyTauTy ty (mkFunTy arg res) `thenM_` - returnM (arg,res) -\end{code} - -\begin{code} -unifyListTy :: TcType -- expected list type - -> TcM TcType -- list element type - -unifyListTy ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyListTy ty' - other -> unify_list_ty_help ty - -unifyListTy ty - = case tcSplitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == listTyCon -> returnM arg_ty - other -> unify_list_ty_help ty - -unify_list_ty_help ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> - unifyTauTy ty (mkListTy elt_ty) `thenM_` - returnM elt_ty - --- variant for parallel arrays --- -unifyPArrTy :: TcType -- expected list type - -> TcM TcType -- list element type - -unifyPArrTy ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyPArrTy ty' - _ -> unify_parr_ty_help ty -unifyPArrTy ty - = case tcSplitTyConApp_maybe ty of - Just (tycon, [arg_ty]) | tycon == parrTyCon -> returnM arg_ty - _ -> unify_parr_ty_help ty - -unify_parr_ty_help ty -- Revert to ordinary unification - = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> - unifyTauTy ty (mkPArrTy elt_ty) `thenM_` - returnM elt_ty -\end{code} - -\begin{code} -unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType] -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 - = newTyVarTys arity kind `thenM` \ arg_tys -> - unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenM_` - returnM arg_tys - where - kind | isBoxed boxity = liftedTypeKind - | otherwise = openTypeKind -\end{code} - %************************************************************************ %* * -\subsection{Kind unification} + Kind unification %* * %************************************************************************ +Unifying kinds is much, much simpler than unifying types. + \begin{code} unifyKind :: TcKind -- Expected -> TcKind -- Actual -> TcM () -unifyKind k1 k2 = uTys k1 k1 k2 k2 +unifyKind LiftedTypeKind LiftedTypeKind = returnM () +unifyKind UnliftedTypeKind UnliftedTypeKind = returnM () + +unifyKind OpenTypeKind k2 | isOpenTypeKind k2 = returnM () +unifyKind ArgTypeKind k2 | isArgTypeKind k2 = returnM () + -- Respect sub-kinding + +unifyKind (FunKind a1 r1) (FunKind a2 r2) + = do { unifyKind a2 a1; unifyKind r1 r2 } + -- Notice the flip in the argument, + -- so that the sub-kinding works right + +unifyKind (KindVar kv1) k2 = uKVar False kv1 k2 +unifyKind k1 (KindVar kv2) = uKVar True kv2 k1 +unifyKind k1 k2 = unifyKindMisMatch k1 k2 unifyKinds :: [TcKind] -> [TcKind] -> TcM () unifyKinds [] [] = returnM () unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenM_` unifyKinds ks1 ks2 -unifyKinds _ _ = panic "unifyKinds: length mis-match" -\end{code} - -\begin{code} -unifyOpenTypeKind :: TcKind -> TcM () --- Ensures that the argument kind is of the form (Type bx) --- for some boxity bx - -unifyOpenTypeKind ty@(TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of - Just ty' -> unifyOpenTypeKind ty' - other -> unify_open_kind_help ty - -unifyOpenTypeKind ty - | isTypeKind ty = returnM () - | otherwise = unify_open_kind_help ty - -unify_open_kind_help ty -- Revert to ordinary unification - = newOpenTypeKind `thenM` \ open_kind -> - unifyKind ty open_kind +unifyKinds _ _ = panic "unifyKinds: length mis-match" + +---------------- +uKVar :: Bool -> KindVar -> TcKind -> TcM () +uKVar swapped kv1 k2 + = do { mb_k1 <- readKindVar kv1 + ; case mb_k1 of + Nothing -> uUnboundKVar swapped kv1 k2 + Just k1 | swapped -> unifyKind k2 k1 + | otherwise -> unifyKind k1 k2 } + +---------------- +uUnboundKVar :: Bool -> KindVar -> TcKind -> TcM () +uUnboundKVar swapped kv1 k2@(KindVar kv2) + | kv1 == kv2 = returnM () + | otherwise -- Distinct kind variables + = do { mb_k2 <- readKindVar kv2 + ; case mb_k2 of + Just k2 -> uUnboundKVar swapped kv1 k2 + Nothing -> writeKindVar kv1 k2 } + +uUnboundKVar swapped kv1 non_var_k2 + = do { k2' <- zonkTcKind non_var_k2 + ; kindOccurCheck kv1 k2' + ; k2'' <- kindSimpleKind swapped k2' + -- KindVars must be bound only to simple kinds + -- Polarities: (kindSimpleKind True ?) succeeds + -- returning *, corresponding to unifying + -- expected: ? + -- actual: kind-ver + ; writeKindVar kv1 k2'' } + +---------------- +kindOccurCheck kv1 k2 -- k2 is zonked + = checkTc (not_in k2) (kindOccurCheckErr kv1 k2) + where + not_in (KindVar kv2) = kv1 /= kv2 + not_in (FunKind a2 r2) = not_in a2 && not_in r2 + not_in other = True + +kindSimpleKind :: Bool -> Kind -> TcM SimpleKind +-- (kindSimpleKind True k) returns a simple kind sk such that sk <: k +-- If the flag is False, it requires k <: sk +-- E.g. kindSimpleKind False ?? = * +-- What about (kv -> *) :=: ?? -> * +kindSimpleKind orig_swapped orig_kind + = go orig_swapped orig_kind + where + go sw (FunKind k1 k2) = do { k1' <- go (not sw) k1 + ; k2' <- go sw k2 + ; return (FunKind k1' k2') } + go True OpenTypeKind = return liftedTypeKind + go True ArgTypeKind = return liftedTypeKind + go sw LiftedTypeKind = return liftedTypeKind + go sw k@(KindVar _) = return k -- KindVars are always simple + go swapped kind = failWithTc (ptext SLIT("Unexpected kind unification failure:") + <+> ppr orig_swapped <+> ppr orig_kind) + -- I think this can't actually happen + +-- T v = MkT v v must be a type +-- T v w = MkT (v -> w) v must not be an umboxed tuple + +---------------- +kindOccurCheckErr tyvar ty + = hang (ptext SLIT("Occurs check: cannot construct the infinite kind:")) + 2 (sep [ppr tyvar, char '=', ppr ty]) + +unifyKindMisMatch ty1 ty2 + = zonkTcKind ty1 `thenM` \ ty1' -> + zonkTcKind ty2 `thenM` \ ty2' -> + let + msg = hang (ptext SLIT("Couldn't match kind")) + 2 (sep [quotes (ppr ty1'), + ptext SLIT("against"), + quotes (ppr ty2')]) + in + failWithTc msg \end{code} \begin{code} unifyFunKind :: TcKind -> TcM (Maybe (TcKind, TcKind)) -- Like unifyFunTy, but does not fail; instead just returns Nothing -unifyFunKind (TyVarTy tyvar) - = getTcTyVar tyvar `thenM` \ maybe_ty -> - case maybe_ty of +unifyFunKind (KindVar kvar) + = readKindVar kvar `thenM` \ maybe_kind -> + case maybe_kind of Just fun_kind -> unifyFunKind fun_kind - Nothing -> newKindVar `thenM` \ arg_kind -> - newKindVar `thenM` \ res_kind -> - putTcTyVar tyvar (mkArrowKind arg_kind res_kind) `thenM_` - returnM (Just (arg_kind,res_kind)) + Nothing -> do { arg_kind <- newKindVar + ; res_kind <- newKindVar + ; writeKindVar kvar (mkArrowKind arg_kind res_kind) + ; returnM (Just (arg_kind,res_kind)) } -unifyFunKind (FunTy arg_kind res_kind) = returnM (Just (arg_kind,res_kind)) -unifyFunKind (NoteTy _ ty) = unifyFunKind ty -unifyFunKind other = returnM Nothing +unifyFunKind (FunKind arg_kind res_kind) = returnM (Just (arg_kind,res_kind)) +unifyFunKind other = returnM Nothing \end{code} %************************************************************************ @@ -955,7 +1148,7 @@ unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred returnM (err ty1' ty2') where err ty1 ty2 = (env1, - nest 4 + nest 2 (vcat [ text "Expected" <+> text s <> colon <+> ppr tidy_ty1, text "Inferred" <+> text s <> colon <+> ppr tidy_ty2 @@ -964,42 +1157,46 @@ unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred (env1, [tidy_ty1,tidy_ty2]) = tidyOpenTypes tidy_env [ty1,ty2] unifyKindCtxt swapped tv1 ty2 tidy_env -- not swapped => tv1 expected, ty2 inferred - -- tv1 is zonked already - = zonkTcType ty2 `thenM` \ ty2' -> - returnM (err ty2') + -- tv1 and ty2 are zonked already + = returnM msg where - err ty2 = (env2, ptext SLIT("When matching types") <+> - sep [quotes pp_expected, ptext SLIT("and"), quotes pp_actual]) - where - (pp_expected, pp_actual) | swapped = (pp2, pp1) - | otherwise = (pp1, pp2) - (env1, tv1') = tidyOpenTyVar tidy_env tv1 - (env2, ty2') = tidyOpenType env1 ty2 - pp1 = ppr tv1' - pp2 = ppr ty2' + msg = (env2, ptext SLIT("When matching the kinds of") <+> + sep [quotes pp_expected <+> ptext SLIT("and"), quotes pp_actual]) + + (pp_expected, pp_actual) | swapped = (pp2, pp1) + | otherwise = (pp1, pp2) + (env1, tv1') = tidyOpenTyVar tidy_env tv1 + (env2, ty2') = tidyOpenType env1 ty2 + pp1 = ppr tv1' <+> dcolon <+> ppr (tyVarKind tv1) + pp2 = ppr ty2' <+> dcolon <+> ppr (typeKind ty2) unifyMisMatch ty1 ty2 - = zonkTcType ty1 `thenM` \ ty1' -> - zonkTcType ty2 `thenM` \ ty2' -> - let - (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2'] - msg = hang (ptext SLIT("Couldn't match")) - 4 (sep [quotes (ppr tidy_ty1), - ptext SLIT("against"), - quotes (ppr tidy_ty2)]) + = do { (env1, pp1, extra1) <- ppr_ty emptyTidyEnv ty1 + ; (env2, pp2, extra2) <- ppr_ty env1 ty2 + ; let msg = sep [sep [ptext SLIT("Couldn't match") <+> pp1, nest 7 (ptext SLIT("against") <+> pp2)], + nest 2 extra1, nest 2 extra2] in - failWithTcM (env, msg) - -unifyWithSigErr tyvar ty - = (env2, hang (ptext SLIT("Cannot unify the type-signature variable") <+> quotes (ppr tidy_tyvar)) - 4 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty))) + failWithTcM (env2, msg) } + +ppr_ty :: TidyEnv -> TcType -> TcM (TidyEnv, SDoc, SDoc) +ppr_ty env ty + = do { ty' <- zonkTcType ty + ; let (env1,tidy_ty) = tidyOpenType env ty' + simple_result = (env1, quotes (ppr tidy_ty), empty) + ; case tidy_ty of + TyVarTy tv + | isSkolemTyVar tv -> return (env2, pp_rigid tv', + pprSkolemTyVar tv') + | otherwise -> return simple_result + where + (env2, tv') = tidySkolemTyVar env1 tv + other -> return simple_result } where - (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar - (env2, tidy_ty) = tidyOpenType env1 ty + pp_rigid tv = ptext SLIT("the rigid variable") <+> quotes (ppr tv) unifyCheck problem tyvar ty = (env2, hang msg - 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) + 2 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) where (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar (env2, tidy_ty) = tidyOpenType env1 ty @@ -1010,6 +1207,64 @@ unifyCheck problem tyvar ty \end{code} +%************************************************************************ +%* * + Checking kinds +%* * +%************************************************************************ + +--------------------------- +-- We would like to get a decent error message from +-- (a) Under-applied type constructors +-- f :: (Maybe, Maybe) +-- (b) Over-applied type constructors +-- f :: Int x -> Int x +-- + +\begin{code} +checkExpectedKind :: Outputable a => a -> TcKind -> TcKind -> TcM () +-- A fancy wrapper for 'unifyKind', which tries +-- to give decent error messages. +checkExpectedKind ty act_kind exp_kind + | act_kind `isSubKind` exp_kind -- Short cut for a very common case + = returnM () + | otherwise + = tryTc (unifyKind exp_kind act_kind) `thenM` \ (errs, mb_r) -> + case mb_r of { + Just _ -> returnM () ; -- Unification succeeded + Nothing -> + + -- So there's definitely an error + -- Now to find out what sort + zonkTcKind exp_kind `thenM` \ exp_kind -> + zonkTcKind act_kind `thenM` \ act_kind -> + + let (exp_as, _) = splitKindFunTys exp_kind + (act_as, _) = splitKindFunTys act_kind + n_exp_as = length exp_as + n_act_as = length act_as + + err | n_exp_as < n_act_as -- E.g. [Maybe] + = quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments") + + -- Now n_exp_as >= n_act_as. In the next two cases, + -- n_exp_as == 0, and hence so is n_act_as + | isLiftedTypeKind exp_kind && isUnliftedTypeKind act_kind + = ptext SLIT("Expecting a lifted type, but") <+> quotes (ppr ty) + <+> ptext SLIT("is unlifted") + + | isUnliftedTypeKind exp_kind && isLiftedTypeKind act_kind + = ptext SLIT("Expecting an unlifted type, but") <+> quotes (ppr ty) + <+> ptext SLIT("is lifted") + + | otherwise -- E.g. Monad [Int] + = sep [ ptext SLIT("Expecting kind") <+> quotes (pprKind exp_kind) <> comma, + ptext SLIT("but") <+> quotes (ppr ty) <+> + ptext SLIT("has kind") <+> quotes (pprKind act_kind)] + in + failWithTc (ptext SLIT("Kind error:") <+> err) + } +\end{code} %************************************************************************ %* * @@ -1017,18 +1272,10 @@ unifyCheck problem tyvar ty %* * %************************************************************************ -@checkSigTyVars@ is used after the type in a type signature has been unified with -the actual type found. It then checks that the type variables of the type signature -are - (a) Still all type variables - eg matching signature [a] against inferred type [(p,q)] - [then a will be unified to a non-type variable] +@checkSigTyVars@ checks that a set of universally quantified type varaibles +are not mentioned in the environment. In particular: - (b) Still all distinct - eg matching signature [(a,b)] against inferred type [(p,p)] - [then a and b will be unified together] - - (c) Not mentioned in the environment + (a) Not mentioned in the type of a variable in the envt eg the signature for f in this: g x = ... where @@ -1051,127 +1298,74 @@ are Before doing this, the substitution is applied to the signature type variable. -We used to have the notion of a "DontBind" type variable, which would -only be bound to itself or nothing. Then points (a) and (b) were -self-checking. But it gave rise to bogus consequential error messages. -For example: - - f = (*) -- Monomorphic - - g :: Num a => a -> a - g x = f x x - -Here, we get a complaint when checking the type signature for g, -that g isn't polymorphic enough; but then we get another one when -dealing with the (Num x) context arising from f's definition; -we try to unify x with Int (to default it), but find that x has already -been unified with the DontBind variable "a" from g's signature. -This is really a problem with side-effecting unification; we'd like to -undo g's effects when its type signature fails, but unification is done -by side effect, so we can't (easily). - -So we revert to ordinary type variables for signatures, and try to -give a helpful message in checkSigTyVars. - \begin{code} -checkSigTyVars :: [TcTyVar] -> TcM [TcTyVar] +checkSigTyVars :: [TcTyVar] -> TcM () checkSigTyVars sig_tvs = check_sig_tyvars emptyVarSet sig_tvs -checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM [TcTyVar] +checkSigTyVarsWrt :: TcTyVarSet -> [TcTyVar] -> TcM () checkSigTyVarsWrt extra_tvs sig_tvs = zonkTcTyVarsAndFV (varSetElems extra_tvs) `thenM` \ extra_tvs' -> check_sig_tyvars extra_tvs' sig_tvs check_sig_tyvars - :: TcTyVarSet -- Global type variables. The universally quantified - -- tyvars should not mention any of these - -- Guaranteed already zonked. - -> [TcTyVar] -- Universally-quantified type variables in the signature - -- Not guaranteed zonked. - -> TcM [TcTyVar] -- Zonked signature type variables - + :: TcTyVarSet -- Global type variables. The universally quantified + -- tyvars should not mention any of these + -- Guaranteed already zonked. + -> [TcTyVar] -- Universally-quantified type variables in the signature + -- Guaranteed to be skolems + -> TcM () check_sig_tyvars extra_tvs [] - = returnM [] + = returnM () check_sig_tyvars extra_tvs sig_tvs - = zonkTcTyVars sig_tvs `thenM` \ sig_tys -> - tcGetGlobalTyVars `thenM` \ gbl_tvs -> - let - env_tvs = gbl_tvs `unionVarSet` extra_tvs - in - traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tys, + = ASSERT( all isSkolemTyVar sig_tvs ) + do { gbl_tvs <- tcGetGlobalTyVars + ; traceTc (text "check_sig_tyvars" <+> (vcat [text "sig_tys" <+> ppr sig_tvs, text "gbl_tvs" <+> ppr gbl_tvs, - text "extra_tvs" <+> ppr extra_tvs])) `thenM_` - - checkM (allDistinctTyVars sig_tys env_tvs) - (complain sig_tys env_tvs) `thenM_` - - returnM (map (tcGetTyVar "checkSigTyVars") sig_tys) - + text "extra_tvs" <+> ppr extra_tvs])) + + ; let env_tvs = gbl_tvs `unionVarSet` extra_tvs + ; ifM (any (`elemVarSet` env_tvs) sig_tvs) + (bleatEscapedTvs env_tvs sig_tvs sig_tvs) + } + +bleatEscapedTvs :: TcTyVarSet -- The global tvs + -> [TcTyVar] -- The possibly-escaping type variables + -> [TcTyVar] -- The zonked versions thereof + -> TcM () +-- Complain about escaping type variables +-- We pass a list of type variables, at least one of which +-- escapes. The first list contains the original signature type variable, +-- while the second contains the type variable it is unified to (usually itself) +bleatEscapedTvs globals sig_tvs zonked_tvs + = do { (env3, msgs) <- foldlM check (env2, []) (tidy_tvs `zip` tidy_zonked_tvs) + ; failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) } where - complain sig_tys globals - = -- "check" checks each sig tyvar in turn - foldlM check - (env2, emptyVarEnv, []) - (tidy_tvs `zip` tidy_tys) `thenM` \ (env3, _, msgs) -> - - failWithTcM (env3, main_msg $$ nest 4 (vcat msgs)) - where - (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs - (env2, tidy_tys) = tidyOpenTypes env1 sig_tys - - main_msg = ptext SLIT("Inferred type is less polymorphic than expected") - - check (tidy_env, acc, msgs) (sig_tyvar,ty) - -- sig_tyvar is from the signature; - -- ty is what you get if you zonk sig_tyvar and then tidy it - -- - -- acc maps a zonked type variable back to a signature type variable - = case tcGetTyVar_maybe ty of { - Nothing -> -- Error (a)! - returnM (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ; - - Just tv -> - - case lookupVarEnv acc tv of { - Just sig_tyvar' -> -- Error (b)! - returnM (tidy_env, acc, unify_msg sig_tyvar thing : msgs) - where - thing = ptext SLIT("another quantified type variable") <+> quotes (ppr sig_tyvar') - - ; Nothing -> - - if tv `elemVarSet` globals -- Error (c) or (d)! Type variable escapes - -- The least comprehensible, so put it last - -- Game plan: - -- get the local TcIds and TyVars from the environment, - -- and pass them to find_globals (they might have tv free) - then findGlobals (unitVarSet tv) tidy_env `thenM` \ (tidy_env1, globs) -> - returnM (tidy_env1, acc, escape_msg sig_tyvar tv globs : msgs) - - else -- All OK - returnM (tidy_env, extendVarEnv acc tv sig_tyvar, msgs) - }} -\end{code} + (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs + (env2, tidy_zonked_tvs) = tidyOpenTyVars env1 zonked_tvs + main_msg = ptext SLIT("Inferred type is less polymorphic than expected") + + check (tidy_env, msgs) (sig_tv, zonked_tv) + | not (zonked_tv `elemVarSet` globals) = return (tidy_env, msgs) + | otherwise + = do { (tidy_env1, globs) <- findGlobals (unitVarSet zonked_tv) tidy_env + ; returnM (tidy_env1, escape_msg sig_tv zonked_tv globs : msgs) } -\begin{code} ----------------------- -escape_msg sig_tv tv globs - = mk_msg sig_tv <+> ptext SLIT("escapes") $$ - if notNull globs then - vcat [pp_it <+> ptext SLIT("is mentioned in the environment:"), - nest 2 (vcat globs)] - else - empty -- Sigh. It's really hard to give a good error message - -- all the time. One bad case is an existential pattern match. - -- We rely on the "When..." context to help. +escape_msg sig_tv zonked_tv globs + | notNull globs + = vcat [sep [msg, ptext SLIT("is mentioned in the environment:")], + nest 2 (vcat globs)] + | otherwise + = msg <+> ptext SLIT("escapes") + -- Sigh. It's really hard to give a good error message + -- all the time. One bad case is an existential pattern match. + -- We rely on the "When..." context to help. where - pp_it | sig_tv /= tv = ptext SLIT("It unifies with") <+> quotes (ppr tv) <> comma <+> ptext SLIT("which") - | otherwise = ptext SLIT("It") - - -unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> thing -mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv) + msg = ptext SLIT("Quantified type variable") <+> quotes (ppr sig_tv) <+> is_bound_to + is_bound_to + | sig_tv == zonked_tv = empty + | otherwise = ptext SLIT("is unified with") <+> quotes (ppr zonked_tv) <+> ptext SLIT("which") \end{code} These two context are used with checkSigTyVars @@ -1189,7 +1383,7 @@ sigCtxt id sig_tvs sig_theta sig_tau tidy_env ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau ] msg = vcat [ptext SLIT("When trying to generalise the type inferred for") <+> quotes (ppr id), - nest 4 sub_msg] + nest 2 sub_msg] in returnM (env3, msg) \end{code}