Improve typechecking of let-bindings
[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 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 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 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 ty <- lookupNameEnv gen_dm_env nm = Just (GenericDM ty)
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, gen_op_ty) | L _ 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) <- findMethodBind sel_name binds_in
203 = do { -- First look up the default method -- It should be there!
204 global_dm_id <- tcLookupId dm_name
205 ; global_dm_id <- addInlinePrags global_dm_id prags
206 ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
207 -- Base the local_dm_name on the selector name, because
208 -- type errors from tcInstanceMethodBody come from here
209
210 ; spec_prags <- discardConstraints $
211 tcSpecPrags global_dm_id prags
212 ; warnTc NoReason
213 (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 ; let local_dm_id = mkLocalId local_dm_name local_dm_ty
245 local_dm_sig = CompleteSig { sig_bndr = local_dm_id
246 , sig_ctxt = ctxt
247 , sig_loc = getLoc (hsSigType hs_ty) }
248
249 ; (ev_binds, (tc_bind, _))
250 <- checkConstraints (ClsSkol clas) tyvars [this_dict] $
251 tcPolyCheck no_prag_fn local_dm_sig
252 (L bind_loc lm_bind)
253
254 ; let export = ABE { abe_poly = global_dm_id
255 , abe_mono = local_dm_id
256 , abe_wrap = idHsWrapper
257 , abe_prags = IsDefaultMethod }
258 full_bind = AbsBinds { abs_tvs = tyvars
259 , abs_ev_vars = [this_dict]
260 , abs_exports = [export]
261 , abs_ev_binds = [ev_binds]
262 , abs_binds = tc_bind }
263
264 ; return (unitBag (L bind_loc full_bind)) }
265
266 | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
267 where
268 sel_name = idName sel_id
269 prags = lookupPragEnv prag_fn sel_name
270 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
271 -- they are all for meth_id
272
273 ---------------
274 tcClassMinimalDef :: Name -> [LSig Name] -> [TcMethInfo] -> TcM ClassMinimalDef
275 tcClassMinimalDef _clas sigs op_info
276 = case findMinimalDef sigs of
277 Nothing -> return defMindef
278 Just mindef -> do
279 -- Warn if the given mindef does not imply the default one
280 -- That is, the given mindef should at least ensure that the
281 -- class ops without default methods are required, since we
282 -- have no way to fill them in otherwise
283 whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
284 (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
285 return mindef
286 where
287 -- By default require all methods without a default
288 -- implementation whose names don't start with '_'
289 defMindef :: ClassMinimalDef
290 defMindef = mkAnd [ noLoc (mkVar name)
291 | (name, _, Nothing) <- op_info
292 , not (startsWithUnderscore (getOccName name)) ]
293
294 instantiateMethod :: Class -> Id -> [TcType] -> TcType
295 -- Take a class operation, say
296 -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
297 -- Instantiate it at [ty1,ty2]
298 -- Return the "local method type":
299 -- forall c. Ix x => (ty2,c) -> ty1
300 instantiateMethod clas sel_id inst_tys
301 = ASSERT( ok_first_pred ) local_meth_ty
302 where
303 rho_ty = piResultTys (idType sel_id) inst_tys
304 (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
305 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
306
307 ok_first_pred = case getClassPredTys_maybe first_pred of
308 Just (clas1, _tys) -> clas == clas1
309 Nothing -> False
310 -- The first predicate should be of form (C a b)
311 -- where C is the class in question
312
313
314 ---------------------------
315 type HsSigFun = NameEnv (LHsSigType Name)
316
317 emptyHsSigs :: HsSigFun
318 emptyHsSigs = emptyNameEnv
319
320 mkHsSigFun :: [LSig Name] -> HsSigFun
321 mkHsSigFun sigs = mkNameEnv [(n, hs_ty)
322 | L _ (ClassOpSig False ns hs_ty) <- sigs
323 , L _ n <- ns ]
324
325 lookupHsSig :: HsSigFun -> Name -> Maybe (LHsSigType Name)
326 lookupHsSig = lookupNameEnv
327
328 ---------------------------
329 findMethodBind :: Name -- Selector name
330 -> LHsBinds Name -- A group of bindings
331 -> Maybe (LHsBind Name, SrcSpan)
332 -- Returns the binding, and the binding
333 -- site of the method binder
334 findMethodBind sel_name binds
335 = foldlBag mplus Nothing (mapBag f binds)
336 where
337 f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
338 | op_name == sel_name
339 = Just (bind, bndr_loc)
340 f _other = Nothing
341
342 ---------------------------
343 findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef
344 findMinimalDef = firstJusts . map toMinimalDef
345 where
346 toMinimalDef :: LSig Name -> Maybe ClassMinimalDef
347 toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf)
348 toMinimalDef _ = Nothing
349
350 {-
351 Note [Polymorphic methods]
352 ~~~~~~~~~~~~~~~~~~~~~~~~~~
353 Consider
354 class Foo a where
355 op :: forall b. Ord b => a -> b -> b -> b
356 instance Foo c => Foo [c] where
357 op = e
358
359 When typechecking the binding 'op = e', we'll have a meth_id for op
360 whose type is
361 op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
362
363 So tcPolyBinds must be capable of dealing with nested polytypes;
364 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
365
366 Note [Silly default-method bind]
367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
368 When we pass the default method binding to the type checker, it must
369 look like op2 = e
370 not $dmop2 = e
371 otherwise the "$dm" stuff comes out error messages. But we want the
372 "$dm" to come out in the interface file. So we typecheck the former,
373 and wrap it in a let, thus
374 $dmop2 = let op2 = e in op2
375 This makes the error messages right.
376
377
378 ************************************************************************
379 * *
380 Error messages
381 * *
382 ************************************************************************
383 -}
384
385 tcMkDeclCtxt :: TyClDecl Name -> SDoc
386 tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,
387 text "declaration for", quotes (ppr (tcdName decl))]
388
389 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
390 tcAddDeclCtxt decl thing_inside
391 = addErrCtxt (tcMkDeclCtxt decl) thing_inside
392
393 badMethodErr :: Outputable a => a -> Name -> SDoc
394 badMethodErr clas op
395 = hsep [text "Class", quotes (ppr clas),
396 text "does not have a method", quotes (ppr op)]
397
398 badGenericMethod :: Outputable a => a -> Name -> SDoc
399 badGenericMethod clas op
400 = hsep [text "Class", quotes (ppr clas),
401 text "has a generic-default signature without a binding", quotes (ppr op)]
402
403 {-
404 badGenericInstanceType :: LHsBinds Name -> SDoc
405 badGenericInstanceType binds
406 = vcat [text "Illegal type pattern in the generic bindings",
407 nest 2 (ppr binds)]
408
409 missingGenericInstances :: [Name] -> SDoc
410 missingGenericInstances missing
411 = text "Missing type patterns for" <+> pprQuotedList missing
412
413 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
414 dupGenericInsts tc_inst_infos
415 = vcat [text "More than one type pattern for a single generic type constructor:",
416 nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
417 text "All the type patterns for a generic type constructor must be identical"
418 ]
419 where
420 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
421 -}
422 badDmPrag :: Id -> Sig Name -> TcM ()
423 badDmPrag sel_id prag
424 = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")
425 <+> quotes (ppr sel_id)
426 <+> text "lacks an accompanying binding")
427
428 warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
429 warningMinimalDefIncomplete mindef
430 = vcat [ text "The MINIMAL pragma does not require:"
431 , nest 2 (pprBooleanFormulaNice mindef)
432 , text "but there is no default implementation." ]
433
434 tcATDefault :: Bool -- If a warning should be emitted when a default instance
435 -- definition is not provided by the user
436 -> SrcSpan
437 -> TCvSubst
438 -> NameSet
439 -> ClassATItem
440 -> TcM [FamInst]
441 -- ^ Construct default instances for any associated types that
442 -- aren't given a user definition
443 -- Returns [] or singleton
444 tcATDefault emit_warn loc inst_subst defined_ats (ATI fam_tc defs)
445 -- User supplied instances ==> everything is OK
446 | tyConName fam_tc `elemNameSet` defined_ats
447 = return []
448
449 -- No user instance, have defaults ==> instatiate them
450 -- Example: class C a where { type F a b :: *; type F a b = () }
451 -- instance C [x]
452 -- Then we want to generate the decl: type F [x] b = ()
453 | Just (rhs_ty, _loc) <- defs
454 = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
455 (tyConTyVars fam_tc)
456 rhs' = substTyUnchecked subst' rhs_ty
457 tcv' = tyCoVarsOfTypesList pat_tys'
458 (tv', cv') = partition isTyVar tcv'
459 tvs' = toposortTyVars tv'
460 cvs' = toposortTyVars cv'
461 ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
462 ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs'
463 fam_tc pat_tys' rhs'
464 -- NB: no validity check. We check validity of default instances
465 -- in the class definition. Because type instance arguments cannot
466 -- be type family applications and cannot be polytypes, the
467 -- validity check is redundant.
468
469 ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
470 , pprCoAxiom axiom ])
471 ; fam_inst <- newFamInst SynFamilyInst axiom
472 ; return [fam_inst] }
473
474 -- No defaults ==> generate a warning
475 | otherwise -- defs = Nothing
476 = do { when emit_warn $ warnMissingAT (tyConName fam_tc)
477 ; return [] }
478 where
479 subst_tv subst tc_tv
480 | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
481 = (subst, ty)
482 | otherwise
483 = (extendTvSubst subst tc_tv ty', ty')
484 where
485 ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
486
487 warnMissingAT :: Name -> TcM ()
488 warnMissingAT name
489 = do { warn <- woptM Opt_WarnMissingMethods
490 ; traceTc "warn" (ppr name <+> ppr warn)
491 ; warnTc (Reason Opt_WarnMissingMethods) warn -- Warn only if -Wmissing-methods
492 (text "No explicit" <+> text "associated type"
493 <+> text "or default declaration for "
494 <+> quotes (ppr name)) }