719c2f3eb53c6a0dea511f5aa997afe79c81c4b1
[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, tcInstanceMethodBody,
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( HsWrapper, 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
160 (tyvars, _, _, op_items) = classBigSig clas
161 prag_fn = mkPragFun sigs default_binds
162 sig_fn = mkHsSigFun sigs
163 clas_tyvars = snd (tcSuperSkolTyVars tyvars)
164 pred = mkClassPred clas (mkTyVarTys clas_tyvars)
165 ; this_dict <- newEvVar pred
166
167 ; traceTc "TIM2" (ppr sigs)
168 ; let tc_dm = tcDefMeth clas clas_tyvars
169 this_dict default_binds
170 sig_fn prag_fn
171
172 ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
173 mapM tc_dm op_items
174
175 ; return (unionManyBags dm_binds) }
176
177 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
178
179 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
180 -> HsSigFun -> PragFun -> ClassOpItem
181 -> TcM (LHsBinds TcId)
182 -- Generate code for polymorphic default methods only (hence DefMeth)
183 -- (Generic default methods have turned into instance decls by now.)
184 -- This is incompatible with Hugs, which expects a polymorphic
185 -- default method for every class op, regardless of whether or not
186 -- the programmer supplied an explicit default decl for the class.
187 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
188 tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn (sel_id, dm_info)
189 = case dm_info of
190 NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
191 ; return emptyBag }
192 DefMeth dm_name -> tc_dm dm_name
193 GenDefMeth dm_name -> tc_dm dm_name
194 where
195 sel_name = idName sel_id
196 prags = prag_fn sel_name
197 (dm_bind,bndr_loc) = findMethodBind sel_name binds_in
198 `orElse` pprPanic "tcDefMeth" (ppr sel_id)
199
200 -- Eg. class C a where
201 -- op :: forall b. Eq b => a -> [b] -> a
202 -- gen_op :: a -> a
203 -- generic gen_op :: D a => a -> a
204 -- The "local_dm_ty" is precisely the type in the above
205 -- type signatures, ie with no "forall a. C a =>" prefix
206
207 tc_dm dm_name
208 = do { dm_id <- tcLookupId dm_name
209 ; local_dm_name <- setSrcSpan bndr_loc (newLocalName sel_name)
210 -- Base the local_dm_name on the selector name, because
211 -- type errors from tcInstanceMethodBody come from here
212
213 ; dm_id_w_inline <- addInlinePrags dm_id prags
214 ; spec_prags <- tcSpecPrags dm_id prags
215
216 ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars)
217 hs_ty = lookupHsSig hs_sig_fn sel_name
218 `orElse` pprPanic "tc_dm" (ppr sel_name)
219
220 ; local_dm_sig <- instTcTySig hs_ty local_dm_ty Nothing [] local_dm_name
221 ; warnTc (not (null spec_prags))
222 (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
223 <+> quotes (ppr sel_name))
224
225 ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
226 dm_id_w_inline local_dm_sig idHsWrapper
227 IsDefaultMethod dm_bind
228
229 ; return (unitBag tc_bind) }
230
231 ---------------
232 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
233 -> Id -> TcSigInfo
234 -> HsWrapper -- See Note [Instance method signatures] in TcInstDcls
235 -> TcSpecPrags -> LHsBind Name
236 -> TcM (LHsBind Id)
237 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
238 meth_id local_meth_sig wrapper
239 specs (L loc bind)
240 = do { let local_meth_id = case local_meth_sig of
241 TcSigInfo{ sig_id = meth_id } -> meth_id
242 _ -> pprPanic "tcInstanceMethodBody" (ppr local_meth_sig)
243 lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
244 -- Substitute the local_meth_name for the binder
245 -- NB: the binding is always a FunBind
246 ; (ev_binds, (tc_bind, _, _))
247 <- checkConstraints skol_info tyvars dfun_ev_vars $
248 tcPolyCheck NonRecursive no_prag_fn local_meth_sig lm_bind
249
250 ; let export = ABE { abe_wrap = wrapper, abe_poly = meth_id
251 , abe_mono = local_meth_id, abe_prags = specs }
252 full_bind = AbsBinds { abs_tvs = tyvars
253 , abs_ev_vars = dfun_ev_vars
254 , abs_exports = [export]
255 , abs_ev_binds = ev_binds
256 , abs_binds = tc_bind }
257
258 ; return (L loc full_bind) }
259 where
260 no_prag_fn _ = [] -- No pragmas for local_meth_id;
261 -- they are all for meth_id
262
263 ---------------
264 tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
265 tcClassMinimalDef _clas sigs op_info
266 = case findMinimalDef sigs of
267 Nothing -> return defMindef
268 Just mindef -> do
269 -- Warn if the given mindef does not imply the default one
270 -- That is, the given mindef should at least ensure that the
271 -- class ops without default methods are required, since we
272 -- have no way to fill them in otherwise
273 whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
274 (\bf -> addWarnTc (warningMinimalDefIncomplete bf))
275 return mindef
276 where
277 -- By default require all methods without a default
278 -- implementation whose names don't start with '_'
279 defMindef :: ClassMinimalDef
280 defMindef = mkAnd [ mkVar name
281 | (name, NoDM, _) <- op_info
282 , not (startsWithUnderscore (getOccName name)) ]
283
284 instantiateMethod :: Class -> Id -> [TcType] -> TcType
285 -- Take a class operation, say
286 -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
287 -- Instantiate it at [ty1,ty2]
288 -- Return the "local method type":
289 -- forall c. Ix x => (ty2,c) -> ty1
290 instantiateMethod clas sel_id inst_tys
291 = ASSERT( ok_first_pred ) local_meth_ty
292 where
293 (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
294 rho_ty = ASSERT( length sel_tyvars == length inst_tys )
295 substTyWith sel_tyvars inst_tys sel_rho
296
297 (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
298 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
299
300 ok_first_pred = case getClassPredTys_maybe first_pred of
301 Just (clas1, _tys) -> clas == clas1
302 Nothing -> False
303 -- The first predicate should be of form (C a b)
304 -- where C is the class in question
305
306
307 ---------------------------
308 type HsSigFun = NameEnv (LHsType Name)
309
310 emptyHsSigs :: HsSigFun
311 emptyHsSigs = emptyNameEnv
312
313 mkHsSigFun :: [LSig Name] -> HsSigFun
314 mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
315 | L _ (TypeSig ns hs_ty _) <- sigs
316 , L _ n <- ns ]
317
318 lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
319 lookupHsSig = lookupNameEnv
320
321 ---------------------------
322 findMethodBind :: Name -- Selector name
323 -> LHsBinds Name -- A group of bindings
324 -> Maybe (LHsBind Name, SrcSpan)
325 -- Returns the binding, and the binding
326 -- site of the method binder
327 findMethodBind sel_name binds
328 = foldlBag mplus Nothing (mapBag f binds)
329 where
330 f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
331 | op_name == sel_name
332 = Just (bind, bndr_loc)
333 f _other = Nothing
334
335 ---------------------------
336 findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
337 findMinimalDef = firstJusts . map toMinimalDef
338 where
339 toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
340 toMinimalDef (L _ (MinimalSig bf)) = Just (fmap unLoc bf)
341 toMinimalDef _ = Nothing
342
343 {-
344 Note [Polymorphic methods]
345 ~~~~~~~~~~~~~~~~~~~~~~~~~~
346 Consider
347 class Foo a where
348 op :: forall b. Ord b => a -> b -> b -> b
349 instance Foo c => Foo [c] where
350 op = e
351
352 When typechecking the binding 'op = e', we'll have a meth_id for op
353 whose type is
354 op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
355
356 So tcPolyBinds must be capable of dealing with nested polytypes;
357 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
358
359 Note [Silly default-method bind]
360 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
361 When we pass the default method binding to the type checker, it must
362 look like op2 = e
363 not $dmop2 = e
364 otherwise the "$dm" stuff comes out error messages. But we want the
365 "$dm" to come out in the interface file. So we typecheck the former,
366 and wrap it in a let, thus
367 $dmop2 = let op2 = e in op2
368 This makes the error messages right.
369
370
371 ************************************************************************
372 * *
373 Error messages
374 * *
375 ************************************************************************
376 -}
377
378 tcMkDeclCtxt :: TyClDecl Name -> SDoc
379 tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
380 ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
381
382 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
383 tcAddDeclCtxt decl thing_inside
384 = addErrCtxt (tcMkDeclCtxt decl) thing_inside
385
386 badMethodErr :: Outputable a => a -> Name -> SDoc
387 badMethodErr clas op
388 = hsep [ptext (sLit "Class"), quotes (ppr clas),
389 ptext (sLit "does not have a method"), quotes (ppr op)]
390
391 badGenericMethod :: Outputable a => a -> Name -> SDoc
392 badGenericMethod clas op
393 = hsep [ptext (sLit "Class"), quotes (ppr clas),
394 ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
395
396 {-
397 badGenericInstanceType :: LHsBinds Name -> SDoc
398 badGenericInstanceType binds
399 = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
400 nest 2 (ppr binds)]
401
402 missingGenericInstances :: [Name] -> SDoc
403 missingGenericInstances missing
404 = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
405
406 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
407 dupGenericInsts tc_inst_infos
408 = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
409 nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
410 ptext (sLit "All the type patterns for a generic type constructor must be identical")
411 ]
412 where
413 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
414 -}
415 badDmPrag :: Id -> Sig Name -> TcM ()
416 badDmPrag sel_id prag
417 = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
418 <+> quotes (ppr sel_id)
419 <+> ptext (sLit "lacks an accompanying binding"))
420
421 warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
422 warningMinimalDefIncomplete mindef
423 = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
424 , nest 2 (pprBooleanFormulaNice mindef)
425 , ptext (sLit "but there is no default implementation.") ]