X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FInst.lhs;h=8a014bca6f6db9f0b2a27c4b7b6ab225daf52833;hb=e5a8d57c85d42007c8cc561e6d6b805c23603fc0;hp=1a8efe2ebf0c54a3a86500593166b520c0f710ab;hpb=e8901a971ef4fcac3e99f4069b6edbd73d42b31b;p=ghc-hetmet.git diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 1a8efe2..8a014bc 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -24,7 +24,7 @@ module Inst ( tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts, - getDictClassTys, dictPred, + growInstsTyVars, getDictClassTys, dictPred, lookupSimpleInst, LookupInstResult(..), tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, @@ -40,14 +40,11 @@ module Inst ( InstOrigin(..), InstLoc, pprInstLoc, - mkWantedCo, mkGivenCo, - isWantedCo, fromWantedCo, fromGivenCo, eqInstCoType, - mkIdEqInstCo, mkSymEqInstCo, mkLeftTransEqInstCo, - mkRightTransEqInstCo, mkAppEqInstCo, - isValidWantedEqInst, - eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst, finalizeEqInst, - 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" @@ -120,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 @@ -152,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 @@ -161,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 @@ -216,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 @@ -286,7 +326,7 @@ newDictBndr :: InstLoc -> TcPredType -> TcM Inst 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)) + co = mkGivenCo $ TyVarTy (Var.mkCoVar name (PredTy pred)) ; return (EqInst {tci_name = name, tci_loc = inst_loc, tci_left = ty1, @@ -859,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 @@ -969,15 +1010,6 @@ isWantedCo :: EqInstCo -> Bool isWantedCo (Left _) = True isWantedCo _ = False -fromGivenCo :: EqInstCo -> Coercion -fromGivenCo (Right co) = co -fromGivenCo _ = panic "fromGivenCo: not a wanted coercion" - -fromWantedCo :: String -> EqInstCo -> TcTyVar -fromWantedCo _ (Left covar) = covar -fromWantedCo msg _ = - panic ("fromWantedCo: not a wanted coercion: " ++ msg) - eqInstCoType :: EqInstCo -> TcType eqInstCoType (Left cotv) = mkTyVarTy cotv eqInstCoType (Right co) = co @@ -1049,12 +1081,12 @@ mkAppEqInstCo (Right co) _ _ Operations on entire EqInst. \begin{code} --- For debugging, make sure the cotv of a wanted is not filled. +-- |A wanted equality is unsolved as long as its cotv is unfilled. -- -isValidWantedEqInst :: Inst -> TcM Bool -isValidWantedEqInst (EqInst {tci_co = Left cotv}) +wantedEqInstIsUnsolved :: Inst -> TcM Bool +wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv}) = liftM not $ isFilledMetaTyVar cotv -isValidWantedEqInst _ = return True +wantedEqInstIsUnsolved _ = return True eitherEqInst :: Inst -- given or wanted EqInst -> (TcTyVar -> a) -- result if wanted @@ -1066,9 +1098,6 @@ eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven Right co -> withGiven co eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i) -mkEqInsts :: [PredType] -> [EqInstCo] -> TcM [Inst] -mkEqInsts preds cos = zipWithM mkEqInst preds cos - mkEqInst :: PredType -> EqInstCo -> TcM Inst mkEqInst (EqPred ty1 ty2) co = do { uniq <- newUnique @@ -1095,6 +1124,15 @@ mkWantedEqInst pred@(EqPred ty1 ty2) } mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred) +-- 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) -- @@ -1102,11 +1140,11 @@ mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred) -- finalizeEqInst :: Inst -- wanted -> TcM Inst -- given -finalizeEqInst wanted@(EqInst{tci_left = ty1, tci_right = ty2, tci_name = name}) +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 - ; let cotv = fromWantedCo "writeWantedCoercion" $ tci_co wanted ; writeMetaTyVar cotv (TyVarTy var) -- set the new coercion @@ -1124,7 +1162,4 @@ eqInstCoercion = tci_co eqInstTys :: Inst -> (TcType, TcType) eqInstTys inst = (tci_left inst, tci_right inst) - -updateEqInstCoercion :: (EqInstCo -> EqInstCo) -> Inst -> Inst -updateEqInstCoercion f inst = inst {tci_co = f $ tci_co inst} \end{code}