- :: (ClassInstEnv, [(ClassOp,SpecEnv)])
- -> InstInfo
- -> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
-
-addClassInstance
- (class_inst_env, op_spec_envs)
- (InstInfo clas inst_tyvars inst_ty _ _
- 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 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) |--> (\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.
- --
- -- 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] rhs of
- Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
- Succeeded spec_env' -> spec_env' )
- where
- rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
- 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'