X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=8a014bca6f6db9f0b2a27c4b7b6ab225daf52833;hb=e5a8d57c85d42007c8cc561e6d6b805c23603fc0;hp=f8630280bee2022a98b5870291741eaf176de9b0;hpb=5d5b74b914bc893a395c2fa60b399fc4975b0720;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index f863028..8a014bc 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -7,7 +7,7 @@ The @Inst@ type: dictionaries or method instances \begin{code} module Inst ( - Inst, + Inst, pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages @@ -15,6 +15,7 @@ module Inst ( tidyInsts, tidyMoreInsts, newDictBndr, newDictBndrs, newDictBndrsO, + newDictOccs, newDictOcc, instCall, instStupidTheta, cloneDict, mkOverLit, newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy, @@ -23,7 +24,7 @@ module Inst ( tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, - getDictClassTys, dictPred, + growInstsTyVars, getDictClassTys, dictPred, lookupSimpleInst, LookupInstResult(..), tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, @@ -39,12 +40,11 @@ module Inst ( InstOrigin(..), InstLoc, pprInstLoc, - mkWantedCo, mkGivenCo, - fromWantedCo, fromGivenCo, - eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst, - finalizeEqInst, writeWantedCoercion, - eqInstType, updateEqInstCoercion, - eqInstCoercion, eqInstTys + mkWantedCo, mkGivenCo, isWantedCo, eqInstCoType, mkIdEqInstCo, + mkSymEqInstCo, mkLeftTransEqInstCo, mkRightTransEqInstCo, mkAppEqInstCo, + wantedEqInstIsUnsolved, eitherEqInst, mkEqInst, mkWantedEqInst, + wantedToLocalEqInst, finalizeEqInst, eqInstType, eqInstCoercion, + eqInstTys ) where #include "HsVersions.h" @@ -92,6 +92,7 @@ import Control.Monad \end{code} + Selection ~~~~~~~~~ \begin{code} @@ -116,8 +117,11 @@ instToVar (Dict {tci_name = nm, tci_pred = pred}) instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds}) = mkLocalId nm (mkImplicTy tvs givens wanteds) -instToVar i@(EqInst {}) - = eitherEqInst i id (\(TyVarTy covar) -> covar) +instToVar inst@(EqInst {}) + = eitherEqInst inst id assertCoVar + where + assertCoVar (TyVarTy cotv) = cotv + assertCoVar coty = pprPanic "Inst.instToVar" (ppr coty) instType :: Inst -> Type instType (LitInst {tci_ty = ty}) = ty @@ -148,6 +152,7 @@ getDictClassTys :: Inst -> (Class, [Type]) getDictClassTys (Dict {tci_pred = pred}) = getClassPredTys pred getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst) +-------------------------------- -- fdPredsOfInst is used to get predicates that contain functional -- dependencies *or* might do so. The "might do" part is because -- a constraint (C a b) might have a superclass with FDs @@ -157,14 +162,16 @@ getDictClassTys inst = pprPanic "getDictClassTys" (ppr inst) fdPredsOfInst :: Inst -> [TcPredType] fdPredsOfInst (Dict {tci_pred = pred}) = [pred] fdPredsOfInst (Method {tci_theta = theta}) = theta -fdPredsOfInst (ImplicInst {tci_given = gs, - tci_wanted = ws}) = fdPredsOfInsts (gs ++ ws) +fdPredsOfInst (ImplicInst {tci_wanted = ws}) = fdPredsOfInsts ws + -- The ImplicInst case doesn't look right; + -- what if ws mentions skolem variables? fdPredsOfInst (LitInst {}) = [] fdPredsOfInst (EqInst {}) = [] fdPredsOfInsts :: [Inst] -> [PredType] fdPredsOfInsts insts = concatMap fdPredsOfInst insts +--------------------------------- isInheritableInst :: Inst -> Bool isInheritableInst (Dict {tci_pred = pred}) = isInheritablePred pred isInheritableInst (Method {tci_theta = theta}) = all isInheritablePred theta @@ -212,8 +219,45 @@ addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs \end{code} -Predicates -~~~~~~~~~~ +Note [Growing the tau-tvs using constraints] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(growInstsTyVars insts tvs) is the result of extending the set + of tyvars tvs using all conceivable links from pred + +E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e} +Then grow precs tvs = {a,b,c} + +All the type variables from an implicit parameter are added, whether or +not they are mentioned in tvs; see Note [Implicit parameters and ambiguity] +in TcSimplify. + +See also Note [Ambiguity] in TcSimplify + +\begin{code} +growInstsTyVars :: [Inst] -> TyVarSet -> TyVarSet +growInstsTyVars insts tvs + | null insts = tvs + | otherwise = fixVarSet mk_next tvs + where + mk_next tvs = foldr grow_inst_tvs tvs insts + +grow_inst_tvs :: Inst -> TyVarSet -> TyVarSet +grow_inst_tvs (Dict {tci_pred = pred}) tvs = growPredTyVars pred tvs +grow_inst_tvs (Method {tci_theta = theta}) tvs = foldr growPredTyVars tvs theta +grow_inst_tvs (ImplicInst {tci_tyvars = tvs1, tci_wanted = ws}) tvs + = tvs `unionVarSet` (foldr grow_inst_tvs (tvs `delVarSetList` tvs1) ws + `delVarSetList` tvs1) +grow_inst_tvs inst tvs -- EqInst, LitInst + = growTyVars (tyVarsOfInst inst) tvs +\end{code} + + +%************************************************************************ +%* * + Predicates +%* * +%************************************************************************ + \begin{code} isAbstractableInst :: Inst -> Bool @@ -278,16 +322,41 @@ newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst] newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta newDictBndr :: InstLoc -> TcPredType -> TcM Inst +-- Makes a "given" newDictBndr inst_loc pred@(EqPred ty1 ty2) = do { uniq <- newUnique ; let name = mkPredName uniq inst_loc pred + co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred)) ; return (EqInst {tci_name = name, tci_loc = inst_loc, tci_left = ty1, tci_right = ty2, - tci_co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred))}) - } -newDictBndr inst_loc pred + tci_co = co }) } + +newDictBndr inst_loc pred = newDict inst_loc pred + +------------------- +newDictOccs :: InstLoc -> TcThetaType -> TcM [Inst] +newDictOccs inst_loc theta = mapM (newDictOcc inst_loc) theta + +newDictOcc :: InstLoc -> TcPredType -> TcM Inst +-- Makes a "wanted" +newDictOcc inst_loc pred@(EqPred ty1 ty2) + = do { uniq <- newUnique + ; cotv <- newMetaCoVar ty1 ty2 + ; let name = mkPredName uniq inst_loc pred + ; return (EqInst {tci_name = name, + tci_loc = inst_loc, + tci_left = ty1, + tci_right = ty2, + tci_co = Left cotv }) } + +newDictOcc inst_loc pred = newDict inst_loc pred + +---------------- +newDict :: InstLoc -> TcPredType -> TcM Inst +-- Always makes a Dict, not an EqInst +newDict inst_loc pred = do { uniq <- newUnique ; let name = mkPredName uniq inst_loc pred ; return (Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc}) } @@ -334,15 +403,12 @@ instCallDicts _ [] = return idHsWrapper instCallDicts loc (EqPred ty1 ty2 : preds) = do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2)) ; coi <- boxyUnify ty1 ty2 --- ; coi <- unifyType ty1 ty2 ; let co = fromCoI coi ty1 ; co_fn <- instCallDicts loc preds ; return (co_fn <.> WpTyApp co) } instCallDicts loc (pred : preds) - = do { uniq <- newUnique - ; let name = mkPredName uniq loc pred - dict = Dict {tci_name = name, tci_pred = pred, tci_loc = loc} + = do { dict <- newDict loc pred ; extendLIE dict ; co_fn <- instCallDicts loc preds ; return (co_fn <.> WpApp (instToId dict)) } @@ -350,8 +416,8 @@ instCallDicts loc (pred : preds) ------------- cloneDict :: Inst -> TcM Inst cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique - ; return (dict {tci_name = setNameUnique nm uniq}) } -cloneDict eq@(EqInst {}) = return eq + ; return (dict {tci_name = setNameUnique nm uniq}) } +cloneDict eq@(EqInst {}) = return eq cloneDict other = pprPanic "cloneDict" (ppr other) -- For vanilla implicit parameters, there is only one in scope @@ -360,15 +426,10 @@ cloneDict other = pprPanic "cloneDict" (ppr other) -- scope, so we make up a new namea. newIPDict :: InstOrigin -> IPName Name -> Type -> TcM (IPName Id, Inst) -newIPDict orig ip_name ty = do - inst_loc <- getInstLoc orig - uniq <- newUnique - let - pred = IParam ip_name ty - name = mkPredName uniq inst_loc pred - dict = Dict {tci_name = name, tci_pred = pred, tci_loc = inst_loc} - - return (mapIPName (\_ -> instToId dict) ip_name, dict) +newIPDict orig ip_name ty + = do { inst_loc <- getInstLoc orig + ; dict <- newDict inst_loc (IParam ip_name ty) + ; return (mapIPName (\_ -> instToId dict) ip_name, dict) } \end{code} @@ -493,7 +554,7 @@ Zonking makes sure that the instance types are fully zonked. \begin{code} zonkInst :: Inst -> TcM Inst -zonkInst dict@(Dict { tci_pred = pred}) = do +zonkInst dict@(Dict {tci_pred = pred}) = do new_pred <- zonkTcPredType pred return (dict {tci_pred = new_pred}) @@ -524,7 +585,7 @@ zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2}) (\co -> liftM mkGivenCo $ zonkTcType co) ; ty1' <- zonkTcType ty1 ; ty2' <- zonkTcType ty2 - ; return (eqinst {tci_co = co', tci_left= ty1', tci_right = ty2' }) + ; return (eqinst {tci_co = co', tci_left = ty1', tci_right = ty2' }) } zonkInsts :: [Inst] -> TcRn [Inst] @@ -838,7 +899,8 @@ record_dfun_usage :: Id -> TcRn () record_dfun_usage dfun_id = do { hsc_env <- getTopEnv ; let dfun_name = idName dfun_id - dfun_mod = nameModule dfun_name + dfun_mod = ASSERT( isExternalName dfun_name ) + nameModule dfun_name ; if isInternalName dfun_name || -- Internal name => defined in this module modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env) then return () -- internal, or in another package @@ -935,20 +997,96 @@ syntaxNameCtxt name orig ty tidy_env = do %* * %************************************************************************ +Operations on EqInstCo. + \begin{code} -mkGivenCo :: Coercion -> Either TcTyVar Coercion +mkGivenCo :: Coercion -> EqInstCo mkGivenCo = Right -mkWantedCo :: TcTyVar -> Either TcTyVar Coercion +mkWantedCo :: TcTyVar -> EqInstCo mkWantedCo = Left -fromGivenCo :: Either TcTyVar Coercion -> Coercion -fromGivenCo (Right co) = co -fromGivenCo _ = panic "fromGivenCo: not a wanted coercion" +isWantedCo :: EqInstCo -> Bool +isWantedCo (Left _) = True +isWantedCo _ = False + +eqInstCoType :: EqInstCo -> TcType +eqInstCoType (Left cotv) = mkTyVarTy cotv +eqInstCoType (Right co) = co +\end{code} + +Coercion transformations on EqInstCo. These transformations work differently +depending on whether a EqInstCo is for a wanted or local equality: + + Local : apply the inverse of the specified coercion + Wanted: obtain a fresh coercion hole (meta tyvar) and update the old hole + to be the specified coercion applied to the new coercion hole + +\begin{code} +-- Coercion transformation: co = id +-- +mkIdEqInstCo :: EqInstCo -> Type -> TcM () +mkIdEqInstCo (Left cotv) t + = writeMetaTyVar cotv t +mkIdEqInstCo (Right _) _ + = return () + +-- Coercion transformation: co = sym co' +-- +mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo +mkSymEqInstCo (Left cotv) (ty1, ty2) + = do { cotv' <- newMetaCoVar ty1 ty2 + ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv')) + ; return $ Left cotv' + } +mkSymEqInstCo (Right co) _ + = return $ Right (mkSymCoercion co) + +-- Coercion transformation: co = co' |> given_co +-- +mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo +mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2) + = do { cotv' <- newMetaCoVar ty1 ty2 + ; writeMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co) + ; return $ Left cotv' + } +mkLeftTransEqInstCo (Right co) given_co _ + = return $ Right (co `mkTransCoercion` mkSymCoercion given_co) + +-- Coercion transformation: co = given_co |> co' +-- +mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo +mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2) + = do { cotv' <- newMetaCoVar ty1 ty2 + ; writeMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv') + ; return $ Left cotv' + } +mkRightTransEqInstCo (Right co) given_co _ + = return $ Right (mkSymCoercion given_co `mkTransCoercion` co) + +-- Coercion transformation: co = col cor +-- +mkAppEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type) + -> TcM (EqInstCo, EqInstCo) +mkAppEqInstCo (Left cotv) (ty1_l, ty2_l) (ty1_r, ty2_r) + = do { cotv_l <- newMetaCoVar ty1_l ty2_l + ; cotv_r <- newMetaCoVar ty1_r ty2_r + ; writeMetaTyVar cotv (mkAppCoercion (TyVarTy cotv_l) (TyVarTy cotv_r)) + ; return (Left cotv_l, Left cotv_r) + } +mkAppEqInstCo (Right co) _ _ + = return (Right $ mkLeftCoercion co, Right $ mkRightCoercion co) +\end{code} + +Operations on entire EqInst. -fromWantedCo :: String -> Either TcTyVar Coercion -> TcTyVar -fromWantedCo _ (Left covar) = covar -fromWantedCo msg _ = panic ("fromWantedCo: not a wanted coercion: " ++ msg) +\begin{code} +-- |A wanted equality is unsolved as long as its cotv is unfilled. +-- +wantedEqInstIsUnsolved :: Inst -> TcM Bool +wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv}) + = liftM not $ isFilledMetaTyVar cotv +wantedEqInstIsUnsolved _ = return True eitherEqInst :: Inst -- given or wanted EqInst -> (TcTyVar -> a) -- result if wanted @@ -960,20 +1098,23 @@ eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven Right co -> withGiven co eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i) -mkEqInsts :: [PredType] -> [Either TcTyVar Coercion] -> TcM [Inst] -mkEqInsts preds cos = zipWithM mkEqInst preds cos - -mkEqInst :: PredType -> Either TcTyVar Coercion -> TcM Inst +mkEqInst :: PredType -> EqInstCo -> TcM Inst mkEqInst (EqPred ty1 ty2) co = do { uniq <- newUnique ; src_span <- getSrcSpanM ; err_ctxt <- getErrCtxt ; let loc = InstLoc EqOrigin src_span err_ctxt name = mkName uniq src_span - inst = EqInst {tci_left = ty1, tci_right = ty2, tci_co = co, tci_loc = loc, tci_name = name} + inst = EqInst { tci_left = ty1 + , tci_right = ty2 + , tci_co = co + , tci_loc = loc + , tci_name = name + } ; return inst } - where mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span + where + mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred) mkWantedEqInst :: PredType -> TcM Inst @@ -983,40 +1124,42 @@ mkWantedEqInst pred@(EqPred ty1 ty2) } mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred) --- type inference: --- We want to promote the wanted EqInst to a given EqInst --- in the signature context. --- This means we have to give the coercion a name --- and fill it in as its own name. -finalizeEqInst - :: Inst -- wanted - -> TcM Inst -- given -finalizeEqInst wanted@(EqInst {tci_left = ty1, tci_right = ty2, tci_name = name}) - = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2) - ; writeWantedCoercion wanted (TyVarTy var) - ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var } - ; return given - } -finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i) +-- Turn a wanted equality into a local that propagates the uninstantiated +-- coercion variable as witness. We need this to propagate wanted irreds into +-- attempts to solve implication constraints. +-- +wantedToLocalEqInst :: Inst -> Inst +wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv}) + = eq {tci_co = Right (mkTyVarTy cotv)} +wantedToLocalEqInst eq = eq + +-- Turn a wanted into a local EqInst (needed during type inference for +-- signatures) +-- +-- * Give it a name and change the coercion around. +-- +finalizeEqInst :: Inst -- wanted + -> TcM Inst -- given +finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, + tci_name = name, tci_co = Left cotv}) + = do { let var = Var.mkCoVar name (PredTy $ EqPred ty1 ty2) + + -- fill the coercion hole + ; writeMetaTyVar cotv (TyVarTy var) + + -- set the new coercion + ; let given = wanted { tci_co = mkGivenCo $ TyVarTy var } + ; return given + } -writeWantedCoercion - :: Inst -- wanted EqInst - -> Coercion -- coercion to fill the hole with - -> TcM () -writeWantedCoercion wanted co - = do { let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted - ; writeMetaTyVar cotv co - } +finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i) eqInstType :: Inst -> TcType eqInstType inst = eitherEqInst inst mkTyVarTy id -eqInstCoercion :: Inst -> Either TcTyVar Coercion +eqInstCoercion :: Inst -> EqInstCo eqInstCoercion = tci_co eqInstTys :: Inst -> (TcType, TcType) eqInstTys inst = (tci_left inst, tci_right inst) - -updateEqInstCoercion :: (Either TcTyVar Coercion -> Either TcTyVar Coercion) -> Inst -> Inst -updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst} \end{code}