2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Typechecking class declarations
9 module TcClassDcl ( tcClassSigs, tcClassDecl2,
10 findMethodBind, instantiateMethod, tcInstanceMethodBody,
12 tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
15 #include "HsVersions.h"
19 import TcPat( addInlinePrags )
26 import BuildTyCl( TcMethInfo )
46 Every class implicitly declares a new data type, corresponding to dictionaries
47 of that class. So, for example:
49 class (D a) => C a where
51 op2 :: forall b. Ord b => a -> b -> b
53 would implicitly declare
55 data CDict a = CDict (D a)
57 (forall b. Ord b => a -> b -> b)
59 (We could use a record decl, but that means changing more of the existing apparatus.
62 For classes with just one superclass+method, we use a newtype decl instead:
65 op :: forallb. a -> b -> b
69 newtype CDict a = CDict (forall b. a -> b -> b)
71 Now DictTy in Type is just a form of type synomym:
72 DictTy c t = TyConTy CDict `AppTy` t
74 Death to "ExpandingDicts".
77 %************************************************************************
79 Type-checking the class op signatures
81 %************************************************************************
84 tcClassSigs :: Name -- Name of the class
87 -> TcM [TcMethInfo] -- One for each method
89 tcClassSigs clas sigs def_methods
90 = do { -- Check that all def_methods are in the class
91 ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
92 ; let op_names = [ n | (n,_,_) <- op_info ]
94 ; sequence_ [ failWithTc (badMethodErr clas n)
95 | n <- dm_bind_names, not (n `elem` op_names) ]
96 -- Value binding for non class-method (ie no TypeSig)
98 ; sequence_ [ failWithTc (badGenericMethod clas n)
99 | n <- genop_names, not (n `elem` dm_bind_names) ]
100 -- Generic signature without value binding
104 dm_bind_names :: [Name] -- These ones have a value binding in the class decl
105 dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
107 genop_names :: [Name] -- These ones have a generic signature
108 genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
110 tc_sig (TypeSig (L _ op_name) op_hs_ty)
111 = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
112 ; let dm | op_name `elem` genop_names = GenericDM
113 | op_name `elem` dm_bind_names = VanillaDM
115 ; return (op_name, dm, op_ty) }
116 tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
120 %************************************************************************
124 %************************************************************************
127 tcClassDecl2 :: LTyClDecl Name -- The class declaration
130 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
131 tcdMeths = default_binds}))
132 = recoverM (return emptyLHsBinds) $
134 do { clas <- tcLookupLocatedClass class_name
136 -- We make a separate binding for each default method.
137 -- At one time I used a single AbsBinds for all of them, thus
138 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
139 -- But that desugars into
140 -- ds = \d -> (..., ..., ...)
141 -- dm1 = \d -> case ds d of (a,b,c) -> a
142 -- And since ds is big, it doesn't get inlined, so we don't get good
143 -- default methods. Better to make separate AbsBinds for each
145 (tyvars, _, _, op_items) = classBigSig clas
146 prag_fn = mkPragFun sigs default_binds
147 sig_fn = mkSigFun sigs
148 clas_tyvars = tcSuperSkolTyVars tyvars
149 pred = mkClassPred clas (mkTyVarTys clas_tyvars)
150 ; this_dict <- newEvVar pred
152 ; traceTc "TIM2" (ppr sigs)
153 ; let tc_dm = tcDefMeth clas clas_tyvars
154 this_dict default_binds sigs
157 ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
160 ; return (unionManyBags dm_binds) }
162 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
164 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
165 -> SigFun -> PragFun -> ClassOpItem
166 -> TcM (LHsBinds TcId)
167 -- Generate code for polymorphic default methods only (hence DefMeth)
168 -- (Generic default methods have turned into instance decls by now.)
169 -- This is incompatible with Hugs, which expects a polymorphic
170 -- default method for every class op, regardless of whether or not
171 -- the programmer supplied an explicit default decl for the class.
172 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
173 tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
175 NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
177 DefMeth dm_name -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars))
178 GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name)
179 ; tc_dm dm_name tau }
180 -- In the case of a generic default, we have to get the type from the signature
181 -- Otherwise we can get it by instantiating the method selector
183 sel_name = idName sel_id
184 prags = prag_fn sel_name
185 dm_sig_fn _ = sig_fn sel_name
186 dm_bind = findMethodBind sel_name binds_in
187 `orElse` pprPanic "tcDefMeth" (ppr sel_id)
189 -- Eg. class C a where
190 -- op :: forall b. Eq b => a -> [b] -> a
192 -- generic gen_op :: D a => a -> a
193 -- The "local_dm_ty" is precisely the type in the above
194 -- type signatures, ie with no "forall a. C a =>" prefix
196 tc_dm dm_name local_dm_ty
197 = do { local_dm_name <- newLocalName sel_name
198 -- Base the local_dm_name on the selector name, because
199 -- type errors from tcInstanceMethodBody come from here
201 ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
202 dm_id = mkExportedLocalId dm_name dm_ty
203 local_dm_id = mkLocalId local_dm_name local_dm_ty
205 ; dm_id_w_inline <- addInlinePrags dm_id prags
206 ; spec_prags <- tcSpecPrags dm_id prags
208 ; warnTc (not (null spec_prags))
209 (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
210 <+> quotes (ppr sel_name))
212 ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
213 dm_id_w_inline local_dm_id dm_sig_fn
214 IsDefaultMethod dm_bind
216 ; return (unitBag tc_bind) }
218 tc_genop_ty :: LHsType Name -> TcM Type
220 = setSrcSpan (getLoc hs_ty) $
221 do { tau <- tcHsKindedType hs_ty
222 ; checkValidType (FunSigCtxt sel_name) tau
225 findGenericSig :: [LSig Name] -> Name -> LHsType Name
226 -- Find the 'generic op :: ty' signature among the sigs
227 -- If dm_info is GenDefMeth, the corresponding signature
228 -- should jolly well exist! Hence the panic
229 findGenericSig sigs sel_name
230 = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
233 _ -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
236 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
238 -> SigFun -> TcSpecPrags -> LHsBind Name
240 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
241 meth_id local_meth_id
244 = do { -- Typecheck the binding, first extending the envt
245 -- so that when tcInstSig looks up the local_meth_id to find
246 -- its signature, we'll find it in the environment
247 let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
248 -- Substitute the local_meth_name for the binder
249 -- NB: the binding is always a FunBind
250 ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
251 ; (ev_binds, (tc_bind, _))
252 <- checkConstraints skol_info tyvars dfun_ev_vars $
253 tcExtendIdEnv [local_meth_id] $
254 tcPolyBinds TopLevel meth_sig_fn no_prag_fn
255 NonRecursive NonRecursive
258 ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
259 , abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
260 , abs_ev_binds = ev_binds
261 , abs_binds = tc_bind }
263 ; return (L loc full_bind) }
265 no_prag_fn _ = [] -- No pragmas for local_meth_id;
266 -- they are all for meth_id
270 instantiateMethod :: Class -> Id -> [TcType] -> TcType
271 -- Take a class operation, say
272 -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
273 -- Instantiate it at [ty1,ty2]
274 -- Return the "local method type":
275 -- forall c. Ix x => (ty2,c) -> ty1
276 instantiateMethod clas sel_id inst_tys
277 = ASSERT( ok_first_pred ) local_meth_ty
279 (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
280 rho_ty = ASSERT( length sel_tyvars == length inst_tys )
281 substTyWith sel_tyvars inst_tys sel_rho
283 (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
284 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
286 ok_first_pred = case getClassPredTys_maybe first_pred of
287 Just (clas1, _tys) -> clas == clas1
289 -- The first predicate should be of form (C a b)
290 -- where C is the class in question
293 ---------------------------
294 findMethodBind :: Name -- Selector name
295 -> LHsBinds Name -- A group of bindings
296 -> Maybe (LHsBind Name) -- The binding
297 findMethodBind sel_name binds
298 = foldlBag mplus Nothing (mapBag f binds)
300 f bind@(L _ (FunBind { fun_id = L _ op_name }))
301 | op_name == sel_name
306 Note [Polymorphic methods]
307 ~~~~~~~~~~~~~~~~~~~~~~~~~~
310 op :: forall b. Ord b => a -> b -> b -> b
311 instance Foo c => Foo [c] where
314 When typechecking the binding 'op = e', we'll have a meth_id for op
316 op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
318 So tcPolyBinds must be capable of dealing with nested polytypes;
319 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
321 Note [Silly default-method bind]
322 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
323 When we pass the default method binding to the type checker, it must
326 otherwise the "$dm" stuff comes out error messages. But we want the
327 "$dm" to come out in the interface file. So we typecheck the former,
328 and wrap it in a let, thus
329 $dmop2 = let op2 = e in op2
330 This makes the error messages right.
333 %************************************************************************
335 Extracting generic instance declaration from class declarations
337 %************************************************************************
339 @getGenericInstances@ extracts the generic instance declarations from a class
340 declaration. For exmaple
345 op{ x+y } (Inl v) = ...
346 op{ x+y } (Inr v) = ...
347 op{ x*y } (v :*: w) = ...
350 gives rise to the instance declarations
352 instance C (x+y) where
356 instance C (x*y) where
363 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
364 mkGenericDefMethBind clas inst_tys sel_id dm_name
365 = -- A generic default method
366 -- If the method is defined generically, we only have to call the
368 do { dflags <- getDOpts
369 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
370 (vcat [ppr clas <+> ppr inst_tys,
371 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
373 ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
374 [mkSimpleMatch [] rhs]) }
376 rhs = nlHsVar dm_name
379 %************************************************************************
383 %************************************************************************
386 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
387 tcAddDeclCtxt decl thing_inside
388 = addErrCtxt ctxt thing_inside
390 thing | isClassDecl decl = "class"
391 | isTypeDecl decl = "type synonym" ++ maybeInst
392 | isDataDecl decl = if tcdND decl == NewType
393 then "newtype" ++ maybeInst
394 else "data type" ++ maybeInst
395 | isFamilyDecl decl = "family"
396 | otherwise = panic "tcAddDeclCtxt/thing"
398 maybeInst | isFamInstDecl decl = " instance"
401 ctxt = hsep [ptext (sLit "In the"), text thing,
402 ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
404 badMethodErr :: Outputable a => a -> Name -> SDoc
406 = hsep [ptext (sLit "Class"), quotes (ppr clas),
407 ptext (sLit "does not have a method"), quotes (ppr op)]
409 badGenericMethod :: Outputable a => a -> Name -> SDoc
410 badGenericMethod clas op
411 = hsep [ptext (sLit "Class"), quotes (ppr clas),
412 ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
414 badATErr :: Class -> Name -> SDoc
416 = hsep [ptext (sLit "Class"), quotes (ppr clas),
417 ptext (sLit "does not have an associated type"), quotes (ppr at)]
419 omittedATWarn :: Name -> SDoc
421 = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
423 badGenericInstanceType :: LHsBinds Name -> SDoc
424 badGenericInstanceType binds
425 = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
428 missingGenericInstances :: [Name] -> SDoc
429 missingGenericInstances missing
430 = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
432 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
433 dupGenericInsts tc_inst_infos
434 = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
435 nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
436 ptext (sLit "All the type patterns for a generic type constructor must be identical")
439 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
441 badDmPrag :: Id -> Sig Name -> TcM ()
442 badDmPrag sel_id prag
443 = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
444 <+> quotes (ppr sel_id)
445 <+> ptext (sLit "lacks an accompanying binding"))