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