cloneDict, mkOverLit,
newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
- tcSyntaxName, isHsVar,
+ tcSyntaxName,
- tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE,
- ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst, fdPredsOfInsts,
- getDictClassTys, dictPred,
+ tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, tcTyVarsOfInst,
+ tcTyVarsOfInsts, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst,
+ fdPredsOfInsts, growInstsTyVars, getDictClassTys, dictPred,
lookupSimpleInst, LookupInstResult(..),
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
InstOrigin(..), InstLoc, pprInstLoc,
- mkWantedCo, mkGivenCo,
- isWantedCo, fromWantedCo, fromGivenCo, eqInstCoType,
- mkIdEqInstCo, mkSymEqInstCo, mkLeftTransEqInstCo,
- mkRightTransEqInstCo, mkAppEqInstCo,
- isValidWantedEqInst,
- eitherEqInst, mkEqInst, mkEqInsts, mkWantedEqInst,
- wantedToLocalEqInst, finalizeEqInst,
- eqInstType, updateEqInstCoercion,
- eqInstCoercion, eqInstTys
+ mkWantedCo, mkGivenCo, isWantedCo, eqInstCoType, mkIdEqInstCo,
+ mkSymEqInstCo, mkLeftTransEqInstCo, mkRightTransEqInstCo, mkAppEqInstCo,
+ mkTyConEqInstCo, mkFunEqInstCo,
+ wantedEqInstIsUnsolved, eitherEqInst, mkEqInst, mkWantedEqInst,
+ wantedToLocalEqInst, finalizeEqInst, eqInstType, eqInstCoercion,
+ eqInstTys
) where
#include "HsVersions.h"
import FunDeps
import TcMType
import TcType
-import MkCore
+import MkCore ( mkBigCoreTupTy )
+import TyCon
import Type
import TypeRep
import Class
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
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
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
ipNamesOfInst _ = []
---------------------------------
-tyVarsOfInst :: Inst -> TcTyVarSet
+
+-- |All free type variables (not including the coercion variables of
+-- equalities)
+--
+tyVarsOfInst :: Inst -> TyVarSet
tyVarsOfInst (LitInst {tci_ty = ty}) = tyVarsOfType ty
tyVarsOfInst (Dict {tci_pred = pred}) = tyVarsOfPred pred
-tyVarsOfInst (Method {tci_oid = id, tci_tys = tys}) = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
- -- The id might have free type variables; in the case of
- -- locally-overloaded class methods, for example
-tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens, tci_wanted = wanteds})
+tyVarsOfInst (Method {tci_oid = id, tci_tys = tys})
+ = tyVarsOfTypes tys `unionVarSet` varTypeTyVars id
+ -- The id might have free type variables; in the case of
+ -- locally-overloaded class methods, for example
+tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens,
+ tci_wanted = wanteds})
= (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
`minusVarSet` mkVarSet tvs
`unionVarSet` unionVarSets (map varTypeTyVars tvs)
-- Remember the free tyvars of a coercion
-tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2}) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2})
+ = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
+
+-- |All free meta type variables *including* the coercion variables of
+-- equalities
+--
+tcTyVarsOfInst :: Inst -> TyVarSet
+tcTyVarsOfInst (LitInst {tci_ty = ty}) = tcTyVarsOfType ty
+tcTyVarsOfInst (Dict {tci_pred = pred}) = tcTyVarsOfPred pred
+tcTyVarsOfInst (Method {tci_oid = id, tci_tys = tys})
+ = tcTyVarsOfTypes tys `unionVarSet` varTypeTcTyVars id
+ -- The id might have free type variables; in the case of
+ -- locally-overloaded class methods, for example
+tcTyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens,
+ tci_wanted = wanteds})
+ = (tcTyVarsOfInsts givens `unionVarSet` tcTyVarsOfInsts wanteds)
+ `minusVarSet` mkVarSet tvs
+ `unionVarSet` unionVarSets (map varTypeTcTyVars tvs)
+ -- Remember the free tyvars of a coercion
+tcTyVarsOfInst (EqInst {tci_co = co, tci_left = ty1, tci_right = ty2})
+ = either unitVarSet tcTyVarsOfType co `unionVarSet` -- include covars
+ tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2
-tyVarsOfInsts :: [Inst] -> VarSet
+tyVarsOfInsts :: [Inst] -> TyVarSet
tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
-tyVarsOfLIE :: Bag Inst -> VarSet
+
+tcTyVarsOfInsts :: [Inst] -> TcTyVarSet
+tcTyVarsOfInsts insts = foldr (unionVarSet . tcTyVarsOfInst) emptyVarSet insts
+
+tyVarsOfLIE :: Bag Inst -> TyVarSet
tyVarsOfLIE lie = tyVarsOfInsts (lieToList lie)
--------------------------
instToDictBind :: Inst -> LHsExpr TcId -> TcDictBinds
instToDictBind inst rhs
- = unitBag (L (instSpan inst) (VarBind (instToId inst) rhs))
+ = unitBag (L (instSpan inst) (VarBind { var_id = instToId inst
+ , var_rhs = rhs
+ , var_inline = False }))
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
; return (HsRat r rat_ty) }
mkOverLit (HsIsString s) = return (HsString s)
-
-isHsVar :: HsExpr Name -> Name -> Bool
-isHsVar (HsVar f) g = f == g
-isHsVar _ _ = False
\end{code}
{ use_stage <- getStage
; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
- (topIdLvl dfun_id) use_stage
+ (topIdLvl dfun_id) (thLevel use_stage)
-- It's possible that not all the tyvars are in
-- the substitution, tenv. For example:
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
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
--
mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
mkIdEqInstCo (Left cotv) t
- = writeMetaTyVar cotv t
+ = bindMetaTyVar cotv t
mkIdEqInstCo (Right _) _
= return ()
mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
mkSymEqInstCo (Left cotv) (ty1, ty2)
= do { cotv' <- newMetaCoVar ty1 ty2
- ; writeMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
+ ; bindMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
; return $ Left cotv'
}
mkSymEqInstCo (Right 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)
+ ; bindMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
; return $ Left cotv'
}
mkLeftTransEqInstCo (Right co) given_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')
+ ; bindMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
; return $ Left cotv'
}
mkRightTransEqInstCo (Right co) given_co _
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))
+ ; bindMetaTyVar 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)
+
+-- Coercion transformation: co = con col -> cor
+--
+mkTyConEqInstCo :: EqInstCo -> TyCon -> [(Type, Type)] -> TcM ([EqInstCo])
+mkTyConEqInstCo (Left cotv) con ty12s
+ = do { cotvs <- mapM (uncurry newMetaCoVar) ty12s
+ ; bindMetaTyVar cotv (mkTyConCoercion con (mkTyVarTys cotvs))
+ ; return (map Left cotvs)
+ }
+mkTyConEqInstCo (Right co) _ args
+ = return $ map (\mkCoes -> Right $ foldl (.) id mkCoes co) mkCoes
+ -- make cascades of the form
+ -- mkRightCoercion (mkLeftCoercion .. (mkLeftCoercion co)..)
+ where
+ n = length args
+ mkCoes = [mkRightCoercion : replicate i mkLeftCoercion | i <- [n-1, n-2..0]]
+
+-- Coercion transformation: co = col -> cor
+--
+mkFunEqInstCo :: EqInstCo -> (Type, Type) -> (Type, Type)
+ -> TcM (EqInstCo, EqInstCo)
+mkFunEqInstCo (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
+ ; bindMetaTyVar cotv (mkFunCoercion (TyVarTy cotv_l) (TyVarTy cotv_r))
+ ; return (Left cotv_l, Left cotv_r)
+ }
+mkFunEqInstCo (Right co) _ _
+ = return (Right $ mkRightCoercion (mkLeftCoercion co),
+ Right $ mkRightCoercion co)
\end{code}
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
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
; return inst
}
where
- mkName uniq src_span = mkInternalName uniq (mkVarOcc "co") src_span
+ mkName uniq src_span = mkInternalName uniq (mkVarOcc "co_ei") src_span
mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
mkWantedEqInst :: PredType -> TcM Inst
--
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
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}