import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
RenamedInstancePragmas(..) )
-import TcEnv ( tcAddImportedIdInfo )
import TcMonad
import Inst ( SYN_IE(InstanceMapper) )
import Bag ( bagToList, Bag )
-import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv),
- classBigSig, classOps, classOpLocalType,
- SYN_IE(ClassOp), SYN_IE(Class)
+import Class ( GenClass, SYN_IE(ClassInstEnv),
+ classBigSig, SYN_IE(Class)
)
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
-import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, SYN_IE(Id) )
+import Id ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, Name{--O only-} )
-import PprType ( GenClass, GenType, GenTyVar )
+import PprType ( GenClass, GenType, GenTyVar, pprParendType )
import Pretty
import SpecEnv ( SpecEnv, nullSpecEnv, addOneToSpecEnv )
import SrcLoc ( SrcLoc )
import Unique ( Unique )
import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
-#if __GLASGOW_HASKELL__ >= 202
import Outputable
-#endif
\end{code}
instance c => k (t tvs) where b
-> [TyVar]
-> Type
-> ThetaType
- -> NF_TcM s (Id, ThetaType)
+ -> (Id, ThetaType)
mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
- = tcAddImportedIdInfo dfun_id `thenNF_Tc` \ new_dfun_id ->
- returnNF_Tc (new_dfun_id, dfun_theta)
+ = (dfun_id, dfun_theta)
where
- (_, super_classes, _, _, _, _) = classBigSig clas
+ (_, super_classes, _, _, _) = classBigSig clas
super_class_theta = super_classes `zip` repeat inst_ty
dfun_theta = case inst_decl_theta of
in
mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
let
- class_lookup_fn = mkLookupFunDef (==) inst_env_entries
- (nullMEnv, \ o -> nullSpecEnv)
+ class_lookup_fn = mkLookupFunDef (==) inst_env_entries nullMEnv
in
returnTc class_lookup_fn
\end{code}
\begin{code}
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
- -> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
+ -> TcM s (Class, ClassInstEnv)
buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
= foldlTc addClassInstance
- (nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
- inst_infos
- `thenTc` \ (class_inst_env, op_inst_envs) ->
- returnTc (clas, (class_inst_env,
- mkLookupFunDef (==) op_inst_envs
- (panic "buildInstanceEnv")))
+ nullMEnv
+ inst_infos `thenTc` \ class_inst_env ->
+ returnTc (clas, class_inst_env)
\end{code}
@addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
\begin{code}
addClassInstance
- :: (ClassInstEnv, [(ClassOp,SpecEnv)])
+ :: ClassInstEnv
-> InstInfo
- -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
+ -> TcM s ClassInstEnv
-addClassInstance
- input_stuff@(class_inst_env, op_spec_envs)
+addClassInstance class_inst_env
(InstInfo clas inst_tyvars inst_ty _ _
dfun_id _ src_loc _)
- =
-
--- We only add specialised/overlapped instances
--- if we are specialising the overloading
--- ToDo ... This causes getConstMethodId errors!
---
--- if not (is_plain_instance inst_ty) && not opt_SpecialiseOverloaded
--- then
--- -- Drop this specialised/overlapped instance
--- returnTc (class_inst_env, op_spec_envs)
--- else
-
- -- Add the instance to the class's instance environment
- case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
- Failed (ty', dfun_id') -> recoverTc (returnTc input_stuff) $
+ = -- Add the instance to the class's instance environment
+ case insertMEnv matchTy class_inst_env inst_ty dfun_id of
+ Failed (ty', dfun_id') -> recoverTc (returnTc class_inst_env) $
dupInstFailure clas (inst_ty, src_loc)
(ty', getSrcLoc dfun_id');
- Succeeded class_inst_env' ->
-
- returnTc (class_inst_env', op_spec_envs)
+ Succeeded class_inst_env' -> returnTc class_inst_env'
{- OLD STUFF FOR CONSTANT METHODS
returnTc (class_inst_env', op_spec_envs')
END OF OLD STUFF -}
- }
\end{code}
\begin{code}
= tcAddErrCtxt ctxt $
failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
where
- ctxt sty = hang (sep [ptext SLIT("Class"), ppr sty clas,
- ptext SLIT("type"), ppr sty ty1])
- 4 (sep [hcat [ptext SLIT("at "), ppr sty locn1],
- hcat [ptext SLIT("and "), ppr sty locn2]])
+ ctxt sty = sep [hsep [ptext SLIT("for"),
+ pprQuote sty $ \ sty -> ppr sty clas <+> pprParendType sty ty1],
+ nest 4 (sep [ptext SLIT("at") <+> ppr sty locn1,
+ ptext SLIT("and") <+> ppr sty locn2])]
\end{code}