- :: (ClassInstEnv, [(ClassOp,SpecEnv)])
- -> InstInfo
- -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
-
-addClassInstance
- (class_inst_env, op_spec_envs)
- (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta
- dfun_id const_meth_ids _ _ _ 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') -> 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) = ... }
- --
- -- 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)
- --
- -- 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.
- --
- -- NOTE THAT this correctly deals with the case where there are
- -- constant methods even though there are type variables in the
- -- instance declaration.
-
- tcGetUnique `thenNF_Tc` \ uniq ->
- let
- dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
- -- Slightly disgusting, but it's only a placeholder for
- -- a dictionary to be chucked away.
-
- op_spec_envs' | null const_meth_ids = op_spec_envs
- | 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 (classOpLocalType op)
- local_tyvar_tys = mkTyVarTys local_tyvars
- rhs = mkValLam [dict] (mkTyApp (mkTyApp (Var meth_id)
- (mkTyVarTys inst_tyvars))
- local_tyvar_tys)
- in
- returnTc (class_inst_env', op_spec_envs')
- }
+ :: InstInfo
+ -> ClassInstEnv
+ -> NF_TcM s ClassInstEnv
+
+addClassInstance
+ (InstInfo clas inst_tyvars inst_tys _ _
+ dfun_id _ src_loc _)
+ class_inst_env
+ = -- Add the instance to the class's instance environment
+ case addToSpecEnv 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'))
+ `thenNF_Tc_`
+ returnNF_Tc class_inst_env
+
+ Succeeded class_inst_env' -> returnNF_Tc class_inst_env'