2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcInstUtil]{Utilities for typechecking instance declarations}
6 The bits common to TcInstDcls and TcDeriv.
9 #include "HsVersions.h"
19 import HsSyn ( MonoBinds, Fake, InPat, Sig )
20 import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
21 RenamedInstancePragmas(..) )
24 import Inst ( SYN_IE(InstanceMapper) )
26 import Bag ( bagToList, Bag )
27 import Class ( GenClass, SYN_IE(ClassInstEnv),
28 classBigSig, SYN_IE(Class)
30 import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
31 import Id ( GenId, mkDictFunId, mkSysLocal, SYN_IE(Id) )
32 import MatchEnv ( nullMEnv, insertMEnv )
33 import Maybes ( MaybeErr(..), mkLookupFunDef )
34 import Name ( getSrcLoc, Name{--O only-} )
35 import PprType ( GenClass, GenType, GenTyVar )
37 import SpecEnv ( SpecEnv, nullSpecEnv, addOneToSpecEnv )
38 import SrcLoc ( SrcLoc )
39 import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys,
40 instantiateTy, matchTy, SYN_IE(ThetaType),
42 import TyVar ( GenTyVar, SYN_IE(TyVar) )
43 import Unique ( Unique )
44 import Util ( equivClasses, zipWithEqual, panic{-, pprTrace-}, Ord3(..) )
49 instance c => k (t tvs) where b
55 [TyVar] -- Type variables, tvs
56 Type -- The type at which the class is being instantiated
57 ThetaType -- inst_decl_theta: the original context, c, from the
58 -- instance declaration. It constrains (some of)
60 ThetaType -- dfun_theta: the inst_decl_theta, plus one
61 -- element for each superclass; the "Mark
62 -- Jones optimisation"
64 RenamedMonoBinds -- Bindings, b
65 SrcLoc -- Source location assoc'd with this instance's defn
66 [RenamedSig] -- User pragmas recorded for generating specialised instances
69 %************************************************************************
71 \subsection{Creating instance related Ids}
73 %************************************************************************
76 mkInstanceRelatedIds :: Name -- Name to use for the dict fun;
83 mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
84 = (dfun_id, dfun_theta)
86 (_, super_classes, _, _, _) = classBigSig clas
87 super_class_theta = super_classes `zip` repeat inst_ty
89 dfun_theta = case inst_decl_theta of
90 [] -> [] -- If inst_decl_theta is empty, then we don't
91 -- want to have any dict arguments, so that we can
92 -- expose the constant methods.
94 other -> inst_decl_theta ++ super_class_theta
95 -- Otherwise we pass the superclass dictionaries to
96 -- the dictionary function; the Mark Jones optimisation.
98 dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
100 dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty
104 %************************************************************************
106 \subsection{Converting instance info into suitable InstEnvs}
108 %************************************************************************
111 buildInstanceEnvs :: Bag InstInfo
112 -> TcM s InstanceMapper
114 buildInstanceEnvs info
116 icmp :: InstInfo -> InstInfo -> TAG_
117 (InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
120 info_by_class = equivClasses icmp (bagToList info)
122 mapTc buildInstanceEnv info_by_class `thenTc` \ inst_env_entries ->
124 class_lookup_fn = mkLookupFunDef (==) inst_env_entries nullMEnv
126 returnTc class_lookup_fn
130 buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
131 -> TcM s (Class, ClassInstEnv)
133 buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
134 = foldlTc addClassInstance
136 inst_infos `thenTc` \ class_inst_env ->
137 returnTc (clas, class_inst_env)
140 @addClassInstance@ adds the appropriate stuff to the @ClassInstEnv@
141 based on information from a single instance declaration. It complains
142 about any overlap with an existing instance.
148 -> TcM s ClassInstEnv
150 addClassInstance class_inst_env
151 (InstInfo clas inst_tyvars inst_ty _ _
153 = -- Add the instance to the class's instance environment
154 case insertMEnv matchTy class_inst_env inst_ty dfun_id of
155 Failed (ty', dfun_id') -> recoverTc (returnTc class_inst_env) $
156 dupInstFailure clas (inst_ty, src_loc)
157 (ty', getSrcLoc dfun_id');
158 Succeeded class_inst_env' -> returnTc class_inst_env'
160 {- OLD STUFF FOR CONSTANT METHODS
162 -- If there are any constant methods, then add them to
163 -- the SpecEnv of each class op (ie selector)
165 -- Example. class Foo a where { op :: Baz b => a -> b; ... }
166 -- instance Foo (p,q) where { op (x,y) = ... ; ... }
168 -- The class decl means that
169 -- op :: forall a. Foo a => forall b. Baz b => a -> b
171 -- The constant method from the instance decl will be:
172 -- op_Pair :: forall p q b. Baz b => (p,q) -> b
174 -- What we put in op's SpecEnv is
175 -- (p,q) |--> (\d::Foo (p,q) -> op_Pair p q)
177 -- Here, [p,q] are the inst_tyvars, and d is a dict whose only
178 -- purpose is to cancel with the dict to which op is applied.
180 -- NOTE THAT this correctly deals with the case where there are
181 -- constant methods even though there are type variables in the
182 -- instance declaration.
184 tcGetUnique `thenNF_Tc` \ uniq ->
186 dict = mkSysLocal SLIT("dict_tpl") uniq (mkDictTy clas inst_ty) src_loc
187 -- Slightly disgusting, but it's only a placeholder for
188 -- a dictionary to be chucked away.
190 op_spec_envs' | null const_meth_ids = op_spec_envs
191 | otherwise = zipWithEqual "add_const_meth" add_const_meth op_spec_envs const_meth_ids
193 add_const_meth (op,spec_env) meth_id
194 = (op, case addOneToSpecEnv spec_env [inst_ty] rhs of
195 Failed (tys', rhs') -> panic "TcInstDecls:add_const_meth"
196 Succeeded spec_env' -> spec_env' )
198 rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
200 returnTc (class_inst_env', op_spec_envs')
206 dupInstFailure clas info1@(ty1, locn1) info2@(ty2, locn2)
207 -- Overlapping/duplicate instances for given class; msg could be more glamourous
208 = tcAddErrCtxt ctxt $
209 failTc (\sty -> ptext SLIT("Duplicate or overlapping instance declarations"))
211 ctxt sty = sep [hsep [ptext SLIT("for"),
212 pprQuote sty $ \ sty -> ppr sty clas <+> ppr sty ty1],
213 nest 4 (sep [ptext SLIT("at") <+> ppr sty locn1,
214 ptext SLIT("and") <+> ppr sty locn2])]