X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcUnify.lhs;h=c13cff66fae6e871c7629c506004889d41c1ee5e;hb=c8898df0380dad4705353de00a48ea105d00bcc5;hp=e4116e2ff769e247a8f1b2ac4ecf462fbffc59e2;hpb=9eb59090515da91f12fad9415800ae7059a08811;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index e4116e2..c13cff6 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -6,18 +6,22 @@ \begin{code} module TcUnify ( -- Full-blown subsumption - tcSubOff, tcSubExp, tcGen, subFunTy, TcHoleType, + tcSubOff, tcSubExp, tcGen, checkSigTyVars, checkSigTyVarsWrt, sigCtxt, findGlobals, -- Various unifications unifyTauTy, unifyTauTyList, unifyTauTyLists, - unifyFunTy, unifyListTy, unifyPArrTy, unifyTupleTy, - unifyKind, unifyKinds, unifyOpenTypeKind, unifyFunKind, - - -- Coercions - Coercion, ExprCoFn, PatCoFn, - (<$>), (<.>), mkCoercion, - idCoercion, isIdCoercion + unifyKind, unifyKinds, unifyFunKind, + checkExpectedKind, + + -------------------------------- + -- Holes + Expected(..), newHole, readExpectedType, + zapExpectedType, zapExpectedTo, zapExpectedBranches, + subFunTys, unifyFunTy, + zapToListTy, unifyListTy, + zapToPArrTy, unifyPArrTy, + zapToTupleTy, unifyTupleTy ) where @@ -25,41 +29,43 @@ module TcUnify ( import HsSyn ( HsExpr(..) ) -import TcHsSyn ( TypecheckedHsExpr, TcPat, mkHsLet ) -import TypeRep ( Type(..), SourceType(..), TyNote(..), openKindCon ) +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, + isTauTy, isSigmaTy, mkFunTys, mkTyConApp, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, tcGetTyVar_maybe, tcGetTyVar, - mkTyConApp, mkFunTy, tyVarsOfType, mkPhiTy, + mkFunTy, tyVarsOfType, mkPhiTy, typeKind, tcSplitFunTy_maybe, mkForAllTys, - isHoleTyVar, isSkolemTyVar, isUserTyVar, + isSkolemTyVar, isUserTyVar, tidyOpenType, tidyOpenTypes, tidyOpenTyVar, tidyOpenTyVars, - eqKind, openTypeKind, liftedTypeKind, isTypeKind, mkArrowKind, - hasMoreBoxityInfo, allDistinctTyVars - ) -import qualified Type ( getTyVar_maybe ) + allDistinctTyVars, pprType ) +import Kind ( Kind(..), SimpleKind, KindVar, isArgTypeKind, + openTypeKind, liftedTypeKind, mkArrowKind, + 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 ( getTcTyVar, putTcTyVar, tcInstType, newKindVar, + newTyVarTy, newTyVarTys, zonkTcKind, + zonkTcType, zonkTcTyVars, 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 TysWiredIn ( listTyCon, parrTyCon, tupleTyCon ) +import TcEnv ( tcGetGlobalTyVars, findGlobals ) +import TyCon ( TyCon, tyConArity, isTupleTyCon, tupleTyConBoxity ) +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 ) import ErrUtils ( Message ) +import SrcLoc ( noLoc ) import BasicTypes ( Boxity, Arity, isBoxed ) -import Util ( equalLength, notNull ) -import Maybe ( isNothing ) +import Util ( equalLength, lengthExceeds, notNull ) import Outputable \end{code} @@ -69,6 +75,207 @@ Notes on holes %************************************************************************ %* * +\subsection{'hole' type variables} +%* * +%************************************************************************ + +\begin{code} +data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference + | Check ty -- The type to check during type checking + +newHole :: TcM (TcRef ty) +newHole = newMutVar (error "Empty hole in typechecker") + +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 <- newTyVarTy kind ; + writeMutVar hole ty ; + return ty } + +zapExpectedType (Check ty) kind + | typeKind ty `isSubKind` kind = return ty + | otherwise = do { ty1 <- newTyVarTy 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 + +zapExpectedTo :: Expected TcType -> TcTauType -> TcM () +zapExpectedTo (Infer hole) ty2 = writeMutVar hole ty2 +zapExpectedTo (Check ty1) ty2 = unifyTauTy ty1 ty2 + +zapExpectedBranches :: [a] -> Expected TcType -> TcM (Expected TcType) +-- Zap the expected type to a monotype if there is more than one branch +zapExpectedBranches branches exp_ty + | lengthExceeds branches 1 = zapExpectedType exp_ty openTypeKind `thenM` \ exp_ty' -> + return (Check exp_ty') + | otherwise = returnM exp_ty + +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 :: [pat] + -> Expected TcRhoType -- Fail if ty isn't a function type + -> ([(pat, Expected TcRhoType)] -> Expected TcRhoType -> TcM a) + -> TcM a + +subFunTys pats (Infer hole) thing_inside + = -- This is the interesting case + mapM new_pat_hole pats `thenM` \ pats_w_holes -> + newHole `thenM` \ res_hole -> + + -- Do the business + thing_inside pats_w_holes (Infer res_hole) `thenM` \ answer -> + + -- Extract the answers + mapM read_pat_hole pats_w_holes `thenM` \ arg_tys -> + readMutVar res_hole `thenM` \ res_ty -> + + -- Write the answer into the incoming hole + writeMutVar hole (mkFunTys arg_tys res_ty) `thenM_` + + -- And return the answer + returnM answer + where + new_pat_hole pat = newHole `thenM` \ hole -> return (pat, Infer hole) + read_pat_hole (pat, Infer hole) = readMutVar hole + +subFunTys pats (Check ty) thing_inside + = go pats ty `thenM` \ (pats_w_tys, res_ty) -> + thing_inside pats_w_tys res_ty + where + go [] ty = return ([], Check ty) + go (pat:pats) ty = unifyFunTy ty `thenM` \ (arg,res) -> + go pats res `thenM` \ (pats_w_tys, final_res) -> + return ((pat, Check arg) : pats_w_tys, final_res) + +unifyFunTy :: TcRhoType -- Fail if ty isn't a function type + -> TcM (TcType, TcType) -- otherwise return arg and result types + +unifyFunTy ty@(TyVarTy tyvar) + = getTcTyVar tyvar `thenM` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyFunTy ty' + Nothing -> unify_fun_ty_help ty + +unifyFunTy ty + = case tcSplitFunTy_maybe ty of + Just arg_and_res -> returnM arg_and_res + Nothing -> unify_fun_ty_help ty + +unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification + = newTyVarTy argTypeKind `thenM` \ arg -> + newTyVarTy openTypeKind `thenM` \ res -> + unifyTauTy ty (mkFunTy arg res) `thenM_` + returnM (arg,res) +\end{code} + +\begin{code} +---------------------- +zapToListTy, zapToPArrTy :: Expected TcType -- expected list type + -> TcM TcType -- list element type +unifyListTy, unifyPArrTy :: TcType -> TcM TcType +zapToListTy = zapToXTy listTyCon +unifyListTy = unifyXTy listTyCon +zapToPArrTy = zapToXTy parrTyCon +unifyPArrTy = unifyXTy parrTyCon + +---------------------- +zapToXTy :: TyCon -- T :: *->* + -> Expected TcType -- Expected type (T a) + -> TcM TcType -- Element type, a + +zapToXTy tc (Check ty) = unifyXTy tc ty +zapToXTy tc (Infer hole) = do { elt_ty <- newTyVarTy liftedTypeKind ; + writeMutVar hole (mkTyConApp tc [elt_ty]) ; + return elt_ty } + +---------------------- +unifyXTy :: TyCon -> TcType -> TcM TcType +unifyXTy tc ty@(TyVarTy tyvar) + = getTcTyVar tyvar `thenM` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyXTy tc ty' + other -> unify_x_ty_help tc ty + +unifyXTy tc ty + = case tcSplitTyConApp_maybe ty of + Just (tycon, [arg_ty]) | tycon == tc -> returnM arg_ty + other -> unify_x_ty_help tc ty + +unify_x_ty_help tc ty -- Revert to ordinary unification + = newTyVarTy liftedTypeKind `thenM` \ elt_ty -> + unifyTauTy ty (mkTyConApp tc [elt_ty]) `thenM_` + returnM elt_ty +\end{code} + +\begin{code} +---------------------- +zapToTupleTy :: Boxity -> Arity -> Expected TcType -> TcM [TcType] +zapToTupleTy boxity arity (Check ty) = unifyTupleTy boxity arity ty +zapToTupleTy boxity arity (Infer hole) = do { (tup_ty, arg_tys) <- new_tuple_ty boxity arity ; + writeMutVar hole tup_ty ; + return arg_tys } + +unifyTupleTy boxity arity ty@(TyVarTy tyvar) + = getTcTyVar tyvar `thenM` \ maybe_ty -> + case maybe_ty of + Just ty' -> unifyTupleTy boxity arity ty' + other -> unify_tuple_ty_help boxity arity ty + +unifyTupleTy boxity arity ty + = case tcSplitTyConApp_maybe ty of + Just (tycon, arg_tys) + | isTupleTyCon tycon + && tyConArity tycon == arity + && tupleTyConBoxity tycon == boxity + -> returnM arg_tys + other -> unify_tuple_ty_help boxity arity ty + +unify_tuple_ty_help boxity arity ty + = new_tuple_ty boxity arity `thenM` \ (tup_ty, arg_tys) -> + unifyTauTy ty tup_ty `thenM_` + returnM arg_tys + +new_tuple_ty boxity arity + = newTyVarTys arity kind `thenM` \ arg_tys -> + return (mkTyConApp tup_tc arg_tys, arg_tys) + where + tup_tc = tupleTyCon boxity arity + kind | isBoxed boxity = liftedTypeKind + | otherwise = argTypeKind -- Components of an unboxed tuple + -- can be unboxed, but not unboxed tuples +\end{code} + + +%************************************************************************ +%* * \subsection{Subsumption} %* * %************************************************************************ @@ -88,12 +295,8 @@ 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 :: TcHoleType -> TcSigmaType -> TcM ExprCoFn -tcSubOff :: TcSigmaType -> TcHoleType -> TcM ExprCoFn -tcSub :: TcSigmaType -> TcSigmaType -> TcM ExprCoFn +tcSubExp :: Expected TcRhoType -> TcRhoType -> TcM ExprCoFn +tcSubOff :: TcSigmaType -> Expected TcSigmaType -> TcM ExprCoFn \end{code} These two check for holes @@ -112,22 +315,17 @@ tcSubOff expected_ty offered_ty -- 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 (Infer hole) other_ty thing_inside + = do { writeMutVar hole other_ty; return idCoercion } -checkHole ty other_ty thing_inside +checkHole (Check ty) other_ty thing_inside = thing_inside ty other_ty \end{code} No holes expected now. Add some error-check context info. \begin{code} +tcSub :: TcSigmaType -> TcSigmaType -> TcM ExprCoFn -- Locally used only tcSub expected_ty actual_ty = traceTc (text "tcSub" <+> details) `thenM_` addErrCtxtM (unifyCtxt "type" expected_ty actual_ty) @@ -181,7 +379,7 @@ tc_sub exp_sty expected_ty act_sty actual_ty | isSigmaTy actual_ty = tcInstCall Rank2Origin 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 @@ -216,16 +414,14 @@ 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 -> + = 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 -> + = 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) -> @@ -260,7 +456,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 @@ -271,8 +467,7 @@ tcSub_fun exp_arg exp_res act_arg act_res 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 + = -- 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 @@ -280,7 +475,7 @@ imitateFun tv ty checkM (not (isSkolemTyVar tv)) (failWithTcM (unifyWithSigErr tv ty)) `thenM_` - newTyVarTy openTypeKind `thenM` \ arg -> + newTyVarTy argTypeKind `thenM` \ arg -> newTyVarTy openTypeKind `thenM` \ res -> putTcTyVar tv (mkFunTy arg res) `thenM_` returnM (arg,res) @@ -341,7 +536,7 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- 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)) + co_fn e = TyLam zonked_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e))) in returnM (mkCoercion co_fn, result) where @@ -353,39 +548,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} %* * %************************************************************************ @@ -464,28 +626,24 @@ 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)) +uTys _ (PredTy (IParam n1 t1)) _ (PredTy (IParam n2 t2)) | n1 == n2 = uTys t1 t1 t2 t2 -uTys _ (SourceTy (ClassP c1 tys1)) _ (SourceTy (ClassP c2 tys2)) +uTys _ (PredTy (ClassP c1 tys1)) _ (PredTy (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 `thenM_` uTys arg1 arg1 arg2 arg2 - -- Type constructors must match + -- NewType constructors must match +uTys _ (NewTcApp tc1 tys1) _ (NewTcApp tc2 tys2) + | tc1 == tc2 = unifyTauTyLists tys1 tys2 + + -- Ordinary 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, @@ -587,42 +745,46 @@ uVar swapped tv1 ps_ty2 ty2 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 + other -> uUnboundVar swapped tv1 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 +uUnboundVar swapped tv1 ps_ty2 (NoteTy n2 ty2) + = uUnboundVar swapped tv1 ps_ty2 ty2 -- The both-type-variable case -uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) +uUnboundVar swapped tv1 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' + Just ty2' -> uUnboundVar swapped tv1 ty2' ty2' Nothing | update_tv2 + -- It should always be the case that either k1 <: k2 or k2 <: k1 + -- Reason: a type variable never gets the kinds (#) or # - -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) + -> ASSERT2( k1 `isSubKind` 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) ) + | otherwise + -> ASSERT2( k2 `isSubKind` k1, (ppr tv2 <+> ppr k2) $$ (ppr tv1 <+> ppr k1) ) putTcTyVar tv1 ps_ty2 `thenM_` returnM () 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 = isUserTyVar tv1 -- Don't unify a signature type variable if poss @@ -630,7 +792,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy 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 +uUnboundVar swapped tv1 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_` @@ -653,7 +815,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 +823,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) @@ -725,8 +887,9 @@ okToUnifyWith tv ty ok (AppTy t1 t2) = ok t1 `and` ok t2 ok (FunTy t1 t2) = ok t1 `and` ok t2 ok (TyConApp _ ts) = oks ts + ok (NewTcApp _ 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 +899,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 +1049,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,19 +1058,18 @@ 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 types") <+> + 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' -> @@ -984,22 +1077,23 @@ unifyMisMatch ty1 ty2 let (env, [tidy_ty1, tidy_ty2]) = tidyOpenTypes emptyTidyEnv [ty1',ty2'] msg = hang (ptext SLIT("Couldn't match")) - 4 (sep [quotes (ppr tidy_ty1), + 2 (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))) + 2 (ptext SLIT("with the type") <+> quotes (ppr tidy_ty))) where (env1, tidy_tyvar) = tidyOpenTyVar emptyTidyEnv tyvar (env2, tidy_ty) = tidyOpenType env1 ty 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 +1104,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} %************************************************************************ %* * @@ -1114,7 +1266,7 @@ check_sig_tyvars extra_tvs sig_tvs (env2, emptyVarEnv, []) (tidy_tvs `zip` tidy_tys) `thenM` \ (env3, _, msgs) -> - failWithTcM (env3, main_msg $$ nest 4 (vcat msgs)) + failWithTcM (env3, main_msg $$ nest 2 (vcat msgs)) where (env1, tidy_tvs) = tidyOpenTyVars emptyTidyEnv sig_tvs (env2, tidy_tys) = tidyOpenTypes env1 sig_tys @@ -1189,7 +1341,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}