buildInstanceEnvs
) where
-import Ubiq
+IMP_Ubiq()
import HsSyn ( MonoBinds, Fake, InPat, Sig )
-import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..),
+import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
RenamedInstancePragmas(..) )
-import TcMonad
-import Inst ( InstanceMapper(..) )
+import TcMonad hiding ( rnMtoTcM )
+import Inst ( SYN_IE(InstanceMapper) )
import Bag ( bagToList )
-import Class ( GenClass, GenClassOp, ClassInstEnv(..),
- classBigSig, classOps, classOpLocalType )
+import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
+ classBigSig, classOps, classOpLocalType,
+ SYN_IE(ClassOp)
+ )
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
-import Name ( getSrcLoc )
+import Name ( getSrcLoc, Name{--O only-} )
import PprType ( GenClass, GenType, GenTyVar )
import Pretty
-import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv )
+import SpecEnv ( SpecEnv, nullSpecEnv, addOneToSpecEnv )
import SrcLoc ( SrcLoc )
import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
- splitForAllTy, instantiateTy, matchTy, ThetaType(..) )
+ splitForAllTy, instantiateTy, matchTy, SYN_IE(ThetaType) )
import TyVar ( GenTyVar )
import Unique ( Unique )
-import Util ( equivClasses, zipWithEqual, panic )
-
+import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-} )
+--import PprStyle
import IdInfo ( noIdInfo )
--import TcPragmas ( tcDictFunPragmas, tcGenPragmas )
[Id] -- Constant methods (either all or none)
RenamedMonoBinds -- Bindings, b
Bool -- True <=> local instance decl
- (Maybe Module) -- Name of module where this instance defined; Nothing => Prelude
+ 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
- -> Maybe Module
+ -> 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 ->
+-- pprTrace "DFUN: " (ppr PprDebug dfun_id) $
+
-- MAKE THE CONSTANT-METHOD IDS
-- if there are no type variables involved
- (if not (null inst_decl_theta)
+ (if (null inst_decl_theta)
then
- returnTc []
- else
mapTc mk_const_meth_id class_ops
+ else
+ returnTc []
) `thenTc` \ const_meth_ids ->
returnTc (dfun_id, dfun_theta, const_meth_ids)
(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 = classOpLocalType op
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
-- the SpecEnv of each class op (ie selector)
--
- -- Example. class Foo a where { op :: Baz b => a -> b }
- -- instance Foo (p,q) where { op (x,y) = ... }
+ -- Example. class Foo a where { op :: Baz b => a -> b; ... }
+ -- instance Foo (p,q) where { op (x,y) = ... ; ... }
+ --
+ -- The class decl means that
+ -- op :: forall a. Foo a => forall b. Baz b => a -> b
--
-- The constant method from the instance decl will be:
-- op_Pair :: forall p q b. Baz b => (p,q) -> b
--
-- What we put in op's SpecEnv is
- -- (p,q) b |--> (\d::Foo (p,q) -> op_Pair p q b)
+ -- (p,q) |--> (\d::Foo (p,q) -> op_Pair p q)
--
-- Here, [p,q] are the inst_tyvars, and d is a dict whose only
-- purpose is to cancel with the dict to which op is applied.
-- 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
+ = (op, case addOneToSpecEnv spec_env [inst_ty] rhs of
Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
Succeeded spec_env' -> spec_env' )
where
- (local_tyvars, _) = splitForAllTy (classOpLocalType op)
- local_tyvar_tys = mkTyVarTys local_tyvars
- rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
- (mkTyVarTys inst_tyvars))
- local_tyvar_tys)
+ rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
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