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