%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
The @Inst@ type: dictionaries or method instances
\begin{code}
module Inst (
Inst,
pprInstances, pprDictsTheta, pprDictsInFull,
showLIE, pprInst, pprInsts, pprInstInFull,
tidyInsts, tidyMoreInsts,
newDictBndr, newDictBndrs, newDictBndrsO,
newDictOccs, newDictOcc,
instCall, instStupidTheta,
cloneDict, mkOverLit,
newIPDict, newMethod, newMethodFromName, newMethodWithGivenTy,
tcInstClassOp,
tcSyntaxName,
tyVarsOfInst, tyVarsOfInsts, tyVarsOfLIE, tcTyVarsOfInst,
tcTyVarsOfInsts, ipNamesOfInst, ipNamesOfInsts, fdPredsOfInst,
fdPredsOfInsts, growInstsTyVars, getDictClassTys, dictPred,
lookupSimpleInst, LookupInstResult(..),
tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isAbstractableInst, isEqInst,
isDict, isClassDict, isMethod, isImplicInst,
isIPDict, isInheritableInst, isMethodOrLit,
isTyVarDict, isMethodFor,
zonkInst, zonkInsts,
instToId, instToVar, instType, instName, instToDictBind,
addInstToDictBind,
InstOrigin(..), InstLoc, pprInstLoc,
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 TcExpr( tcPolyExpr )
import TcUnify( boxyUnify )
import FastString
import HsSyn
import TcHsSyn
import TcRnMonad
import TcEnv
import InstEnv
import FunDeps
import TcMType
import TcType
import MkCore ( mkBigCoreTupTy )
import TyCon
import Type
import TypeRep
import Class
import Unify
import Module
import Coercion
import HscTypes
import CoreFVs
import Id
import Name
import NameSet
import Var ( Var, TyVar )
import qualified Var
import VarEnv
import VarSet
import PrelNames
import BasicTypes
import SrcLoc
import DynFlags
import Bag
import Maybes
import Util
import Unique
import Outputable
import Data.List
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 (EqInst {tci_left = ty1, tci_right = ty2}) = mkPredTy (EqPred ty1 ty2)
mkImplicTy :: [TyVar] -> [Inst] -> [Inst] -> Type
mkImplicTy tvs givens wanteds
= ASSERT( all isAbstractableInst givens )
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 :: Inst -> [TcPredType]
fdPredsOfInst (Dict {tci_pred = pred}) = [pred]
fdPredsOfInst (Method {tci_theta = theta}) = theta
fdPredsOfInst (ImplicInst {tci_wanted = ws}) = fdPredsOfInsts ws
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
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 _ = []
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
tyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens,
tci_wanted = wanteds})
= (tyVarsOfInsts givens `unionVarSet` tyVarsOfInsts wanteds)
`minusVarSet` mkVarSet tvs
`unionVarSet` unionVarSets (map varTypeTyVars tvs)
tyVarsOfInst (EqInst {tci_left = ty1, tci_right = ty2})
= tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2
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
tcTyVarsOfInst (ImplicInst {tci_tyvars = tvs, tci_given = givens,
tci_wanted = wanteds})
= (tcTyVarsOfInsts givens `unionVarSet` tcTyVarsOfInsts wanteds)
`minusVarSet` mkVarSet tvs
`unionVarSet` unionVarSets (map varTypeTcTyVars tvs)
tcTyVarsOfInst (EqInst {tci_co = co, tci_left = ty1, tci_right = ty2})
= either unitVarSet tcTyVarsOfType co `unionVarSet`
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 (instToId inst) rhs))
addInstToDictBind :: TcDictBinds -> Inst -> LHsExpr TcId -> TcDictBinds
addInstToDictBind binds inst rhs = binds `unionBags` instToDictBind inst rhs
\end{code}
Note [Growing the tautvs 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
= growTyVars (tyVarsOfInst inst) tvs
\end{code}
%************************************************************************
%* *
Predicates
%* *
%************************************************************************
\begin{code}
isAbstractableInst :: Inst -> Bool
isAbstractableInst inst = isDict inst || isEqInst inst
isEqInst :: Inst -> Bool
isEqInst (EqInst {}) = True
isEqInst _ = False
isDict :: Inst -> Bool
isDict (Dict {}) = True
isDict _ = False
isClassDict :: Inst -> Bool
isClassDict (Dict {tci_pred = pred}) = isClassPred pred
isClassDict _ = False
isTyVarDict :: Inst -> Bool
isTyVarDict (Dict {tci_pred = pred}) = isTyVarClassPred pred
isTyVarDict _ = False
isIPDict :: Inst -> Bool
isIPDict (Dict {tci_pred = pred}) = isIPPred pred
isIPDict _ = False
isImplicInst :: Inst -> Bool
isImplicInst (ImplicInst {}) = True
isImplicInst _ = False
isMethod :: Inst -> Bool
isMethod (Method {}) = True
isMethod _ = False
isMethodFor :: TcIdSet -> Inst -> Bool
isMethodFor ids (Method {tci_oid = id}) = id `elemVarSet` ids
isMethodFor _ _ = False
isMethodOrLit :: Inst -> Bool
isMethodOrLit (Method {}) = True
isMethodOrLit (LitInst {}) = True
isMethodOrLit _ = False
\end{code}
%************************************************************************
%* *
\subsection{Building dictionaries}
%* *
%************************************************************************
\begin{code}
newDictBndrsO :: InstOrigin -> TcThetaType -> TcM [Inst]
newDictBndrsO orig theta = do { loc <- getInstLoc orig
; newDictBndrs loc theta }
newDictBndrs :: InstLoc -> TcThetaType -> TcM [Inst]
newDictBndrs inst_loc theta = mapM (newDictBndr inst_loc) theta
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))
; return (EqInst {tci_name = name,
tci_loc = inst_loc,
tci_left = ty1,
tci_right = ty2,
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
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
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}) }
instCall :: InstOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
instCall orig tys theta
= do { loc <- getInstLoc orig
; dict_app <- instCallDicts loc theta
; return (dict_app <.> mkWpTyApps tys) }
instStupidTheta :: InstOrigin -> TcThetaType -> TcM ()
instStupidTheta orig theta
= do { loc <- getInstLoc orig
; _co <- instCallDicts loc theta
; return () }
instCallDicts :: InstLoc -> TcThetaType -> TcM HsWrapper
instCallDicts _ [] = return idHsWrapper
instCallDicts loc (EqPred ty1 ty2 : preds)
= do { traceTc (text "instCallDicts" <+> ppr (EqPred ty1 ty2))
; coi <- boxyUnify ty1 ty2
; let co = fromCoI coi ty1
; co_fn <- instCallDicts loc preds
; return (co_fn <.> WpTyApp co) }
instCallDicts loc (pred : preds)
= do { dict <- newDict loc pred
; extendLIE dict
; co_fn <- instCallDicts loc preds
; return (co_fn <.> WpApp (instToId dict)) }
cloneDict :: Inst -> TcM Inst
cloneDict dict@(Dict nm _ _) = do { uniq <- newUnique
; return (dict {tci_name = setNameUnique nm uniq}) }
cloneDict eq@(EqInst {}) = return eq
cloneDict other = pprPanic "cloneDict" (ppr other)
newIPDict :: InstOrigin -> IPName Name -> Type
-> TcM (IPName Id, Inst)
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}
\begin{code}
mkPredName :: Unique -> InstLoc -> PredType -> Name
mkPredName uniq loc pred_ty
= mkInternalName uniq occ (instLocSpan loc)
where
occ = case pred_ty of
ClassP cls _ -> mkDictOcc (getOccName cls)
IParam ip _ -> getOccName (ipNameName ip)
EqPred ty _ -> mkEqPredCoOcc baseOcc
where
baseOcc = case splitTyConApp_maybe ty of
Nothing -> mkTcOcc "$"
Just (tc, _) -> getOccName tc
\end{code}
%************************************************************************
%* *
\subsection{Building methods (calls of overloaded functions)}
%* *
%************************************************************************
\begin{code}
newMethodFromName :: InstOrigin -> BoxyRhoType -> Name -> TcM TcId
newMethodFromName origin ty name = do
id <- tcLookupId name
loc <- getInstLoc origin
inst <- tcInstClassOp loc id [ty]
extendLIE inst
return (instToId inst)
newMethodWithGivenTy :: InstOrigin -> Id -> [Type] -> TcRn TcId
newMethodWithGivenTy orig id tys = do
loc <- getInstLoc orig
inst <- newMethod loc id tys
extendLIE inst
return (instToId inst)
tcInstClassOp :: InstLoc -> Id -> [TcType] -> TcM Inst
tcInstClassOp inst_loc sel_id tys = do
let
(tyvars, _rho) = tcSplitForAllTys (idType sel_id)
zipWithM_ checkKind tyvars tys
newMethod inst_loc sel_id tys
checkKind :: TyVar -> TcType -> TcM ()
checkKind tv ty
= do { let ty1 = ty
; if typeKind ty1 `isSubKind` Var.tyVarKind tv
then return ()
else
pprPanic "checkKind: adding kind constraint"
(vcat [ppr tv <+> ppr (Var.tyVarKind tv),
ppr ty <+> ppr ty1 <+> ppr (typeKind ty1)])
}
newMethod :: InstLoc -> Id -> [Type] -> TcRn Inst
newMethod inst_loc id tys = do
new_uniq <- newUnique
let
(theta,tau) = tcSplitPhiTy (applyTys (idType id) tys)
meth_id = mkUserLocal (mkMethodOcc (getOccName id)) new_uniq tau loc
inst = Method {tci_id = meth_id, tci_oid = id, tci_tys = tys,
tci_theta = theta, tci_loc = inst_loc}
loc = instLocSpan inst_loc
return inst
\end{code}
\begin{code}
mkOverLit :: OverLitVal -> TcM HsLit
mkOverLit (HsIntegral i)
= do { integer_ty <- tcMetaTy integerTyConName
; return (HsInteger i integer_ty) }
mkOverLit (HsFractional r)
= do { rat_ty <- tcMetaTy rationalTyConName
; return (HsRat r rat_ty) }
mkOverLit (HsIsString s) = return (HsString s)
\end{code}
%************************************************************************
%* *
\subsection{Zonking}
%* *
%************************************************************************
Zonking makes sure that the instance types are fully zonked.
\begin{code}
zonkInst :: Inst -> TcM Inst
zonkInst dict@(Dict {tci_pred = pred}) = do
new_pred <- zonkTcPredType pred
return (dict {tci_pred = new_pred})
zonkInst meth@(Method {tci_oid = id, tci_tys = tys, tci_theta = theta}) = do
new_id <- zonkId id
new_tys <- zonkTcTypes tys
new_theta <- zonkTcThetaType theta
return (meth { tci_oid = new_id, tci_tys = new_tys, tci_theta = new_theta })
zonkInst lit@(LitInst {tci_ty = ty}) = do
new_ty <- zonkTcType ty
return (lit {tci_ty = new_ty})
zonkInst implic@(ImplicInst {})
= ASSERT( all isImmutableTyVar (tci_tyvars implic) )
do { givens' <- zonkInsts (tci_given implic)
; wanteds' <- zonkInsts (tci_wanted implic)
; return (implic {tci_given = givens',tci_wanted = wanteds'}) }
zonkInst eqinst@(EqInst {tci_left = ty1, tci_right = ty2})
= do { co' <- eitherEqInst eqinst
(\covar -> return (mkWantedCo covar))
(\co -> liftM mkGivenCo $ zonkTcType co)
; ty1' <- zonkTcType ty1
; ty2' <- zonkTcType ty2
; return (eqinst {tci_co = co', tci_left = ty1', tci_right = ty2' })
}
zonkInsts :: [Inst] -> TcRn [Inst]
zonkInsts insts = mapM zonkInst insts
\end{code}
%************************************************************************
%* *
\subsection{Printing}
%* *
%************************************************************************
ToDo: improve these prettyprinting things. The ``origin'' is really only
relevant in error messages.
\begin{code}
instance Outputable Inst where
ppr inst = pprInst inst
pprDictsTheta :: [Inst] -> SDoc
pprDictsTheta insts = parens (sep (punctuate comma (map (ppr . instType) insts)))
pprDictsInFull :: [Inst] -> SDoc
pprDictsInFull dicts
= vcat (map go dicts)
where
go dict = sep [quotes (ppr (instType dict)), nest 2 (pprInstArising dict)]
pprInsts :: [Inst] -> SDoc
pprInsts insts = brackets (interpp'SP insts)
pprInst, pprInstInFull :: Inst -> SDoc
pprInst i@(EqInst {tci_left = ty1, tci_right = ty2})
= eitherEqInst i
(\covar -> text "Wanted" <+> ppr (TyVarTy covar) <+> dcolon <+> ppr (EqPred ty1 ty2))
(\co -> text "Given" <+> ppr co <+> dcolon <+> ppr (EqPred ty1 ty2))
pprInst inst = ppr name <> braces (pprUnique (getUnique name)) <+> dcolon
<+> braces (ppr (instType inst) <> implicWantedEqs)
where
name = instName inst
implicWantedEqs
| isImplicInst inst = text " &" <+>
ppr (filter isEqInst (tci_wanted inst))
| otherwise = empty
pprInstInFull inst@(EqInst {}) = pprInst inst
pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstArising inst)]
tidyInst :: TidyEnv -> Inst -> Inst
tidyInst env eq@(EqInst {tci_left = lty, tci_right = rty, tci_co = co}) =
eq { tci_left = tidyType env lty
, tci_right = tidyType env rty
, tci_co = either Left (Right . tidyType env) co
}
tidyInst env lit@(LitInst {tci_ty = ty}) = lit {tci_ty = tidyType env ty}
tidyInst env dict@(Dict {tci_pred = pred}) = dict {tci_pred = tidyPred env pred}
tidyInst env meth@(Method {tci_tys = tys}) = meth {tci_tys = tidyTypes env tys}
tidyInst env implic@(ImplicInst {})
= implic { tci_tyvars = tvs'
, tci_given = map (tidyInst env') (tci_given implic)
, tci_wanted = map (tidyInst env') (tci_wanted implic) }
where
(env', tvs') = mapAccumL tidyTyVarBndr env (tci_tyvars implic)
tidyMoreInsts :: TidyEnv -> [Inst] -> (TidyEnv, [Inst])
tidyMoreInsts env insts
= (env', map (tidyInst env') insts)
where
env' = tidyFreeTyVars env (tyVarsOfInsts insts)
tidyInsts :: [Inst] -> (TidyEnv, [Inst])
tidyInsts insts = tidyMoreInsts emptyTidyEnv insts
showLIE :: SDoc -> TcM ()
showLIE str
= do { lie_var <- getLIEVar ;
lie <- readMutVar lie_var ;
traceTc (str <+> vcat (map pprInstInFull (lieToList lie))) }
\end{code}
%************************************************************************
%* *
Extending the instance environment
%* *
%************************************************************************
\begin{code}
tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a
tcExtendLocalInstEnv dfuns thing_inside
= do { traceDFuns dfuns
; env <- getGblEnv
; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns
; let env' = env { tcg_insts = dfuns ++ tcg_insts env,
tcg_inst_env = inst_env' }
; setGblEnv env' thing_inside }
addLocalInst :: InstEnv -> Instance -> TcM InstEnv
addLocalInst home_ie ispec
= do {
let dfun = instanceDFunId ispec
; (tvs', theta', tau') <- tcInstSkolType InstSkol (idType dfun)
; let (cls, tys') = tcSplitDFunHead tau'
dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau')
ispec' = setInstanceDFunId ispec dfun'
; eps <- getEps
; let inst_envs = (eps_inst_env eps, home_ie)
; case checkFunDeps inst_envs ispec' of
Just specs -> funDepErr ispec' specs
Nothing -> return ()
; let { (matches, _) = lookupInstEnv inst_envs cls tys'
; dup_ispecs = [ dup_ispec
| (dup_ispec, _) <- matches
, let (_,_,_,dup_tys) = instanceHead dup_ispec
, isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] }
; case dup_ispecs of
dup_ispec : _ -> dupInstErr ispec' dup_ispec
[] -> return ()
; return (extendInstEnv home_ie ispec') }
getOverlapFlag :: TcM OverlapFlag
getOverlapFlag
= do { dflags <- getDOpts
; let overlap_ok = dopt Opt_OverlappingInstances dflags
incoherent_ok = dopt Opt_IncoherentInstances dflags
overlap_flag | incoherent_ok = Incoherent
| overlap_ok = OverlapOk
| otherwise = NoOverlap
; return overlap_flag }
traceDFuns :: [Instance] -> TcRn ()
traceDFuns ispecs
= traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs)))
where
pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec
funDepErr :: Instance -> [Instance] -> TcRn ()
funDepErr ispec ispecs
= addDictLoc ispec $
addErr (hang (ptext (sLit "Functional dependencies conflict between instance declarations:"))
2 (pprInstances (ispec:ispecs)))
dupInstErr :: Instance -> Instance -> TcRn ()
dupInstErr ispec dup_ispec
= addDictLoc ispec $
addErr (hang (ptext (sLit "Duplicate instance declarations:"))
2 (pprInstances [ispec, dup_ispec]))
addDictLoc :: Instance -> TcRn a -> TcRn a
addDictLoc ispec thing_inside
= setSrcSpan (mkSrcSpan loc loc) thing_inside
where
loc = getSrcLoc ispec
\end{code}
%************************************************************************
%* *
\subsection{Looking up Insts}
%* *
%************************************************************************
\begin{code}
data LookupInstResult
= NoInstance
| GenInst [Inst] (LHsExpr TcId)
lookupSimpleInst :: Inst -> TcM LookupInstResult
lookupSimpleInst (EqInst {}) = return NoInstance
lookupSimpleInst (ImplicInst {}) = return NoInstance
lookupSimpleInst (Method {tci_oid = id, tci_tys = tys, tci_theta = theta, tci_loc = loc})
= do { (dict_app, dicts) <- getLIE $ instCallDicts loc theta
; let co_fn = dict_app <.> mkWpTyApps tys
; return (GenInst dicts (L span $ HsWrap co_fn (HsVar id))) }
where
span = instLocSpan loc
lookupSimpleInst (LitInst { tci_lit = lit@OverLit { ol_val = lit_val
, ol_rebindable = rebindable }
, tci_ty = ty, tci_loc = iloc})
| debugIsOn && rebindable = panic "lookupSimpleInst"
| Just witness <- shortCutLit lit_val ty
= do { let lit' = lit { ol_witness = witness, ol_type = ty }
; return (GenInst [] (L loc (HsOverLit lit'))) }
| otherwise
= do { hs_lit <- mkOverLit lit_val
; from_thing <- tcLookupId (hsOverLitName lit_val)
; method_inst <- tcInstClassOp iloc from_thing [ty]
; let witness = HsApp (L loc (HsVar (instToId method_inst)))
(L loc (HsLit hs_lit))
lit' = lit { ol_witness = witness, ol_type = ty }
; return (GenInst [method_inst] (L loc (HsOverLit lit'))) }
where
loc = instLocSpan iloc
lookupSimpleInst (Dict {tci_pred = pred, tci_loc = loc})
= do { mb_result <- lookupPred pred
; case mb_result of {
Nothing -> return NoInstance ;
Just (dfun_id, mb_inst_tys) -> do
{ use_stage <- getStage
; checkWellStaged (ptext (sLit "instance for") <+> quotes (ppr pred))
(topIdLvl dfun_id) (thLevel use_stage)
; let inst_tv (Left tv) = do { tv' <- tcInstTyVar tv; return (mkTyVarTy tv') }
inst_tv (Right ty) = return ty
; tys <- mapM inst_tv mb_inst_tys
; let
(theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys)
src_loc = instLocSpan loc
dfun = HsVar dfun_id
; if null theta then
return (GenInst [] (L src_loc $ HsWrap (mkWpTyApps tys) dfun))
else do
{ (dict_app, dicts) <- getLIE $ instCallDicts loc theta
; let co_fn = dict_app <.> mkWpTyApps tys
; return (GenInst dicts (L src_loc $ HsWrap co_fn dfun))
}}}}
lookupPred :: TcPredType -> TcM (Maybe (DFunId, [Either TyVar TcType]))
lookupPred pred@(ClassP clas tys)
= do { eps <- getEps
; tcg_env <- getGblEnv
; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env)
; case lookupInstEnv inst_envs clas tys of {
([(ispec, inst_tys)], [])
-> do { let dfun_id = is_dfun ispec
; traceTc (text "lookupInst success" <+>
vcat [text "dict" <+> ppr pred,
text "witness" <+> ppr dfun_id
<+> ppr (idType dfun_id) ])
; record_dfun_usage dfun_id
; return (Just (dfun_id, inst_tys)) } ;
(matches, unifs)
-> do { traceTc (text "lookupInst fail" <+>
vcat [text "dict" <+> ppr pred,
text "matches" <+> ppr matches,
text "unifs" <+> ppr unifs])
; return Nothing }
}}
lookupPred (IParam {}) = return Nothing
lookupPred (EqPred {}) = panic "lookupPred EqPred"
record_dfun_usage :: Id -> TcRn ()
record_dfun_usage dfun_id
= do { hsc_env <- getTopEnv
; let dfun_name = idName dfun_id
dfun_mod = ASSERT( isExternalName dfun_name )
nameModule dfun_name
; if isInternalName dfun_name ||
modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
then return ()
else do { tcg_env <- getGblEnv
; updMutVar (tcg_inst_uses tcg_env)
(`addOneToNameSet` idName dfun_id) }}
tcGetInstEnvs :: TcM (InstEnv, InstEnv)
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
return (eps_inst_env eps, tcg_inst_env env) }
\end{code}
%************************************************************************
%* *
Remappable syntax
%* *
%************************************************************************
Suppose we are doing the XNoImplicitPrelude thing, and we encounter
a doexpression. We have to find (>>) in the current environment, which is
done by the rename. Then we have to check that it has the same type as
Control.Monad.(>>). Or, more precisely, a compatible type. One 'customer' had
this:
(>>) :: HB m n mn => m a -> n b -> mn b
So the idea is to generate a local binding for (>>), thus:
let then72 :: forall a b. m a -> m b -> m b
then72 = ...something involving the user's (>>)...
in
...the doexpression...
Now the doexpression can proceed using then72, which has exactly
the expected type.
In fact tcSyntaxName just generates the RHS for then72, because we only
want an actual binding in the doexpression case. For literals, we can
just use the expression inline.
\begin{code}
tcSyntaxName :: InstOrigin
-> TcType
-> (Name, HsExpr Name)
-> TcM (Name, HsExpr TcId)
tcSyntaxName orig ty (std_nm, HsVar user_nm)
| std_nm == user_nm
= do id <- newMethodFromName orig ty std_nm
return (std_nm, HsVar id)
tcSyntaxName orig ty (std_nm, user_nm_expr) = do
std_id <- tcLookupId std_nm
let
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
sigma1 = substTyWith [tv] [ty] tau
addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do
span <- getSrcSpanM
expr <- tcPolyExpr (L span user_nm_expr) sigma1
return (std_nm, unLoc expr)
syntaxNameCtxt :: HsExpr Name -> InstOrigin -> Type -> TidyEnv
-> TcRn (TidyEnv, SDoc)
syntaxNameCtxt name orig ty tidy_env = do
inst_loc <- getInstLoc orig
let
msg = vcat [ptext (sLit "When checking that") <+> quotes (ppr name) <+>
ptext (sLit "(needed by a syntactic construct)"),
nest 2 (ptext (sLit "has the required type:") <+> ppr (tidyType tidy_env ty)),
nest 2 (ptext (sLit "arising from") <+> pprInstLoc inst_loc)]
return (tidy_env, msg)
\end{code}
%************************************************************************
%* *
EqInsts
%* *
%************************************************************************
Operations on EqInstCo.
\begin{code}
mkGivenCo :: Coercion -> EqInstCo
mkGivenCo = Right
mkWantedCo :: TcTyVar -> EqInstCo
mkWantedCo = Left
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}
mkIdEqInstCo :: EqInstCo -> Type -> TcM ()
mkIdEqInstCo (Left cotv) t
= bindMetaTyVar cotv t
mkIdEqInstCo (Right _) _
= return ()
mkSymEqInstCo :: EqInstCo -> (Type, Type) -> TcM EqInstCo
mkSymEqInstCo (Left cotv) (ty1, ty2)
= do { cotv' <- newMetaCoVar ty1 ty2
; bindMetaTyVar cotv (mkSymCoercion (TyVarTy cotv'))
; return $ Left cotv'
}
mkSymEqInstCo (Right co) _
= return $ Right (mkSymCoercion co)
mkLeftTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
mkLeftTransEqInstCo (Left cotv) given_co (ty1, ty2)
= do { cotv' <- newMetaCoVar ty1 ty2
; bindMetaTyVar cotv (TyVarTy cotv' `mkTransCoercion` given_co)
; return $ Left cotv'
}
mkLeftTransEqInstCo (Right co) given_co _
= return $ Right (co `mkTransCoercion` mkSymCoercion given_co)
mkRightTransEqInstCo :: EqInstCo -> Coercion -> (Type, Type) -> TcM EqInstCo
mkRightTransEqInstCo (Left cotv) given_co (ty1, ty2)
= do { cotv' <- newMetaCoVar ty1 ty2
; bindMetaTyVar cotv (given_co `mkTransCoercion` TyVarTy cotv')
; return $ Left cotv'
}
mkRightTransEqInstCo (Right co) given_co _
= return $ Right (mkSymCoercion given_co `mkTransCoercion` co)
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
; 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)
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
where
n = length args
mkCoes = [mkRightCoercion : replicate i mkLeftCoercion | i <- [n1, n2..0]]
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}
wantedEqInstIsUnsolved :: Inst -> TcM Bool
wantedEqInstIsUnsolved (EqInst {tci_co = Left cotv})
= liftM not $ isFilledMetaTyVar cotv
wantedEqInstIsUnsolved _ = return True
eitherEqInst :: Inst
-> (TcTyVar -> a)
-> (Coercion -> a)
-> a
eitherEqInst (EqInst {tci_co = either_co}) withWanted withGiven
= case either_co of
Left covar -> withWanted covar
Right co -> withGiven co
eitherEqInst i _ _ = pprPanic "eitherEqInst" (ppr i)
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
}
; return inst
}
where
mkName uniq src_span = mkInternalName uniq (mkVarOcc "co_ei") src_span
mkEqInst pred _ = pprPanic "mkEqInst" (ppr pred)
mkWantedEqInst :: PredType -> TcM Inst
mkWantedEqInst pred@(EqPred ty1 ty2)
= do { cotv <- newMetaCoVar ty1 ty2
; mkEqInst pred (Left cotv)
}
mkWantedEqInst pred = pprPanic "mkWantedEqInst" (ppr pred)
wantedToLocalEqInst :: Inst -> Inst
wantedToLocalEqInst eq@(EqInst {tci_co = Left cotv})
= eq {tci_co = Right (mkTyVarTy cotv)}
wantedToLocalEqInst eq = eq
finalizeEqInst :: Inst
-> TcM Inst
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)
; writeMetaTyVar cotv (TyVarTy var)
; let given = wanted { tci_co = mkGivenCo $ TyVarTy var }
; return given
}
finalizeEqInst i = pprPanic "finalizeEqInst" (ppr i)
eqInstType :: Inst -> TcType
eqInstType inst = eitherEqInst inst mkTyVarTy id
eqInstCoercion :: Inst -> EqInstCo
eqInstCoercion = tci_co
eqInstTys :: Inst -> (TcType, TcType)
eqInstTys inst = (tci_left inst, tci_right inst)
\end{code}