bc1bac291cc23cf50b0dd3f0c8ca4ca690c623a0
[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, completeSigPolyId )
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 -- We have created a complete type signature in
237 -- instTcTySig, hence it is safe to call
238 -- completeSigPolyId
239 , abe_mono = completeSigPolyId local_dm_sig'
240 , abe_wrap = idHsWrapper
241 , abe_prags = IsDefaultMethod }
242 full_bind = AbsBinds { abs_tvs = tyvars
243 , abs_ev_vars = [this_dict]
244 , abs_exports = [export]
245 , abs_ev_binds = [ev_binds]
246 , abs_binds = tc_bind }
247
248 ; return (unitBag (L bind_loc full_bind)) }
249
250 | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
251 where
252 sel_name = idName sel_id
253 prags = prag_fn sel_name
254 no_prag_fn _ = [] -- No pragmas for local_meth_id;
255 -- they are all for meth_id
256
257 ---------------
258 tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
259 tcClassMinimalDef _clas sigs op_info
260 = case findMinimalDef sigs of
261 Nothing -> return defMindef
262 Just mindef -> do
263 -- Warn if the given mindef does not imply the default one
264 -- That is, the given mindef should at least ensure that the
265 -- class ops without default methods are required, since we
266 -- have no way to fill them in otherwise
267 whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
268 (\bf -> addWarnTc (warningMinimalDefIncomplete bf))
269 return mindef
270 where
271 -- By default require all methods without a default
272 -- implementation whose names don't start with '_'
273 defMindef :: ClassMinimalDef
274 defMindef = mkAnd [ mkVar name
275 | (name, NoDM, _) <- op_info
276 , not (startsWithUnderscore (getOccName name)) ]
277
278 instantiateMethod :: Class -> Id -> [TcType] -> TcType
279 -- Take a class operation, say
280 -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
281 -- Instantiate it at [ty1,ty2]
282 -- Return the "local method type":
283 -- forall c. Ix x => (ty2,c) -> ty1
284 instantiateMethod clas sel_id inst_tys
285 = ASSERT( ok_first_pred ) local_meth_ty
286 where
287 (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
288 rho_ty = ASSERT( length sel_tyvars == length inst_tys )
289 substTyWith sel_tyvars inst_tys sel_rho
290
291 (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
292 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
293
294 ok_first_pred = case getClassPredTys_maybe first_pred of
295 Just (clas1, _tys) -> clas == clas1
296 Nothing -> False
297 -- The first predicate should be of form (C a b)
298 -- where C is the class in question
299
300
301 ---------------------------
302 type HsSigFun = NameEnv (LHsType Name)
303
304 emptyHsSigs :: HsSigFun
305 emptyHsSigs = emptyNameEnv
306
307 mkHsSigFun :: [LSig Name] -> HsSigFun
308 mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
309 | L _ (TypeSig ns hs_ty _) <- sigs
310 , L _ n <- ns ]
311
312 lookupHsSig :: HsSigFun -> Name -> Maybe (LHsType Name)
313 lookupHsSig = lookupNameEnv
314
315 ---------------------------
316 findMethodBind :: Name -- Selector name
317 -> LHsBinds Name -- A group of bindings
318 -> Maybe (LHsBind Name, SrcSpan)
319 -- Returns the binding, and the binding
320 -- site of the method binder
321 findMethodBind sel_name binds
322 = foldlBag mplus Nothing (mapBag f binds)
323 where
324 f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
325 | op_name == sel_name
326 = Just (bind, bndr_loc)
327 f _other = Nothing
328
329 ---------------------------
330 findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
331 findMinimalDef = firstJusts . map toMinimalDef
332 where
333 toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
334 toMinimalDef (L _ (MinimalSig _ bf)) = Just (fmap unLoc bf)
335 toMinimalDef _ = Nothing
336
337 {-
338 Note [Polymorphic methods]
339 ~~~~~~~~~~~~~~~~~~~~~~~~~~
340 Consider
341 class Foo a where
342 op :: forall b. Ord b => a -> b -> b -> b
343 instance Foo c => Foo [c] where
344 op = e
345
346 When typechecking the binding 'op = e', we'll have a meth_id for op
347 whose type is
348 op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
349
350 So tcPolyBinds must be capable of dealing with nested polytypes;
351 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
352
353 Note [Silly default-method bind]
354 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
355 When we pass the default method binding to the type checker, it must
356 look like op2 = e
357 not $dmop2 = e
358 otherwise the "$dm" stuff comes out error messages. But we want the
359 "$dm" to come out in the interface file. So we typecheck the former,
360 and wrap it in a let, thus
361 $dmop2 = let op2 = e in op2
362 This makes the error messages right.
363
364
365 ************************************************************************
366 * *
367 Error messages
368 * *
369 ************************************************************************
370 -}
371
372 tcMkDeclCtxt :: TyClDecl Name -> SDoc
373 tcMkDeclCtxt decl = hsep [ptext (sLit "In the"), pprTyClDeclFlavour decl,
374 ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
375
376 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
377 tcAddDeclCtxt decl thing_inside
378 = addErrCtxt (tcMkDeclCtxt decl) thing_inside
379
380 badMethodErr :: Outputable a => a -> Name -> SDoc
381 badMethodErr clas op
382 = hsep [ptext (sLit "Class"), quotes (ppr clas),
383 ptext (sLit "does not have a method"), quotes (ppr op)]
384
385 badGenericMethod :: Outputable a => a -> Name -> SDoc
386 badGenericMethod clas op
387 = hsep [ptext (sLit "Class"), quotes (ppr clas),
388 ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
389
390 {-
391 badGenericInstanceType :: LHsBinds Name -> SDoc
392 badGenericInstanceType binds
393 = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
394 nest 2 (ppr binds)]
395
396 missingGenericInstances :: [Name] -> SDoc
397 missingGenericInstances missing
398 = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
399
400 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
401 dupGenericInsts tc_inst_infos
402 = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
403 nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
404 ptext (sLit "All the type patterns for a generic type constructor must be identical")
405 ]
406 where
407 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
408 -}
409 badDmPrag :: Id -> Sig Name -> TcM ()
410 badDmPrag sel_id prag
411 = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
412 <+> quotes (ppr sel_id)
413 <+> ptext (sLit "lacks an accompanying binding"))
414
415 warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
416 warningMinimalDefIncomplete mindef
417 = vcat [ ptext (sLit "The MINIMAL pragma does not require:")
418 , nest 2 (pprBooleanFormulaNice mindef)
419 , ptext (sLit "but there is no default implementation.") ]