X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcInstUtil.lhs;h=38b8f2fb41034190e33bac527b54999a06f127a0;hb=f7ecf7234c224489be8a5e63fced903b655d92ee;hp=c8180abecaa6678745bc6477cef3fe55a9775283;hpb=ca5a4a480d10d61e5b7a52eb4d556e8b8c33e69d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index c8180ab..38b8f2f 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -14,18 +14,20 @@ module TcInstUtil ( 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 hiding ( rnMtoTcM ) -import Inst ( InstanceMapper(..) ) +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 ) @@ -33,15 +35,14 @@ import Maybes ( MaybeErr(..), mkLookupFunDef ) 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 IdInfo ( noIdInfo ) --import TcPragmas ( tcDictFunPragmas, tcGenPragmas ) \end{code} @@ -64,7 +65,7 @@ data InstInfo [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} @@ -77,7 +78,8 @@ data InstInfo \begin{code} mkInstanceRelatedIds :: Bool - -> Maybe Module + -> SrcLoc + -> Module -> RenamedInstancePragmas -> Class -> [TyVar] @@ -86,7 +88,7 @@ mkInstanceRelatedIds :: Bool -> [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 @@ -114,16 +116,16 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas -} 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 -- 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) @@ -131,7 +133,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas (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 -> @@ -147,7 +149,7 @@ mkInstanceRelatedIds from_here inst_mod inst_pragmas 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 @@ -219,7 +221,7 @@ addClassInstance 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 _) = @@ -235,21 +237,24 @@ addClassInstance -- 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. @@ -265,31 +270,27 @@ addClassInstance -- 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}