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