c5a4c3aab3ea45ed63ef55b5267502dde835afd5
[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,
15 tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,
16 tcATDefault
17 ) where
18
19 #include "HsVersions.h"
20
21 import HsSyn
22 import TcEnv
23 import TcSigs
24 import TcEvidence ( idHsWrapper )
25 import TcBinds
26 import TcUnify
27 import TcHsType
28 import TcMType
29 import Type ( getClassPredTys_maybe, piResultTys )
30 import TcType
31 import TcRnMonad
32 import BuildTyCl( TcMethInfo )
33 import Class
34 import Coercion ( pprCoAxiom )
35 import DynFlags
36 import FamInst
37 import FamInstEnv
38 import Id
39 import Name
40 import NameEnv
41 import NameSet
42 import Var
43 import VarEnv
44 import Outputable
45 import SrcLoc
46 import TyCon
47 import Maybes
48 import BasicTypes
49 import Bag
50 import FastString
51 import BooleanFormula
52 import Util
53
54 import Control.Monad
55 import Data.List ( mapAccumL, partition )
56
57 {-
58 Dictionary handling
59 ~~~~~~~~~~~~~~~~~~~
60 Every class implicitly declares a new data type, corresponding to dictionaries
61 of that class. So, for example:
62
63 class (D a) => C a where
64 op1 :: a -> a
65 op2 :: forall b. Ord b => a -> b -> b
66
67 would implicitly declare
68
69 data CDict a = CDict (D a)
70 (a -> a)
71 (forall b. Ord b => a -> b -> b)
72
73 (We could use a record decl, but that means changing more of the existing apparatus.
74 One step at at time!)
75
76 For classes with just one superclass+method, we use a newtype decl instead:
77
78 class C a where
79 op :: forallb. a -> b -> b
80
81 generates
82
83 newtype CDict a = CDict (forall b. a -> b -> b)
84
85 Now DictTy in Type is just a form of type synomym:
86 DictTy c t = TyConTy CDict `AppTy` t
87
88 Death to "ExpandingDicts".
89
90
91 ************************************************************************
92 * *
93 Type-checking the class op signatures
94 * *
95 ************************************************************************
96 -}
97
98 tcClassSigs :: Name -- Name of the class
99 -> [LSig Name]
100 -> LHsBinds Name
101 -> TcM [TcMethInfo] -- Exactly one for each method
102 tcClassSigs clas sigs def_methods
103 = do { traceTc "tcClassSigs 1" (ppr clas)
104
105 ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs
106 ; let gen_dm_env :: NameEnv (SrcSpan, Type)
107 gen_dm_env = mkNameEnv gen_dm_prs
108
109 ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs
110
111 ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]
112 ; sequence_ [ failWithTc (badMethodErr clas n)
113 | n <- dm_bind_names, not (n `elemNameSet` op_names) ]
114 -- Value binding for non class-method (ie no TypeSig)
115
116 ; sequence_ [ failWithTc (badGenericMethod clas n)
117 | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]
118 -- Generic signature without value binding
119
120 ; traceTc "tcClassSigs 2" (ppr clas)
121 ; return op_info }
122 where
123 vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs]
124 gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig True nm ty) <- sigs]
125 dm_bind_names :: [Name] -- These ones have a value binding in the class decl
126 dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
127
128 tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType Name)
129 -> TcM [TcMethInfo]
130 tc_sig gen_dm_env (op_names, op_hs_ty)
131 = do { traceTc "ClsSig 1" (ppr op_names)
132 ; op_ty <- tcClassSigType op_names op_hs_ty -- Class tyvars already in scope
133 ; traceTc "ClsSig 2" (ppr op_names)
134 ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }
135 where
136 f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)
137 | nm `elem` dm_bind_names = Just VanillaDM
138 | otherwise = Nothing
139
140 tc_gen_sig (op_names, gen_hs_ty)
141 = do { gen_op_ty <- tcClassSigType op_names gen_hs_ty
142 ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }
143
144 {-
145 ************************************************************************
146 * *
147 Class Declarations
148 * *
149 ************************************************************************
150 -}
151
152 tcClassDecl2 :: LTyClDecl Name -- The class declaration
153 -> TcM (LHsBinds Id)
154
155 tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
156 tcdMeths = default_binds}))
157 = recoverM (return emptyLHsBinds) $
158 setSrcSpan (getLoc class_name) $
159 do { clas <- tcLookupLocatedClass class_name
160
161 -- We make a separate binding for each default method.
162 -- At one time I used a single AbsBinds for all of them, thus
163 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
164 -- But that desugars into
165 -- ds = \d -> (..., ..., ...)
166 -- dm1 = \d -> case ds d of (a,b,c) -> a
167 -- And since ds is big, it doesn't get inlined, so we don't get good
168 -- default methods. Better to make separate AbsBinds for each
169 ; let (tyvars, _, _, op_items) = classBigSig clas
170 prag_fn = mkPragEnv sigs default_binds
171 sig_fn = mkHsSigFun sigs
172 clas_tyvars = snd (tcSuperSkolTyVars tyvars)
173 pred = mkClassPred clas (mkTyVarTys clas_tyvars)
174 ; this_dict <- newEvVar pred
175
176 ; let tc_item = tcDefMeth clas clas_tyvars this_dict
177 default_binds sig_fn prag_fn
178 ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
179 mapM tc_item op_items
180
181 ; return (unionManyBags dm_binds) }
182
183 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
184
185 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
186 -> HsSigFun -> TcPragEnv -> ClassOpItem
187 -> TcM (LHsBinds TcId)
188 -- Generate code for default methods
189 -- This is incompatible with Hugs, which expects a polymorphic
190 -- default method for every class op, regardless of whether or not
191 -- the programmer supplied an explicit default decl for the class.
192 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
193
194 tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
195 = do { -- No default method
196 mapM_ (addLocM (badDmPrag sel_id))
197 (lookupPragEnv prag_fn (idName sel_id))
198 ; return emptyBag }
199
200 tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
201 (sel_id, Just (dm_name, dm_spec))
202 | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
203 = do { -- First look up the default method; it should be there!
204 -- It can be the orinary default method
205 -- or the generic-default method. E.g of the latter
206 -- class C a where
207 -- op :: a -> a -> Bool
208 -- default op :: Eq a => a -> a -> Bool
209 -- op x y = x==y
210 -- The default method we generate is
211 -- $gm :: (C a, Eq a) => a -> a -> Bool
212 -- $gm x y = x==y
213
214 global_dm_id <- tcLookupId dm_name
215 ; global_dm_id <- addInlinePrags global_dm_id prags
216 ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
217 -- Base the local_dm_name on the selector name, because
218 -- type errors from tcInstanceMethodBody come from here
219
220 ; spec_prags <- discardConstraints $
221 tcSpecPrags global_dm_id prags
222 ; warnTc NoReason
223 (not (null spec_prags))
224 (text "Ignoring SPECIALISE pragmas on default method"
225 <+> quotes (ppr sel_name))
226
227 ; let hs_ty = hs_sig_fn sel_name
228 `orElse` pprPanic "tc_dm" (ppr sel_name)
229 -- We need the HsType so that we can bring the right
230 -- type variables into scope
231 --
232 -- Eg. class C a where
233 -- op :: forall b. Eq b => a -> [b] -> a
234 -- gen_op :: a -> a
235 -- generic gen_op :: D a => a -> a
236 -- The "local_dm_ty" is precisely the type in the above
237 -- type signatures, ie with no "forall a. C a =>" prefix
238
239 local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
240
241 lm_bind = dm_bind { fun_id = L bind_loc local_dm_name }
242 -- Substitute the local_meth_name for the binder
243 -- NB: the binding is always a FunBind
244
245 warn_redundant = case dm_spec of
246 GenericDM {} -> True
247 VanillaDM -> False
248 -- For GenericDM, warn if the user specifies a signature
249 -- with redundant constraints; but not for VanillaDM, where
250 -- the default method may well be 'error' or something
251
252 ctxt = FunSigCtxt sel_name warn_redundant
253
254 ; let local_dm_id = mkLocalId local_dm_name local_dm_ty
255 local_dm_sig = CompleteSig { sig_bndr = local_dm_id
256 , sig_ctxt = ctxt
257 , sig_loc = getLoc (hsSigType hs_ty) }
258
259 ; (ev_binds, (tc_bind, _))
260 <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
261 tcPolyCheck no_prag_fn local_dm_sig
262 (L bind_loc lm_bind)
263
264 ; let export = ABE { abe_poly = global_dm_id
265 , abe_mono = local_dm_id
266 , abe_wrap = idHsWrapper
267 , abe_prags = IsDefaultMethod }
268 full_bind = AbsBinds { abs_tvs = tyvars
269 , abs_ev_vars = [this_dict]
270 , abs_exports = [export]
271 , abs_ev_binds = [ev_binds]
272 , abs_binds = tc_bind }
273
274 ; return (unitBag (L bind_loc full_bind)) }
275
276 | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
277 where
278 sel_name = idName sel_id
279 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
280 -- they are all for meth_id
281
282 ---------------
283 tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
284 tcClassMinimalDef _clas sigs op_info
285 = case findMinimalDef sigs of
286 Nothing -> return defMindef
287 Just mindef -> do
288 -- Warn if the given mindef does not imply the default one
289 -- That is, the given mindef should at least ensure that the
290 -- class ops without default methods are required, since we
291 -- have no way to fill them in otherwise
292 whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
293 (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
294 return mindef
295 where
296 -- By default require all methods without a default implementation
297 defMindef :: ClassMinimalDef
298 defMindef = mkAnd [ noLoc (mkVar name)
299 | (name, _, Nothing) <- op_info ]
300
301 instantiateMethod :: Class -> Id -> [TcType] -> TcType
302 -- Take a class operation, say
303 -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
304 -- Instantiate it at [ty1,ty2]
305 -- Return the "local method type":
306 -- forall c. Ix x => (ty2,c) -> ty1
307 instantiateMethod clas sel_id inst_tys
308 = ASSERT( ok_first_pred ) local_meth_ty
309 where
310 rho_ty = piResultTys (idType sel_id) inst_tys
311 (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
312 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
313
314 ok_first_pred = case getClassPredTys_maybe first_pred of
315 Just (clas1, _tys) -> clas == clas1
316 Nothing -> False
317 -- The first predicate should be of form (C a b)
318 -- where C is the class in question
319
320
321 ---------------------------
322 type HsSigFun = Name -> Maybe (LHsSigType Name)
323
324 mkHsSigFun :: [LSig Name] -> HsSigFun
325 mkHsSigFun sigs = lookupNameEnv env
326 where
327 env = mkHsSigEnv get_classop_sig sigs
328
329 get_classop_sig :: LSig Name -> Maybe ([Located Name], LHsSigType Name)
330 get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty)
331 get_classop_sig _ = Nothing
332
333 ---------------------------
334 findMethodBind :: Name -- Selector
335 -> LHsBinds Name -- A group of bindings
336 -> TcPragEnv
337 -> Maybe (LHsBind Name, SrcSpan, [LSig Name])
338 -- Returns the binding, the binding
339 -- site of the method binder, and any inline or
340 -- specialisation pragmas
341 findMethodBind sel_name binds prag_fn
342 = foldlBag mplus Nothing (mapBag f binds)
343 where
344 prags = lookupPragEnv prag_fn sel_name
345
346 f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
347 | op_name == sel_name
348 = Just (bind, bndr_loc, prags)
349 f _other = Nothing
350
351 ---------------------------
352 findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
353 findMinimalDef = firstJusts . map toMinimalDef
354 where
355 toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
356 toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
357 toMinimalDef _ = Nothing
358
359 {-
360 Note [Polymorphic methods]
361 ~~~~~~~~~~~~~~~~~~~~~~~~~~
362 Consider
363 class Foo a where
364 op :: forall b. Ord b => a -> b -> b -> b
365 instance Foo c => Foo [c] where
366 op = e
367
368 When typechecking the binding 'op = e', we'll have a meth_id for op
369 whose type is
370 op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
371
372 So tcPolyBinds must be capable of dealing with nested polytypes;
373 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
374
375 Note [Silly default-method bind]
376 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
377 When we pass the default method binding to the type checker, it must
378 look like op2 = e
379 not $dmop2 = e
380 otherwise the "$dm" stuff comes out error messages. But we want the
381 "$dm" to come out in the interface file. So we typecheck the former,
382 and wrap it in a let, thus
383 $dmop2 = let op2 = e in op2
384 This makes the error messages right.
385
386
387 ************************************************************************
388 * *
389 Error messages
390 * *
391 ************************************************************************
392 -}
393
394 tcMkDeclCtxt :: TyClDecl Name -> SDoc
395 tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,
396 text "declaration for", quotes (ppr (tcdName decl))]
397
398 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
399 tcAddDeclCtxt decl thing_inside
400 = addErrCtxt (tcMkDeclCtxt decl) thing_inside
401
402 badMethodErr :: Outputable a => a -> Name -> SDoc
403 badMethodErr clas op
404 = hsep [text "Class", quotes (ppr clas),
405 text "does not have a method", quotes (ppr op)]
406
407 badGenericMethod :: Outputable a => a -> Name -> SDoc
408 badGenericMethod clas op
409 = hsep [text "Class", quotes (ppr clas),
410 text "has a generic-default signature without a binding", quotes (ppr op)]
411
412 {-
413 badGenericInstanceType :: LHsBinds Name -> SDoc
414 badGenericInstanceType binds
415 = vcat [text "Illegal type pattern in the generic bindings",
416 nest 2 (ppr binds)]
417
418 missingGenericInstances :: [Name] -> SDoc
419 missingGenericInstances missing
420 = text "Missing type patterns for" <+> pprQuotedList missing
421
422 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
423 dupGenericInsts tc_inst_infos
424 = vcat [text "More than one type pattern for a single generic type constructor:",
425 nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
426 text "All the type patterns for a generic type constructor must be identical"
427 ]
428 where
429 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
430 -}
431 badDmPrag :: Id -> Sig Name -> TcM ()
432 badDmPrag sel_id prag
433 = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")
434 <+> quotes (ppr sel_id)
435 <+> text "lacks an accompanying binding")
436
437 warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
438 warningMinimalDefIncomplete mindef
439 = vcat [ text "The MINIMAL pragma does not require:"
440 , nest 2 (pprBooleanFormulaNice mindef)
441 , text "but there is no default implementation." ]
442
443 tcATDefault :: Bool -- If a warning should be emitted when a default instance
444 -- definition is not provided by the user
445 -> SrcSpan
446 -> TCvSubst
447 -> NameSet
448 -> ClassATItem
449 -> TcM [FamInst]
450 -- ^ Construct default instances for any associated types that
451 -- aren't given a user definition
452 -- Returns [] or singleton
453 tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
454 -- User supplied instances ==> everything is OK
455 | tyConName fam_tc `elemNameSet` defined_ats
456 = return []
457
458 -- No user instance, have defaults ==> instantiate them
459 -- Example: class C a where { type F a b :: *; type F a b = () }
460 -- instance C [x]
461 -- Then we want to generate the decl: type F [x] b = ()
462 | Just (rhs_ty, _loc) <- defs
463 = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
464 (tyConTyVars fam_tc)
465 rhs' = substTyUnchecked subst' rhs_ty
466 tcv' = tyCoVarsOfTypesList pat_tys'
467 (tv', cv') = partition isTyVar tcv'
468 tvs' = toposortTyVars tv'
469 cvs' = toposortTyVars cv'
470 ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
471 ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs'
472 fam_tc pat_tys' rhs'
473 -- NB: no validity check. We check validity of default instances
474 -- in the class definition. Because type instance arguments cannot
475 -- be type family applications and cannot be polytypes, the
476 -- validity check is redundant.
477
478 ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
479 , pprCoAxiom axiom ])
480 ; fam_inst <- newFamInst SynFamilyInst axiom
481 ; return [fam_inst] }
482
483 -- No defaults ==> generate a warning
484 | otherwise -- defs = Nothing
485 = do { when emit_warn $ warnMissingAT (tyConName fam_tc)
486 ; return [] }
487 where
488 subst_tv subst tc_tv
489 | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
490 = (subst, ty)
491 | otherwise
492 = (extendTvSubst subst tc_tv ty', ty')
493 where
494 ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
495
496 warnMissingAT :: Name -> TcM ()
497 warnMissingAT name
498 = do { warn <- woptM Opt_WarnMissingMethods
499 ; traceTc "warn" (ppr name <+> ppr warn)
500 ; warnTc (Reason Opt_WarnMissingMethods) warn -- Warn only if -Wmissing-methods
501 (text "No explicit" <+> text "associated type"
502 <+> text "or default declaration for "
503 <+> quotes (ppr name)) }