\begin{code}
module TcInstUtil (
InstInfo(..),
- buildInstanceEnvs,
+ buildInstanceEnv,
classDataCon
) where
import CmdLineOpts ( opt_AllowOverlappingInstances )
import TcMonad
-import Inst ( InstanceMapper )
-
+import TcEnv ( InstEnv, emptyInstEnv, addToInstEnv )
import Bag ( bagToList, Bag )
import Class ( Class )
-import Var ( TyVar, Id )
-import InstEnv ( InstEnv, emptyInstEnv, addToInstEnv )
+import Var ( TyVar, Id, idName )
import Maybes ( MaybeErr(..), mkLookupFunDef )
-import Name ( getSrcLoc )
+import Name ( getSrcLoc, nameModule, isLocallyDefined )
import SrcLoc ( SrcLoc )
-import Type ( ThetaType, Type )
+import Type ( Type, ClassContext )
import PprType ( pprConstraint )
import Class ( classTyCon )
import DataCon ( DataCon )
Class -- Class, k
[TyVar] -- Type variables, tvs
[Type] -- The types at which the class is being instantiated
- ThetaType -- inst_decl_theta: the original context, c, from the
+ ClassContext -- inst_decl_theta: the original context, c, from the
-- instance declaration. It constrains (some of)
-- the TyVars above
Id -- The dfun id
%************************************************************************
\begin{code}
-buildInstanceEnvs :: Bag InstInfo
- -> NF_TcM s InstanceMapper
-
-buildInstanceEnvs info
- = let
- i_uniq :: InstInfo -> Unique
- i_uniq (InstInfo c _ _ _ _ _ _ _) = getUnique c
-
- info_by_class = equivClassesByUniq i_uniq (bagToList info)
- in
- mapNF_Tc buildInstanceEnv info_by_class `thenNF_Tc` \ inst_env_entries ->
- let
- class_lookup_fn = mkLookupFunDef (==) inst_env_entries emptyInstEnv
- in
- returnNF_Tc class_lookup_fn
-\end{code}
+buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv
-\begin{code}
-buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
- -> NF_TcM s (Class, InstEnv)
-
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _) : _)
- = foldrNF_Tc addClassInstance
- emptyInstEnv
- inst_infos `thenNF_Tc` \ class_inst_env ->
- returnNF_Tc (clas, class_inst_env)
+buildInstanceEnv info = foldrNF_Tc addClassInstance emptyInstEnv (bagToList info)
\end{code}
@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
addClassInstance
(InstInfo clas inst_tyvars inst_tys _
dfun_id _ src_loc _)
- class_inst_env
+ inst_env
= -- Add the instance to the class's instance environment
case addToInstEnv opt_AllowOverlappingInstances
- class_inst_env inst_tyvars inst_tys dfun_id of
- Failed (ty', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, src_loc)
- (ty', getSrcLoc dfun_id'))
+ inst_env clas inst_tyvars inst_tys dfun_id of
+ Failed (tys', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, dfun_id)
+ (tys', dfun_id'))
`thenNF_Tc_`
- returnNF_Tc class_inst_env
+ returnNF_Tc inst_env
- Succeeded class_inst_env' -> returnNF_Tc class_inst_env'
+ Succeeded inst_env' -> returnNF_Tc inst_env'
\end{code}
\begin{code}
-dupInstErr clas info1@(tys1, locn1) info2@(tys2, locn2)
+dupInstErr clas info1@(tys1, dfun1) info2@(tys2, dfun2)
-- Overlapping/duplicate instances for given class; msg could be more glamourous
= hang (ptext SLIT("Duplicate or overlapping instance declarations"))
4 (sep [ptext SLIT("for") <+> quotes (pprConstraint clas tys1),
- nest 4 (sep [ptext SLIT("at") <+> ppr locn1,
- ptext SLIT("and") <+> ppr locn2])])
+ nest 4 (sep [ppr_loc dfun1, ptext SLIT("and") <+> ppr_loc dfun2])])
+ where
+ ppr_loc dfun
+ | isLocallyDefined dfun = ptext SLIT("defined at") <+> ppr (getSrcLoc dfun)
+ | otherwise = ptext SLIT("imported from module") <+> quotes (ppr (nameModule (idName dfun)))
\end{code}