From: simonpj Date: Mon, 26 Nov 2001 09:22:05 +0000 (+0000) Subject: [project @ 2001-11-26 09:22:05 by simonpj] X-Git-Tag: Approximately_9120_patches~526 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0760818ed7cd939ca14639e1aebfc67bd934f220;p=ghc-hetmet.git [project @ 2001-11-26 09:22:05 by simonpj] Add missing files for Rank-N commit --- diff --git a/ghc/compiler/typecheck/TcUnify.hi-boot b/ghc/compiler/typecheck/TcUnify.hi-boot new file mode 100644 index 0000000..e7b21a2 --- /dev/null +++ b/ghc/compiler/typecheck/TcUnify.hi-boot @@ -0,0 +1,7 @@ +_interface_ TcUnify 1 +_exports_ +TcUnify unifyTauTy; +_declarations_ +1 unifyTauTy _:_ TcType.TcTauType -> TcType.TcTauType -> TcMonad.TcM () ;; + + diff --git a/ghc/compiler/typecheck/TcUnify.hi-boot-5 b/ghc/compiler/typecheck/TcUnify.hi-boot-5 new file mode 100644 index 0000000..ad561d2 --- /dev/null +++ b/ghc/compiler/typecheck/TcUnify.hi-boot-5 @@ -0,0 +1,8 @@ +-- This boot file exists only to tie the knot between +-- TcUnify and TcSimplify + +__interface TcUnify 1 0 where +__export TcUnify unifyTauTy ; +1 unifyTauTy :: TcType.TcTauType -> TcType.TcTauType -> TcMonad.TcM () ; + + diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs new file mode 100644 index 0000000..4cdab86 --- /dev/null +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -0,0 +1,1122 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{Type subsumption and unification} + +\begin{code} +module TcUnify ( + -- Full-blown subsumption + tcSub, tcGen, subFunTy, + checkSigTyVars, sigCtxt, sigPatCtxt, + + -- Various unifications + unifyTauTy, unifyTauTyList, unifyTauTyLists, + unifyFunTy, unifyListTy, unifyTupleTy, + unifyKind, unifyKinds, unifyOpenTypeKind, + + -- Coercions + Coercion, ExprCoFn, PatCoFn, + (<$>), (<.>), mkCoercion, + idCoercion, isIdCoercion + + ) where + +#include "HsVersions.h" + + +import HsSyn ( HsExpr(..) ) +import TcHsSyn ( TypecheckedHsExpr, TcPat, + mkHsDictApp, mkHsTyApp, mkHsLet ) +import TypeRep ( Type(..), SourceType(..), + openKindCon, typeCon ) + +import TcMonad -- TcType, amongst others +import TcType ( TcKind, TcType, TcSigmaType, TcPhiType, TcTyVar, TcTauType, + TcTyVarSet, TcThetaType, + isTauTy, isSigmaTy, + tcSplitAppTy_maybe, tcSplitTyConApp_maybe, + tcGetTyVar_maybe, tcGetTyVar, + mkTyConApp, mkTyVarTys, mkFunTy, tyVarsOfType, mkRhoTy, + typeKind, tcSplitFunTy_maybe, mkForAllTys, + isHoleTyVar, isSkolemTyVar, isUserTyVar, allDistinctTyVars, + tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars, + eqKind, openTypeKind, liftedTypeKind, unliftedTypeKind, isTypeKind, + hasMoreBoxityInfo, tyVarBindingInfo + ) +import qualified Type ( getTyVar_maybe ) +import Inst ( LIE, emptyLIE, plusLIE, mkLIE, + newDicts, instToId + ) +import TcMType ( getTcTyVar, putTcTyVar, tcInstType, + newTyVarTy, newTyVarTys, newBoxityVar, newHoleTyVarTy, + zonkTcType, zonkTcTyVars, zonkTcTyVar ) +import TcSimplify ( tcSimplifyCheck ) +import TysWiredIn ( listTyCon, mkListTy, mkTupleTy ) +import TcEnv ( TcTyThing(..), tcExtendGlobalTyVars, tcGetGlobalTyVars, tcLEnvElts ) +import TyCon ( tyConArity, isTupleTyCon, tupleTyConBoxity ) +import PprType ( pprType ) +import CoreFVs ( idFreeTyVars ) +import Id ( mkSysLocal, idType ) +import Var ( Var, varName, tyVarKind ) +import VarSet ( elemVarSet, varSetElems ) +import VarEnv +import Name ( isSystemName, getSrcLoc ) +import ErrUtils ( Message ) +import BasicTypes ( Boxity, Arity, isBoxed ) +import Util ( isSingleton, equalLength ) +import Maybe ( isNothing ) +import Outputable +\end{code} + + +%************************************************************************ +%* * +\subsection{Subsumption} +%* * +%************************************************************************ + +\begin{code} +tcSub :: TcSigmaType -- expected_ty; can be a type scheme; + -- can be a "hole" type variable + -> TcSigmaType -- actual_ty; can be a type scheme + -> TcM (ExprCoFn, LIE) +\end{code} + +(tcSub expected_ty actual_ty) checks that + actual_ty <= expected_ty +That is, that a value of type actual_ty is acceptable in +a place expecting a value of type expected_ty. + +It returns a coercion function + co_fn :: actual_ty -> expected_ty +which takes an HsExpr of type actual_ty into one of type +expected_ty. + +\begin{code} +tcSub expected_ty actual_ty + = traceTc (text "tcSub" <+> details) `thenNF_Tc_` + tcAddErrCtxtM (unifyCtxt "type" expected_ty actual_ty) + (tc_sub expected_ty expected_ty actual_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 + -> TcSigmaType -- ..and after + -> TcM (ExprCoFn, LIE) + +----------------------------------- +-- Expand synonyms +tc_sub exp_sty (NoteTy _ exp_ty) act_sty act_ty = tc_sub exp_sty exp_ty act_sty act_ty +tc_sub exp_sty exp_ty act_sty (NoteTy _ act_ty) = tc_sub exp_sty exp_ty act_sty act_ty + +----------------------------------- +-- "Hole type variable" case +-- Do this case before unwrapping for-alls in the actual_ty + +tc_sub _ (TyVarTy tv) act_sty act_ty + | isHoleTyVar tv + = -- It's a "hole" type variable + getTcTyVar tv `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + + Just ty -> -- Already been assigned + tc_sub ty ty act_sty act_ty ; + + Nothing -> -- Assign it + putTcTyVar tv act_sty `thenNF_Tc_` + returnTc (idCoercion, emptyLIE) + + +----------------------------------- +-- Generalisation case +-- actual_ty: d:Eq b => b->b +-- expected_ty: forall a. Ord a => a->a +-- co_fn e /\a. \d2:Ord a. let d = eqFromOrd d2 in e + +-- It is essential to do this *before* the specialisation case +-- Example: f :: (Eq a => a->a) -> ... +-- g :: Ord b => b->b +-- Consider f g ! + +tc_sub exp_sty expected_ty act_sty actual_ty + | isSigmaTy expected_ty + = tcGen expected_ty ( + \ body_exp_ty -> tc_sub body_exp_ty body_exp_ty act_sty actual_ty + ) `thenTc` \ (gen_fn, co_fn, lie) -> + returnTc (gen_fn <.> co_fn, lie) + +----------------------------------- +-- Specialisation case: +-- actual_ty: forall a. Ord a => a->a +-- expected_ty: Int -> Int +-- co_fn e = e Int dOrdInt + +tc_sub exp_sty expected_ty act_sty actual_ty + | isSigmaTy actual_ty + = tcInstType actual_ty `thenNF_Tc` \ (tvs, theta, body_ty) -> + newDicts orig theta `thenNF_Tc` \ dicts -> + let + inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tvs)) + (map instToId dicts) + in + tc_sub exp_sty expected_ty body_ty body_ty `thenTc` \ (co_fn, lie) -> + returnTc (co_fn <.> mkCoercion inst_fn, lie `plusLIE` mkLIE dicts) + where + orig = Rank2Origin + +----------------------------------- +-- Function case + +tc_sub _ (FunTy exp_arg exp_res) _ (FunTy act_arg act_res) + = tcSub_fun exp_arg exp_res act_arg act_res + +----------------------------------- +-- Type variable meets function: imitate + +-- MARK: can we short-cut to an error case? +-- 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! + +tc_sub exp_sty exp_ty@(FunTy exp_arg exp_res) _ (TyVarTy tv) + = getTcTyVar tv `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty -> tc_sub exp_sty exp_ty ty ty + Nothing -> imitateFun tv `thenNF_Tc` \ (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) + = getTcTyVar tv `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty -> tc_sub ty ty act_sty act_ty + Nothing -> imitateFun tv `thenNF_Tc` \ (exp_arg, exp_res) -> + 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 `thenTc_` + returnTc (idCoercion, emptyLIE) +\end{code} + +%************************************************************************ +%* * +\subsection{Functions} +%* * +%************************************************************************ + +\begin{code} +tcSub_fun exp_arg exp_res act_arg act_res + = tcSub act_arg exp_arg `thenTc` \ (co_fn_arg, lie1) -> + tcSub exp_res act_res `thenTc` \ (co_fn_res, lie2) -> + tcGetUnique `thenNF_Tc` \ uniq -> + let + -- co_fn_arg :: HsExpr exp_arg -> HsExpr act_arg + -- co_fn_res :: HsExpr act_res -> HsExpr exp_res + -- co_fn :: HsExpr (act_arg -> act_res) -> HsExpr (exp_arg -> exp_res) + arg_id = mkSysLocal SLIT("sub") uniq exp_arg + coercion | isIdCoercion co_fn_arg, + isIdCoercion co_fn_res = idCoercion + | otherwise = mkCoercion co_fn + + co_fn e = DictLam [arg_id] + (co_fn_res <$> (HsApp e (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 + -- HsApp e $it :: HsExpr act_res + -- co_fn_res $it :: HsExpr exp_res + in + returnTc (coercion, lie1 `plusLIE` lie2) + +imitateFun :: TcTyVar -> NF_TcM (TcType, TcType) +imitateFun tv + = ASSERT( not (isHoleTyVar tv) ) + newTyVarTy openTypeKind `thenNF_Tc` \ arg -> + newTyVarTy openTypeKind `thenNF_Tc` \ res -> + -- NB: tv is an *ordinary* tyvar and so are the new ones + putTcTyVar tv (mkFunTy arg res) `thenNF_Tc_` + returnNF_Tc (arg,res) +\end{code} + + +%************************************************************************ +%* * +\subsection{Generalisation} +%* * +%************************************************************************ + +\begin{code} +tcGen :: TcSigmaType -- expected_ty + -> (TcPhiType -> TcM (result, LIE)) -- spec_ty + -> TcM (ExprCoFn, result, LIE) + -- The expression has type: spec_ty -> expected_ty + +tcGen expected_ty thing_inside -- We expect expected_ty to be a forall-type + -- If not, the call is a no-op + = tcInstType expected_ty `thenNF_Tc` \ (forall_tvs, theta, phi_ty) -> + + -- Type-check the arg and unify with poly type + thing_inside phi_ty `thenTc` \ (result, lie) -> + + -- Check that the "forall_tvs" havn't been constrained + -- The interesting bit here is that we must include the free variables + -- of the expected_ty. Here's an example: + -- runST (newVar True) + -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool)) + -- for (newVar True), with s fresh. Then we unify with the runST's arg type + -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool. + -- So now s' isn't unconstrained because it's linked to a. + -- Conclusion: include the free vars of the expected_ty in the + -- list of "free vars" for the signature check. + + tcExtendGlobalTyVars free_tvs $ + tcAddErrCtxtM (sigCtxt forall_tvs theta phi_ty) $ + + newDicts SignatureOrigin theta `thenNF_Tc` \ dicts -> + tcSimplifyCheck sig_msg forall_tvs dicts lie `thenTc` \ (free_lie, inst_binds) -> + checkSigTyVars forall_tvs free_tvs `thenTc` \ zonked_tvs -> + + 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 + returnTc (mkCoercion co_fn, result, free_lie) + where + free_tvs = tyVarsOfType expected_ty + sig_msg = ptext SLIT("When generalising the type of an expression") +\end{code} + + + +%************************************************************************ +%* * +\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} +%* * +%************************************************************************ + +The exported functions are all defined as versions of some +non-exported generic functions. + +Unify two @TauType@s. Dead straightforward. + +\begin{code} +unifyTauTy :: TcTauType -> TcTauType -> TcM () +unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred + = -- The unifier should only ever see tau-types + -- (no quantification whatsoever) + ASSERT2( isTauTy ty1, ppr ty1 ) + ASSERT2( isTauTy ty2, ppr ty2 ) + tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $ + uTys ty1 ty1 ty2 ty2 +\end{code} + +@unifyTauTyList@ unifies corresponding elements of two lists of +@TauType@s. It uses @uTys@ to do the real work. The lists should be +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 [] [] = returnTc () +unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_` + unifyTauTyLists tys1 tys2 +unifyTauTyLists ty1s ty2s = panic "Unify.unifyTauTyLists: mismatched type lists!" +\end{code} + +@unifyTauTyList@ takes a single list of @TauType@s and unifies them +all together. It is used, for example, when typechecking explicit +lists, when all the elts should be of the same type. + +\begin{code} +unifyTauTyList :: [TcTauType] -> TcM () +unifyTauTyList [] = returnTc () +unifyTauTyList [ty] = returnTc () +unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_` + unifyTauTyList tys +\end{code} + +%************************************************************************ +%* * +\subsection[Unify-uTys]{@uTys@: getting down to business} +%* * +%************************************************************************ + +@uTys@ is the heart of the unifier. Each arg happens twice, because +we want to report errors in terms of synomyms if poss. The first of +the pair is used in error messages only; it is always the same as the +second, except that if the first is a synonym then the second may be a +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 + -- ty1 is the *expected* type + + -> 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 + + -- Ignore usage annotations inside typechecker +uTys ps_ty1 (UsageTy _ ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 +uTys ps_ty1 ty1 ps_ty2 (UsageTy _ ty2) = uTys ps_ty1 ty1 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 + -- "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 + + -- Functions; just check the two parts +uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) + = uTys fun1 fun1 fun2 fun2 `thenTc_` uTys arg1 arg1 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 + + -- 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 + = case tcSplitAppTy_maybe ty2 of + Just (s2,t2) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 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) + = case tcSplitAppTy_maybe ty1 of + Just (s1,t1) -> uTys s1 s1 s2 s2 `thenTc_` uTys t1 t1 t2 t2 + Nothing -> unifyMisMatch ps_ty1 ps_ty2 + + -- Not expecting for-alls in unification + -- ... but the error message from the unifyMisMatch more informative + -- than a panic message! + + -- Anything else fails +uTys ps_ty1 ty1 ps_ty2 ty2 = unifyMisMatch ps_ty1 ps_ty2 +\end{code} + + +Notes on synonyms +~~~~~~~~~~~~~~~~~ +If you are tempted to make a short cut on synonyms, as in this +pseudocode... + +\begin{verbatim} +-- NO uTys (SynTy con1 args1 ty1) (SynTy con2 args2 ty2) +-- NO = if (con1 == con2) then +-- NO -- Good news! Same synonym constructors, so we can shortcut +-- NO -- by unifying their arguments and ignoring their expansions. +-- NO unifyTauTypeLists args1 args2 +-- NO else +-- NO -- Never mind. Just expand them and try again +-- NO uTys ty1 ty2 +\end{verbatim} + +then THINK AGAIN. Here is the whole story, as detected and reported +by Chris Okasaki \tr{}: +\begin{quotation} +Here's a test program that should detect the problem: + +\begin{verbatim} + type Bogus a = Int + x = (1 :: Bogus Char) :: Bogus Bool +\end{verbatim} + +The problem with [the attempted shortcut code] is that +\begin{verbatim} + con1 == con2 +\end{verbatim} +is not a sufficient condition to be able to use the shortcut! +You also need to know that the type synonym actually USES all +its arguments. For example, consider the following type synonym +which does not use all its arguments. +\begin{verbatim} + type Bogus a = Int +\end{verbatim} + +If you ever tried unifying, say, \tr{Bogus Char} with \tr{Bogus Bool}, +the unifier would blithely try to unify \tr{Char} with \tr{Bool} and +would fail, even though the expanded forms (both \tr{Int}) should +match. + +Similarly, unifying \tr{Bogus Char} with \tr{Bogus t} would +unnecessarily bind \tr{t} to \tr{Char}. + +... You could explicitly test for the problem synonyms and mark them +somehow as needing expansion, perhaps also issuing a warning to the +user. +\end{quotation} + + +%************************************************************************ +%* * +\subsection[Unify-uVar]{@uVar@: unifying with a type variable} +%* * +%************************************************************************ + +@uVar@ is called when at least one of the types being unified is a +variable. It does {\em not} assume that the variable is a fixed point +of the substitution; rather, notice that @uVar@ (defined below) nips +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 + -> TcTyVar + -> TcTauType -> TcTauType -- printing and real versions + -> TcM () + +uVar swapped tv1 ps_ty2 ty2 + = traceTc (text "uVar" <+> ppr swapped <+> ppr tv1 <+> (ppr ps_ty2 $$ ppr ty2)) `thenNF_Tc_` + getTcTyVar tv1 `thenNF_Tc` \ 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 + + -- 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) + + -- Same type variable => no-op + | tv1 == tv2 + = returnTc () + + -- Distinct type variables + -- ASSERT maybe_ty1 /= Just + | otherwise + = getTcTyVar tv2 `thenNF_Tc` \ 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) `thenNF_Tc_` + returnTc () + | otherwise + + -> WARN( not (k2 `hasMoreBoxityInfo` k1), (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) + putTcTyVar tv1 ps_ty2 `thenNF_Tc_` + returnTc () + 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 + + 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 + + -- 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 + checkTcM (not (isSkolemTyVar tv1)) + (failWithTcM (unifyWithSigErr tv1 ps_ty2)) `thenTc_` + + -- Check that the kinds match + zonkTcType ps_ty2 `thenNF_Tc` \ ps_ty2' -> + checkKinds swapped tv1 ps_ty2' `thenTc_` + + -- Occurs check + -- Basically we want to update tv1 := ps_ty2 + -- because ps_ty2 has type-synonym info, which improves later error messages + -- + -- But consider + -- type A a = () + -- + -- f :: (A a -> a -> ()) -> () + -- f = \ _ -> () + -- + -- x :: () + -- x = f (\ x p -> p x) + -- + -- In the application (p x), we try to match "t" with "A t". If we go + -- ahead and bind t to A t (= ps_ty2), we'll lead the type checker into + -- an infinite loop later. + -- But we should not reject the program, because A t = (). + -- Rather, we should bind t to () (= non_var_ty2). + -- + -- That's why we have this two-state occurs-check + if not (tv1 `elemVarSet` tyVarsOfType ps_ty2') then + putTcTyVar tv1 ps_ty2' `thenNF_Tc_` + returnTc () + else + zonkTcType non_var_ty2 `thenNF_Tc` \ non_var_ty2' -> + if not (tv1 `elemVarSet` tyVarsOfType non_var_ty2') then + -- This branch rarely succeeds, except in strange cases + -- like that in the example above + putTcTyVar tv1 non_var_ty2' `thenNF_Tc_` + returnTc () + else + failWithTcM (unifyOccurCheck tv1 ps_ty2') + + +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 + + | tk1 `eqKind` liftedTypeKind && tk2 `eqKind` unliftedTypeKind + -- Check that we don't unify a lifted type variable with an + -- unlifted type: e.g. (id 3#) is illegal + = tcAddErrCtxtM (unifyKindCtxt swapped tv1 ty2) $ + unifyMisMatch k1 k2 + + | otherwise + = -- Check that we aren't losing boxity info (shouldn't happen) + WARN (not (tk2 `hasMoreBoxityInfo` tk1), + (ppr tv1 <+> ppr tk1) $$ (ppr ty2 <+> ppr tk2)) + returnTc () + where + (k1,k2) | swapped = (tk2,tk1) + | otherwise = (tk1,tk2) + tk1 = tyVarKind tv1 + tk2 = typeKind ty2 +\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 :: TcSigmaType -- Fail if ty isn't a function type + -> TcM (TcType, TcType) -- otherwise return arg and result types +subFunTy ty@(TyVarTy tyvar) + + = getTcTyVar tyvar `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty -> subFunTy ty + Nothing | isHoleTyVar tyvar + -> newHoleTyVarTy `thenNF_Tc` \ arg -> + newHoleTyVarTy `thenNF_Tc` \ res -> + putTcTyVar tyvar (mkFunTy arg res) `thenNF_Tc_` + returnTc (arg,res) + | otherwise + -> unify_fun_ty_help ty + +subFunTy ty + = case tcSplitFunTy_maybe ty of + Just arg_and_res -> returnTc arg_and_res + Nothing -> unify_fun_ty_help ty + + +unifyFunTy :: TcPhiType -- Fail if ty isn't a function type + -> TcM (TcType, TcType) -- otherwise return arg and result types + +unifyFunTy ty@(TyVarTy tyvar) + = getTcTyVar tyvar `thenNF_Tc` \ 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 -> returnTc arg_and_res + Nothing -> unify_fun_ty_help ty + +unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification + = newTyVarTy openTypeKind `thenNF_Tc` \ arg -> + newTyVarTy openTypeKind `thenNF_Tc` \ res -> + unifyTauTy ty (mkFunTy arg res) `thenTc_` + returnTc (arg,res) +\end{code} + +\begin{code} +unifyListTy :: TcType -- expected list type + -> TcM TcType -- list element type + +unifyListTy ty@(TyVarTy tyvar) + = getTcTyVar tyvar `thenNF_Tc` \ 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 -> returnTc arg_ty + other -> unify_list_ty_help ty + +unify_list_ty_help ty -- Revert to ordinary unification + = newTyVarTy liftedTypeKind `thenNF_Tc` \ elt_ty -> + unifyTauTy ty (mkListTy elt_ty) `thenTc_` + returnTc elt_ty +\end{code} + +\begin{code} +unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType] +unifyTupleTy boxity arity ty@(TyVarTy tyvar) + = getTcTyVar tyvar `thenNF_Tc` \ 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 + -> returnTc arg_tys + other -> unify_tuple_ty_help boxity arity ty + +unify_tuple_ty_help boxity arity ty + = newTyVarTys arity kind `thenNF_Tc` \ arg_tys -> + unifyTauTy ty (mkTupleTy boxity arity arg_tys) `thenTc_` + returnTc arg_tys + where + kind | isBoxed boxity = liftedTypeKind + | otherwise = openTypeKind +\end{code} + + +%************************************************************************ +%* * +\subsection{Kind unification} +%* * +%************************************************************************ + +\begin{code} +unifyKind :: TcKind -- Expected + -> TcKind -- Actual + -> TcM () +unifyKind k1 k2 + = tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $ + uTys k1 k1 k2 k2 + +unifyKinds :: [TcKind] -> [TcKind] -> TcM () +unifyKinds [] [] = returnTc () +unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_` + 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 `thenNF_Tc` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyOpenTypeKind ty' + other -> unify_open_kind_help ty + +unifyOpenTypeKind ty + | isTypeKind ty = returnTc () + | otherwise = unify_open_kind_help ty + +unify_open_kind_help ty -- Revert to ordinary unification + = newBoxityVar `thenNF_Tc` \ boxity -> + unifyKind ty (mkTyConApp typeCon [boxity]) +\end{code} + + +%************************************************************************ +%* * +\subsection[Unify-context]{Errors and contexts} +%* * +%************************************************************************ + +Errors +~~~~~~ + +\begin{code} +unifyCtxt s ty1 ty2 tidy_env -- ty1 expected, ty2 inferred + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ ty2' -> + returnNF_Tc (err ty1' ty2') + where + err ty1 ty2 = (env1, + nest 4 + (vcat [ + text "Expected" <+> text s <> colon <+> ppr tidy_ty1, + text "Inferred" <+> text s <> colon <+> ppr tidy_ty2 + ])) + where + (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 `thenNF_Tc` \ ty2' -> + returnNF_Tc (err ty2') + 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' + +unifyMisMatch ty1 ty2 + = zonkTcType ty1 `thenNF_Tc` \ ty1' -> + zonkTcType ty2 `thenNF_Tc` \ 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)]) + 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))) + where + (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar + (env2, tidy_ty) = tidyOpenType env1 ty + +unifyOccurCheck tyvar ty + = (env2, hang (ptext SLIT("Occurs check: cannot construct the infinite type:")) + 4 (sep [ppr tidy_tyvar, char '=', ppr tidy_ty])) + where + (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar + (env2, tidy_ty) = tidyOpenType env1 ty +\end{code} + + + +%************************************************************************ +%* * +\subsection{Checking signature type variables} +%* * +%************************************************************************ + +@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] + + (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 + eg the signature for f in this: + + g x = ... where + f :: a->[a] + f y = [x,y] + + Here, f is forced to be monorphic by the free occurence of x. + + (d) Not (unified with another type variable that is) in scope. + eg f x :: (r->r) = (\y->y) :: forall a. a->r + when checking the expression type signature, we find that + even though there is nothing in scope whose type mentions r, + nevertheless the type signature for the expression isn't right. + + Another example is in a class or instance declaration: + class C a where + op :: forall b. a -> b + op x = x + Here, b gets unified with a + +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] -- Universally-quantified type variables in the signature + -> TcTyVarSet -- Tyvars that are free in the type signature + -- Not necessarily zonked + -- These should *already* be in the free-in-env set, + -- and are used here only to improve the error message + -> TcM [TcTyVar] -- Zonked signature type variables + +checkSigTyVars [] free = returnTc [] +checkSigTyVars sig_tyvars free_tyvars + = zonkTcTyVars sig_tyvars `thenNF_Tc` \ sig_tys -> + tcGetGlobalTyVars `thenNF_Tc` \ globals -> + + checkTcM (allDistinctTyVars sig_tys globals) + (complain sig_tys globals) `thenTc_` + + returnTc (map (tcGetTyVar "checkSigTyVars") sig_tys) + + where + complain sig_tys globals + = -- "check" checks each sig tyvar in turn + foldlNF_Tc check + (env2, emptyVarEnv, []) + (tidy_tvs `zip` tidy_tys) `thenNF_Tc` \ (env3, _, msgs) -> + + failWithTcM (env3, main_msg $$ vcat msgs) + where + (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tyvars + (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)! + returnNF_Tc (tidy_env, acc, unify_msg sig_tyvar (quotes (ppr ty)) : msgs) ; + + Just tv -> + + case lookupVarEnv acc tv of { + Just sig_tyvar' -> -- Error (b)! + returnNF_Tc (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: + -- a) get the local TcIds and TyVars from the environment, + -- and pass them to find_globals (they might have tv free) + -- b) similarly, find any free_tyvars that mention tv + then tcGetEnv `thenNF_Tc` \ ve -> + find_globals tv tidy_env (tcLEnvElts ve) `thenNF_Tc` \ (tidy_env1, globs) -> + find_frees tv tidy_env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (tidy_env2, frees) -> + returnNF_Tc (tidy_env2, acc, escape_msg sig_tyvar tv globs frees : msgs) + + else -- All OK + returnNF_Tc (tidy_env, extendVarEnv acc tv sig_tyvar, msgs) + }} + +----------------------- +-- find_globals looks at the value environment and finds values +-- whose types mention the offending type variable. It has to be +-- careful to zonk the Id's type first, so it has to be in the monad. +-- We must be careful to pass it a zonked type variable, too. + +find_globals :: Var + -> TidyEnv + -> [TcTyThing] + -> NF_TcM (TidyEnv, [SDoc]) + +find_globals tv tidy_env things + = go tidy_env [] things + where + go tidy_env acc [] = returnNF_Tc (tidy_env, acc) + go tidy_env acc (thing : things) + = find_thing ignore_it tidy_env thing `thenNF_Tc` \ (tidy_env1, maybe_doc) -> + case maybe_doc of + Just d -> go tidy_env1 (d:acc) things + Nothing -> go tidy_env1 acc things + + ignore_it ty = not (tv `elemVarSet` tyVarsOfType ty) + +----------------------- +find_thing ignore_it tidy_env (ATcId id) + = zonkTcType (idType id) `thenNF_Tc` \ id_ty -> + if ignore_it id_ty then + returnNF_Tc (tidy_env, Nothing) + else let + (tidy_env', tidy_ty) = tidyOpenType tidy_env id_ty + msg = sep [ppr id <+> dcolon <+> ppr tidy_ty, + nest 2 (parens (ptext SLIT("bound at") <+> + ppr (getSrcLoc id)))] + in + returnNF_Tc (tidy_env', Just msg) + +find_thing ignore_it tidy_env (ATyVar tv) + = zonkTcTyVar tv `thenNF_Tc` \ tv_ty -> + if ignore_it tv_ty then + returnNF_Tc (tidy_env, Nothing) + else let + (tidy_env1, tv1) = tidyOpenTyVar tidy_env tv + (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty + msg = sep [ptext SLIT("Type variable") <+> quotes (ppr tv1) <+> eq_stuff, nest 2 bound_at] + + eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty, tv == tv' = empty + | otherwise = equals <+> ppr tv_ty + -- It's ok to use Type.getTyVar_maybe because ty is zonked by now + + bound_at = tyVarBindingInfo tv + in + returnNF_Tc (tidy_env2, Just msg) + +----------------------- +find_frees tv tidy_env acc [] + = returnNF_Tc (tidy_env, acc) +find_frees tv tidy_env acc (ftv:ftvs) + = zonkTcTyVar ftv `thenNF_Tc` \ ty -> + if tv `elemVarSet` tyVarsOfType ty then + let + (tidy_env', ftv') = tidyOpenTyVar tidy_env ftv + in + find_frees tv tidy_env' (ftv':acc) ftvs + else + find_frees tv tidy_env acc ftvs + + +escape_msg sig_tv tv globs frees + = mk_msg sig_tv <+> ptext SLIT("escapes") $$ + if not (null globs) then + vcat [pp_it <+> ptext SLIT("is mentioned in the environment:"), + nest 2 (vcat globs)] + else if not (null frees) then + vcat [ptext SLIT("It is reachable from the type variable(s)") <+> pprQuotedList frees, + nest 2 (ptext SLIT("which") <+> is_are <+> ptext SLIT("free in the signature")) + ] + else + empty -- Sigh. It's really hard to give a good error message + -- all the time. One bad case is an existential pattern match + where + is_are | isSingleton frees = ptext SLIT("is") + | otherwise = ptext SLIT("are") + pp_it | sig_tv /= tv = ptext SLIT("It unifies with") <+> quotes (ppr tv) <> comma <+> ptext SLIT("which") + | otherwise = ptext SLIT("It") + + vcat_first :: Int -> [SDoc] -> SDoc + vcat_first n [] = empty + vcat_first 0 (x:xs) = text "...others omitted..." + vcat_first n (x:xs) = x $$ vcat_first (n-1) xs + + +unify_msg tv thing = mk_msg tv <+> ptext SLIT("is unified with") <+> thing +mk_msg tv = ptext SLIT("Quantified type variable") <+> quotes (ppr tv) +\end{code} + +These two context are used with checkSigTyVars + +\begin{code} +sigCtxt :: [TcTyVar] -> TcThetaType -> TcTauType + -> TidyEnv -> NF_TcM (TidyEnv, Message) +sigCtxt sig_tyvars sig_theta sig_tau tidy_env + = zonkTcType sig_tau `thenNF_Tc` \ actual_tau -> + let + (env1, tidy_sig_tyvars) = tidyOpenTyVars tidy_env sig_tyvars + (env2, tidy_sig_rho) = tidyOpenType env1 (mkRhoTy sig_theta sig_tau) + (env3, tidy_actual_tau) = tidyOpenType env2 actual_tau + msg = vcat [ptext SLIT("Signature type: ") <+> pprType (mkForAllTys tidy_sig_tyvars tidy_sig_rho), + ptext SLIT("Type to generalise:") <+> pprType tidy_actual_tau + ] + in + returnNF_Tc (env3, msg) + +sigPatCtxt bound_tvs bound_ids tidy_env + = returnNF_Tc (env1, + sep [ptext SLIT("When checking a pattern that binds"), + nest 4 (vcat (zipWith ppr_id show_ids tidy_tys))]) + where + show_ids = filter is_interesting bound_ids + is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs + + (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids) + ppr_id id ty = ppr id <+> dcolon <+> ppr ty + -- Don't zonk the types so we get the separate, un-unified versions +\end{code} + +