buildInstanceEnvs
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( MonoBinds, Fake, InPat, Sig )
import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
RenamedInstancePragmas(..) )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
import Inst ( InstanceMapper(..) )
import Bag ( bagToList )
-import Class ( GenClass, GenClassOp, ClassInstEnv(..),
- getClassBigSig, getClassOps, getClassOpLocalType )
+import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
+ classBigSig, classOps, classOpLocalType )
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
+import Name ( getSrcLoc, Name{--O only-} )
import PprType ( GenClass, GenType, GenTyVar )
import Pretty
-import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
+import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv, addOneToSpecEnv )
import SrcLoc ( SrcLoc )
-import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTy,
- splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
+import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
+ splitForAllTy, instantiateTy, matchTy, SYN_IE(ThetaType) )
import TyVar ( GenTyVar )
import Unique ( Unique )
import Util ( equivClasses, zipWithEqual, panic )
-
import IdInfo ( noIdInfo )
--import TcPragmas ( tcDictFunPragmas, tcGenPragmas )
\end{code}
[Id] -- Constant methods (either all or none)
RenamedMonoBinds -- Bindings, b
Bool -- True <=> local instance decl
- FAST_STRING -- Name of module where this instance was
- -- defined.
+ Module -- Name of module where this instance defined
SrcLoc -- Source location assoc'd with this instance's defn
[RenamedSig] -- User pragmas recorded for generating specialised instances
\end{code}
%************************************************************************
\begin{code}
-mkInstanceRelatedIds :: Bool -> FAST_STRING
+mkInstanceRelatedIds :: Bool
+ -> SrcLoc
+ -> Module
-> RenamedInstancePragmas
-> Class
-> [TyVar]
-> [RenamedSig]
-> TcM s (Id, ThetaType, [Id])
-mkInstanceRelatedIds from_here inst_mod inst_pragmas
+mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
clas inst_tyvars inst_ty inst_decl_theta uprags
= -- MAKE THE DFUN ID
let
-}
let dfun_id_info = noIdInfo in -- For now
- returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here inst_mod dfun_id_info)
+ returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info)
) `thenTc` \ dfun_id ->
-- MAKE THE CONSTANT-METHOD IDS
returnTc (dfun_id, dfun_theta, const_meth_ids)
where
- (class_tyvar, super_classes, _, class_ops, _, _) = getClassBigSig clas
+ (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
tenv = [(class_tyvar, inst_ty)]
- super_class_theta = super_classes `zip` (repeat inst_ty)
+ super_class_theta = super_classes `zip` repeat inst_ty
mk_const_meth_id op
= tcGetUnique `thenNF_Tc` \ uniq ->
let id_info = noIdInfo -- For now
in
returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
- from_here inst_mod id_info)
+ from_here src_loc inst_mod id_info)
)
where
- op_ty = getClassOpLocalType op
+ op_ty = classOpLocalType op
meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
{- LATER
inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
= foldlTc addClassInstance
- (nullMEnv, [(op, nullSpecEnv) | op <- getClassOps clas])
+ (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
inst_infos
`thenTc` \ (class_inst_env, op_inst_envs) ->
returnTc (clas, (class_inst_env,
addClassInstance
(class_inst_env, op_spec_envs)
- (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
+ (InstInfo clas inst_tyvars inst_ty _ _
dfun_id const_meth_ids _ _ _ src_loc _)
=
-- Add the instance to the class's instance environment
case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
- Failed (ty', dfun_id') -> failTc (dupInstErr clas (inst_ty, src_loc)
- (ty', getSrcLoc dfun_id'));
+ Failed (ty', dfun_id') -> dupInstFailure clas (inst_ty, src_loc)
+ (ty', getSrcLoc dfun_id');
Succeeded class_inst_env' ->
-- If there are any constant methods, then add them to
-- a dictionary to be chucked away.
op_spec_envs' | null const_meth_ids = op_spec_envs
- | otherwise = zipWithEqual add_const_meth op_spec_envs const_meth_ids
+ | otherwise = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids
add_const_meth (op,spec_env) meth_id
= (op, case addOneToSpecEnv spec_env (inst_ty : local_tyvar_tys) rhs of
Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
Succeeded spec_env' -> spec_env' )
where
- (local_tyvars, _) = splitForAllTy (getClassOpLocalType op)
- local_tyvar_tys = map mkTyVarTy local_tyvars
+ (local_tyvars, _) = splitForAllTy (classOpLocalType op)
+ local_tyvar_tys = mkTyVarTys local_tyvars
rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
- (map mkTyVarTy inst_tyvars))
+ (mkTyVarTys inst_tyvars))
local_tyvar_tys)
in
returnTc (class_inst_env', op_spec_envs')
\end{code}
\begin{code}
-dupInstErr clas info1@(ty1, locn1) info2@(ty2, locn2) sty
+dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
-- Overlapping/duplicate instances for given class; msg could be more glamourous
- = ppHang (ppBesides [ppStr "Duplicate/overlapping instances: class `", ppr sty clas, ppStr "'"])
- 4 (showOverlap sty info1 info2)
-
-showOverlap sty (ty1,loc1) (ty2,loc2)
- = ppSep [ppBesides [ppStr "type `", ppr sty ty1, ppStr "'"],
- ppBesides [ppStr "at ", ppr sty loc1],
- ppBesides [ppStr "and ", ppr sty loc2]]
+ = tcAddErrCtxt ctxt $
+ failTc (\sty -> ppStr "Duplicate or overlapping instance declarations")
+ where
+ ctxt sty = ppHang (ppSep [ppBesides[ppStr "Class `", ppr sty clas, ppStr "'"],
+ ppBesides[ppStr "type `", ppr sty ty1, ppStr "'"]])
+ 4 (ppSep [ppBesides [ppStr "at ", ppr sty locn1],
+ ppBesides [ppStr "and ", ppr sty locn2]])
\end{code}
projects / ghc-hetmet.git / blobdiff