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