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