Major patch to add -fwarn-redundant-constraints
[ghc.git] / compiler / typecheck / TcClassDcl.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 Typechecking class declarations
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module TcClassDcl ( tcClassSigs, tcClassDecl2,
12 findMethodBind, instantiateMethod,
13 tcClassMinimalDef,
14 HsSigFun, mkHsSigFun, lookupHsSig, emptyHsSigs,
15 tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr
16 ) where
17
18 #include "HsVersions.h"
19
20 import HsSyn
21 import TcEnv
22 import TcPat( addInlinePrags )
23 import TcEvidence( idHsWrapper )
24 import TcBinds
25 import TcUnify
26 import TcHsType
27 import TcMType
28 import Type ( getClassPredTys_maybe )
29 import TcType
30 import TcRnMonad
31 import BuildTyCl( TcMethInfo )
32 import Class
33 import Id
34 import Name
35 import NameEnv
36 import NameSet
37 import Var
38 import Outputable
39 import SrcLoc
40 import Maybes
41 import BasicTypes
42 import Bag
43 import FastString
44 import BooleanFormula
45 import Util
46
47 import Control.Monad
48
49 {-
50 Dictionary handling
51 ~~~~~~~~~~~~~~~~~~~
52 Every class implicitly declares a new data type, corresponding to dictionaries
53 of that class. So, for example:
54
55 class (D a) => C a where
56 op1 :: a -> a
57 op2 :: forall b. Ord b => a -> b -> b
58
59 would implicitly declare
60
61 data CDict a = CDict (D a)
62 (a -> a)
63 (forall b. Ord b => a -> b -> b)
64
65 (We could use a record decl, but that means changing more of the existing apparatus.
66 One step at at time!)
67
68 For classes with just one superclass+method, we use a newtype decl instead:
69
70 class C a where
71 op :: forallb. a -> b -> b
72
73 generates
74
75 newtype CDict a = CDict (forall b. a -> b -> b)
76
77 Now DictTy in Type is just a form of type synomym:
78 DictTy c t = TyConTy CDict `AppTy` t
79
80 Death to "ExpandingDicts".
81
82
83 ************************************************************************
84 * *
85 Type-checking the class op signatures
86 * *
87 ************************************************************************
88 -}
89
90 tcClassSigs :: Name -- Name of the class
91 -> [LSig Name]
92 -> LHsBinds Name
93 -> TcM ([TcMethInfo], -- Exactly one for each method
94 NameEnv Type) -- Types of the generic-default methods
95 tcClassSigs clas sigs def_methods
96 = do { traceTc "tcClassSigs 1" (ppr clas)
97
98 ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
99 ; let gen_dm_env = mkNameEnv gen_dm_prs
100
101 ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
102
103 ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
104 ; sequence_ [ failWithTc (badMethodErr clas n)
105 | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
106 -- Value binding for non class-method (ie no TypeSig)
107
108 ; sequence_ [ failWithTc (badGenericMethod clas n)
109 | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
110 -- Generic signature without value binding
111
112 ; traceTc "tcClassSigs 2" (ppr clas)
113 ; return (op_info, gen_dm_env) }
114 where
115 vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty _) <- sigs]
116 gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs]
117 dm_bind_names :: [Name] -- These ones have a value binding in the class decl
118 dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
119
120 tc_sig genop_env (op_names, op_hs_ty)
121 = do { traceTc "ClsSig 1" (ppr op_names)
122 ; op_ty <- tcClassSigType op_hs_ty -- Class tyvars already in scope
123 ; traceTc "ClsSig 2" (ppr op_names)
124 ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] }
125 where
126 f nm | nm `elemNameEnv` genop_env = GenericDM
127 | nm `elem` dm_bind_names = VanillaDM
128 | otherwise = NoDM
129
130 tc_gen_sig (op_names, gen_hs_ty)
131 = do { gen_op_ty <- tcClassSigType gen_hs_ty
132 ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] }
133
134 {-
135 ************************************************************************
136 * *
137 Class Declarations
138 * *
139 ************************************************************************
140 -}
141
142 tcClassDecl2 :: LTyClDecl Name -- The class declaration
143 -> TcM (LHsBinds Id)
144
145 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
146 tcdMeths = default_binds}))
147 = recoverM (return emptyLHsBinds) $
148 setSrcSpan loc $
149 do { clas <- tcLookupLocatedClass class_name
150
151 -- We make a separate binding for each default method.
152 -- At one time I used a single AbsBinds for all of them, thus
153 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
154 -- But that desugars into
155 -- ds = \d -> (..., ..., ...)
156 -- dm1 = \d -> case ds d of (a,b,c) -> a
157 -- And since ds is big, it doesn't get inlined, so we don't get good
158 -- default methods. Better to make separate AbsBinds for each
159 ; let (tyvars, _, _, op_items) = classBigSig clas
160 prag_fn = mkPragFun sigs default_binds
161 sig_fn = mkHsSigFun sigs
162 clas_tyvars = snd (tcSuperSkolTyVars tyvars)
163 pred = mkClassPred clas (mkTyVarTys clas_tyvars)
164 ; this_dict <- newEvVar pred
165
166 ; let tc_item (sel_id, dm_info)
167 = case dm_info of
168 DefMeth dm_name -> tc_dm sel_id dm_name False
169 GenDefMeth dm_name -> tc_dm sel_id dm_name True
170 -- For GenDefMeth, warn if the user specifies a signature
171 -- with redundant constraints; but not for DefMeth, where
172 -- the default method may well be 'error' or something
173 NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id))
174 (prag_fn (idName sel_id))
175 ; return emptyBag }
176 tc_dm = tcDefMeth clas clas_tyvars this_dict
177 default_binds sig_fn prag_fn
178
179 ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
180 mapM tc_item op_items
181
182 ; return (unionManyBags dm_binds) }
183
184 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
185
186 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
187 -> HsSigFun -> PragFun -> Id -> Name -> Bool
188 -> TcM (LHsBinds TcId)
189 -- Generate code for polymorphic default methods only (hence DefMeth)
190 -- (Generic default methods have turned into instance decls by now.)
191 -- This is incompatible with Hugs, which expects a polymorphic
192 -- default method for every class op, regardless of whether or not
193 -- the programmer supplied an explicit default decl for the class.
194 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
195 tcDefMeth clas tyvars this_dict binds_in
196 hs_sig_fn prag_fn sel_id dm_name warn_redundant
197 | Just (L bind_loc dm_bind, bndr_loc) <- findMethodBind sel_name binds_in
198 -- First look up the default method -- it should be there!
199 = do { global_dm_id <- tcLookupId dm_name
200 ; global_dm_id <- addInlinePrags global_dm_id prags
201 ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
202 -- Base the local_dm_name on the selector name, because
203 -- type errors from tcInstanceMethodBody come from here
204
205 ; spec_prags <- tcSpecPrags global_dm_id prags
206 ; warnTc (not (null spec_prags))
207 (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
208 <+> quotes (ppr sel_name))
209
210 ; let hs_ty = lookupHsSig hs_sig_fn sel_name
211 `orElse` pprPanic "tc_dm" (ppr sel_name)
212 -- We need the HsType so that we can bring the right
213 -- type variables into scope
214 --
215 -- Eg. class C a where
216 -- op :: forall b. Eq b => a -> [b] -> a
217 -- gen_op :: a -> a
218 -- generic gen_op :: D a => a -> a
219 -- The "local_dm_ty" is precisely the type in the above
220 -- type signatures, ie with no "forall a. C a =>" prefix
221
222 local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
223
224 lm_bind = dm_bind { fun_id = L bind_loc local_dm_name }
225 -- Substitute the local_meth_name for the binder
226 -- NB: the binding is always a FunBind
227
228 ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
229 ; let local_dm_sig' = local_dm_sig { sig_warn_redundant = warn_redundant }
230 ; (ev_binds, (tc_bind, _, _))
231 <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
232 tcPolyCheck NonRecursive no_prag_fn local_dm_sig'
233 (L bind_loc lm_bind)
234
235 ; let export = ABE { abe_poly = global_dm_id
236 , abe_mono = sig_id local_dm_sig'
237 , abe_wrap = idHsWrapper
238 , abe_prags = IsDefaultMethod }
239 full_bind = AbsBinds { abs_tvs = tyvars
240 , abs_ev_vars = [this_dict]
241 , abs_exports = [export]
242 , abs_ev_binds = [ev_binds]
243 , abs_binds = tc_bind }
244
245 ; return (unitBag (L bind_loc full_bind)) }
246
247 | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
248 where
249 sel_name = idName sel_id
250 prags = prag_fn sel_name
251 no_prag_fn _ = [] -- No pragmas for local_meth_id;
252 -- they are all for meth_id
253
254 ---------------
255 tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
256 tcClassMinimalDef _clas sigs op_info
257 = case findMinimalDef sigs of
258 Nothing -> return defMindef
259 Just mindef -> do
260 -- Warn if the given mindef does not imply the default one
261 -- That is, the given mindef should at least ensure that the
262 -- class ops without default methods are required, since we
263 -- have no way to fill them in otherwise
264 whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
265 (\bf -> addWarnTc (warningMinimalDefIncomplete bf))
266 return mindef
267 where
268 -- By default require all methods without a default
269 -- implementation whose names don't start with '_'
270 defMindef :: ClassMinimalDef
271 defMindef = mkAnd [ mkVar name
272 | (name, NoDM, _) <- op_info
273 , not (startsWithUnderscore (getOccName name)) ]
274
275 instantiateMethod :: Class -> Id -> [TcType] -> TcType
276 -- Take a class operation, say
277 -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
278 -- Instantiate it at [ty1,ty2]
279 -- Return the "local method type":
280 -- forall c. Ix x => (ty2,c) -> ty1
281 instantiateMethod clas sel_id inst_tys
282 = ASSERT( ok_first_pred ) local_meth_ty
283 where
284 (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
285 rho_ty = ASSERT( length sel_tyvars == length inst_tys )
286 substTyWith sel_tyvars inst_tys sel_rho
287
288 (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
289 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
290
291 ok_first_pred = case getClassPredTys_maybe first_pred of
292 Just (clas1, _tys) -> clas == clas1
293 Nothing -> False
294 -- The first predicate should be of form (C a b)
295 -- where C is the class in question
296
297
298 ---------------------------
299 type HsSigFun = NameEnv (LHsType Name)
300
301 emptyHsSigs :: HsSigFun
302 emptyHsSigs = emptyNameEnv
303
304 mkHsSigFun :: [LSig Name] -> HsSigFun
305 mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
306 | L _ (TypeSig ns hs_ty _) <- sigs
307 , L _ n <- ns ]
308
309 lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
310 lookupHsSig = lookupNameEnv
311
312 ---------------------------
313 findMethodBind :: Name -- Selector name
314 -> LHsBinds Name -- A group of bindings
315 -> Maybe (LHsBind Name, SrcSpan)
316 -- Returns the binding, and the binding
317 -- site of the method binder
318 findMethodBind sel_name binds
319 = foldlBag mplus Nothing (mapBag f binds)
320 where
321 f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
322 | op_name == sel_name
323 = Just (bind, bndr_loc)
324 f _other = Nothing
325
326 ---------------------------
327 findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
328 findMinimalDef = firstJusts . map toMinimalDef
329 where
330 toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
331 toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf)
332 toMinimalDef _ = Nothing
333
334 {-
335 Note [Polymorphic methods]
336 ~~~~~~~~~~~~~~~~~~~~~~~~~~
337 Consider
338 class Foo a where
339 op :: forall b. Ord b => a -> b -> b -> b
340 instance Foo c => Foo [c] where
341 op = e
342
343 When typechecking the binding 'op = e', we'll have a meth_id for op
344 whose type is
345 op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
346
347 So tcPolyBinds must be capable of dealing with nested polytypes;
348 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
349
350 Note [Silly default-method bind]
351 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
352 When we pass the default method binding to the type checker, it must
353 look like op2 = e
354 not $dmop2 = e
355 otherwise the "$dm" stuff comes out error messages. But we want the
356 "$dm" to come out in the interface file. So we typecheck the former,
357 and wrap it in a let, thus
358 $dmop2 = let op2 = e in op2
359 This makes the error messages right.
360
361
362 ************************************************************************
363 * *
364 Error messages
365 * *
366 ************************************************************************
367 -}
368
369 tcMkDeclCtxt :: TyClDecl Name -> SDoc
370 tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
371 ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
372
373 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
374 tcAddDeclCtxt decl thing_inside
375 = addErrCtxt (tcMkDeclCtxt decl) thing_inside
376
377 badMethodErr :: Outputable a => a -> Name -> SDoc
378 badMethodErr clas op
379 = hsep [ptext (sLit "Class"), quotes (ppr clas),
380 ptext (sLit "does not have a method"), quotes (ppr op)]
381
382 badGenericMethod :: Outputable a => a -> Name -> SDoc
383 badGenericMethod clas op
384 = hsep [ptext (sLit "Class"), quotes (ppr clas),
385 ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
386
387 {-
388 badGenericInstanceType :: LHsBinds Name -> SDoc
389 badGenericInstanceType binds
390 = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
391 nest 2 (ppr binds)]
392
393 missingGenericInstances :: [Name] -> SDoc
394 missingGenericInstances missing
395 = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
396
397 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
398 dupGenericInsts tc_inst_infos
399 = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
400 nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
401 ptext (sLit "All the type patterns for a generic type constructor must be identical")
402 ]
403 where
404 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
405 -}
406 badDmPrag :: Id -> Sig Name -> TcM ()
407 badDmPrag sel_id prag
408 = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
409 <+> quotes (ppr sel_id)
410 <+> ptext (sLit "lacks an accompanying binding"))
411
412 warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
413 warningMinimalDefIncomplete mindef
414 = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
415 , nest 2 (pprBooleanFormulaNice mindef)
416 , ptext (sLit "but there is no default implementation.") ]