-
-import Control.Monad
-\end{code}
-
-
-
-Selection
-~~~~~~~~~
-\begin{code}
-instName :: Inst -> Name
-instName (EqInst {tci_name = name}) = name
-instName inst = Var.varName (instToVar inst)
-
-instToId :: Inst -> TcId
-instToId inst = WARN( not (isId id), ppr inst )
- id
- where
- id = instToVar inst
-
-instToVar :: Inst -> Var
-instToVar (LitInst {tci_name = nm, tci_ty = ty})
- = mkLocalId nm ty
-instToVar (Method {tci_id = id})
- = id
-instToVar (Dict {tci_name = nm, tci_pred = pred})
- | isEqPred pred = Var.mkCoVar nm (mkPredTy pred)
- | otherwise = mkLocalId nm (mkPredTy pred)
-instToVar (ImplicInst {tci_name = nm, tci_tyvars = tvs, tci_given = givens,
- tci_wanted = wanteds})
- = mkLocalId nm (mkImplicTy tvs givens wanteds)
-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
-instType (Method {tci_id = id}) = idType id
-instType (Dict {tci_pred = pred}) = mkPredTy pred
-instType imp@(ImplicInst {}) = mkImplicTy (tci_tyvars imp) (tci_given imp)
- (tci_wanted imp)
--- instType i@(EqInst {tci_co = co}) = eitherEqInst i TyVarTy id
-instType (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
-
-mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
-mkImplicTy tvs givens wanteds -- The type of an implication constraint
- = ASSERT( all isAbstractableInst givens )
- -- pprTrace "mkImplicTy" (ppr givens) $
- -- See [Equational Constraints in Implication Constraints]
- let dict_wanteds = filter (not . isEqInst) wanteds
- in
- mkForAllTys tvs $
- mkPhiTy (map dictPred givens) $
- mkBigCoreTupTy (map instType dict_wanteds)
-
-dictPred :: Inst -> TcPredType
-dictPred (Dict {tci_pred = pred}) = pred
-dictPred (EqInst {tci_left=ty1,tci_right=ty2}) = EqPred ty1 ty2
-dictPred inst = pprPanic "dictPred" (ppr inst)
-
-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
--- Leaving these in is really important for the call to fdPredsOfInsts
--- in TcSimplify.inferLoop, because the result is fed to 'grow',
--- which is supposed to be conservative
-fdPredsOfInst :: Inst -> [TcPredType]
-fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
-fdPredsOfInst (Method {tci_theta = theta}) = theta
-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
-isInheritableInst _ = True
-
-
----------------------------------
--- Get the implicit parameters mentioned by these Insts
--- NB: the results of these functions are insensitive to zonking
-
-ipNamesOfInsts :: [Inst] -> [Name]
-ipNamesOfInst :: Inst -> [Name]
-ipNamesOfInsts insts = [n | inst <- insts, n <- ipNamesOfInst inst]
-
-ipNamesOfInst (Dict {tci_pred = IParam n _}) = [ipNameName n]
-ipNamesOfInst (Method {tci_theta = theta}) = [ipNameName n | IParam n _ <- theta]
-ipNamesOfInst _ = []
-
----------------------------------
-
--- |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})
- = (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
-
--- |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] -> TyVarSet
-tyVarsOfInsts insts = foldr (unionVarSet . tyVarsOfInst) emptyVarSet insts
-
-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 { 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