Add nakedSubstTy and use it in TcHsType.tcInferApps
[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 HsSyn
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 -- tcExtendTyVarEnv here (instead of scopeTyVars) is OK:
202 -- the tcDefMeth calls checkConstraints to bump the TcLevel
203 -- and make the implication constraint
204 ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
205 mapM tc_item op_items
206
207 ; return (unionManyBags dm_binds) }
208
209 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
210
211 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn
212 -> HsSigFun -> TcPragEnv -> ClassOpItem
213 -> TcM (LHsBinds GhcTcId)
214 -- Generate code for default methods
215 -- This is incompatible with Hugs, which expects a polymorphic
216 -- default method for every class op, regardless of whether or not
217 -- the programmer supplied an explicit default decl for the class.
218 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
219
220 tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)
221 = do { -- No default method
222 mapM_ (addLocM (badDmPrag sel_id))
223 (lookupPragEnv prag_fn (idName sel_id))
224 ; return emptyBag }
225
226 tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
227 (sel_id, Just (dm_name, dm_spec))
228 | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn
229 = do { -- First look up the default method; it should be there!
230 -- It can be the orinary default method
231 -- or the generic-default method. E.g of the latter
232 -- class C a where
233 -- op :: a -> a -> Bool
234 -- default op :: Eq a => a -> a -> Bool
235 -- op x y = x==y
236 -- The default method we generate is
237 -- $gm :: (C a, Eq a) => a -> a -> Bool
238 -- $gm x y = x==y
239
240 global_dm_id <- tcLookupId dm_name
241 ; global_dm_id <- addInlinePrags global_dm_id prags
242 ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc
243 -- Base the local_dm_name on the selector name, because
244 -- type errors from tcInstanceMethodBody come from here
245
246 ; spec_prags <- discardConstraints $
247 tcSpecPrags global_dm_id prags
248 ; warnTc NoReason
249 (not (null spec_prags))
250 (text "Ignoring SPECIALISE pragmas on default method"
251 <+> quotes (ppr sel_name))
252
253 ; let hs_ty = hs_sig_fn sel_name
254 `orElse` pprPanic "tc_dm" (ppr sel_name)
255 -- We need the HsType so that we can bring the right
256 -- type variables into scope
257 --
258 -- Eg. class C a where
259 -- op :: forall b. Eq b => a -> [b] -> a
260 -- gen_op :: a -> a
261 -- generic gen_op :: D a => a -> a
262 -- The "local_dm_ty" is precisely the type in the above
263 -- type signatures, ie with no "forall a. C a =>" prefix
264
265 local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)
266
267 lm_bind = dm_bind { fun_id = L bind_loc local_dm_name }
268 -- Substitute the local_meth_name for the binder
269 -- NB: the binding is always a FunBind
270
271 warn_redundant = case dm_spec of
272 GenericDM {} -> True
273 VanillaDM -> False
274 -- For GenericDM, warn if the user specifies a signature
275 -- with redundant constraints; but not for VanillaDM, where
276 -- the default method may well be 'error' or something
277
278 ctxt = FunSigCtxt sel_name warn_redundant
279
280 ; let local_dm_id = mkLocalId local_dm_name local_dm_ty
281 local_dm_sig = CompleteSig { sig_bndr = local_dm_id
282 , sig_ctxt = ctxt
283 , sig_loc = getLoc (hsSigType hs_ty) }
284
285 ; (ev_binds, (tc_bind, _))
286 <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $
287 tcPolyCheck no_prag_fn local_dm_sig
288 (L bind_loc lm_bind)
289
290 ; let export = ABE { abe_ext = noExt
291 , abe_poly = global_dm_id
292 , abe_mono = local_dm_id
293 , abe_wrap = idHsWrapper
294 , abe_prags = IsDefaultMethod }
295 full_bind = AbsBinds { abs_ext = noExt
296 , abs_tvs = tyvars
297 , abs_ev_vars = [this_dict]
298 , abs_exports = [export]
299 , abs_ev_binds = [ev_binds]
300 , abs_binds = tc_bind
301 , abs_sig = True }
302
303 ; return (unitBag (L bind_loc full_bind)) }
304
305 | otherwise = pprPanic "tcDefMeth" (ppr sel_id)
306 where
307 sel_name = idName sel_id
308 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
309 -- they are all for meth_id
310
311 ---------------
312 tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef
313 tcClassMinimalDef _clas sigs op_info
314 = case findMinimalDef sigs of
315 Nothing -> return defMindef
316 Just mindef -> do
317 -- Warn if the given mindef does not imply the default one
318 -- That is, the given mindef should at least ensure that the
319 -- class ops without default methods are required, since we
320 -- have no way to fill them in otherwise
321 tcg_env <- getGblEnv
322 -- However, only do this test when it's not an hsig file,
323 -- since you can't write a default implementation.
324 when (tcg_src tcg_env /= HsigFile) $
325 whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $
326 (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))
327 return mindef
328 where
329 -- By default require all methods without a default implementation
330 defMindef :: ClassMinimalDef
331 defMindef = mkAnd [ noLoc (mkVar name)
332 | (name, _, Nothing) <- op_info ]
333
334 instantiateMethod :: Class -> TcId -> [TcType] -> TcType
335 -- Take a class operation, say
336 -- op :: forall ab. C a => forall c. Ix c => (b,c) -> a
337 -- Instantiate it at [ty1,ty2]
338 -- Return the "local method type":
339 -- forall c. Ix x => (ty2,c) -> ty1
340 instantiateMethod clas sel_id inst_tys
341 = ASSERT( ok_first_pred ) local_meth_ty
342 where
343 rho_ty = piResultTys (idType sel_id) inst_tys
344 (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
345 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
346
347 ok_first_pred = case getClassPredTys_maybe first_pred of
348 Just (clas1, _tys) -> clas == clas1
349 Nothing -> False
350 -- The first predicate should be of form (C a b)
351 -- where C is the class in question
352
353
354 ---------------------------
355 type HsSigFun = Name -> Maybe (LHsSigType GhcRn)
356
357 mkHsSigFun :: [LSig GhcRn] -> HsSigFun
358 mkHsSigFun sigs = lookupNameEnv env
359 where
360 env = mkHsSigEnv get_classop_sig sigs
361
362 get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)
363 get_classop_sig (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)
364 get_classop_sig _ = Nothing
365
366 ---------------------------
367 findMethodBind :: Name -- Selector
368 -> LHsBinds GhcRn -- A group of bindings
369 -> TcPragEnv
370 -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])
371 -- Returns the binding, the binding
372 -- site of the method binder, and any inline or
373 -- specialisation pragmas
374 findMethodBind sel_name binds prag_fn
375 = foldlBag mplus Nothing (mapBag f binds)
376 where
377 prags = lookupPragEnv prag_fn sel_name
378
379 f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))
380 | op_name == sel_name
381 = Just (bind, bndr_loc, prags)
382 f _other = Nothing
383
384 ---------------------------
385 findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef
386 findMinimalDef = firstJusts . map toMinimalDef
387 where
388 toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef
389 toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)
390 toMinimalDef _ = Nothing
391
392 {-
393 Note [Polymorphic methods]
394 ~~~~~~~~~~~~~~~~~~~~~~~~~~
395 Consider
396 class Foo a where
397 op :: forall b. Ord b => a -> b -> b -> b
398 instance Foo c => Foo [c] where
399 op = e
400
401 When typechecking the binding 'op = e', we'll have a meth_id for op
402 whose type is
403 op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
404
405 So tcPolyBinds must be capable of dealing with nested polytypes;
406 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
407
408 Note [Silly default-method bind]
409 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
410 When we pass the default method binding to the type checker, it must
411 look like op2 = e
412 not $dmop2 = e
413 otherwise the "$dm" stuff comes out error messages. But we want the
414 "$dm" to come out in the interface file. So we typecheck the former,
415 and wrap it in a let, thus
416 $dmop2 = let op2 = e in op2
417 This makes the error messages right.
418
419
420 ************************************************************************
421 * *
422 Error messages
423 * *
424 ************************************************************************
425 -}
426
427 tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc
428 tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,
429 text "declaration for", quotes (ppr (tcdName decl))]
430
431 tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a
432 tcAddDeclCtxt decl thing_inside
433 = addErrCtxt (tcMkDeclCtxt decl) thing_inside
434
435 badMethodErr :: Outputable a => a -> Name -> SDoc
436 badMethodErr clas op
437 = hsep [text "Class", quotes (ppr clas),
438 text "does not have a method", quotes (ppr op)]
439
440 badGenericMethod :: Outputable a => a -> Name -> SDoc
441 badGenericMethod clas op
442 = hsep [text "Class", quotes (ppr clas),
443 text "has a generic-default signature without a binding", quotes (ppr op)]
444
445 {-
446 badGenericInstanceType :: LHsBinds Name -> SDoc
447 badGenericInstanceType binds
448 = vcat [text "Illegal type pattern in the generic bindings",
449 nest 2 (ppr binds)]
450
451 missingGenericInstances :: [Name] -> SDoc
452 missingGenericInstances missing
453 = text "Missing type patterns for" <+> pprQuotedList missing
454
455 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
456 dupGenericInsts tc_inst_infos
457 = vcat [text "More than one type pattern for a single generic type constructor:",
458 nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
459 text "All the type patterns for a generic type constructor must be identical"
460 ]
461 where
462 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
463 -}
464 badDmPrag :: TcId -> Sig GhcRn -> TcM ()
465 badDmPrag sel_id prag
466 = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")
467 <+> quotes (ppr sel_id)
468 <+> text "lacks an accompanying binding")
469
470 warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc
471 warningMinimalDefIncomplete mindef
472 = vcat [ text "The MINIMAL pragma does not require:"
473 , nest 2 (pprBooleanFormulaNice mindef)
474 , text "but there is no default implementation." ]
475
476 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
477 instDeclCtxt1 hs_inst_ty
478 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
479
480 instDeclCtxt2 :: Type -> SDoc
481 instDeclCtxt2 dfun_ty
482 = instDeclCtxt3 cls tys
483 where
484 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
485
486 instDeclCtxt3 :: Class -> [Type] -> SDoc
487 instDeclCtxt3 cls cls_tys
488 = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))
489
490 inst_decl_ctxt :: SDoc -> SDoc
491 inst_decl_ctxt doc = hang (text "In the instance declaration for")
492 2 (quotes doc)
493
494 tcATDefault :: SrcSpan
495 -> TCvSubst
496 -> NameSet
497 -> ClassATItem
498 -> TcM [FamInst]
499 -- ^ Construct default instances for any associated types that
500 -- aren't given a user definition
501 -- Returns [] or singleton
502 tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)
503 -- User supplied instances ==> everything is OK
504 | tyConName fam_tc `elemNameSet` defined_ats
505 = return []
506
507 -- No user instance, have defaults ==> instantiate them
508 -- Example: class C a where { type F a b :: *; type F a b = () }
509 -- instance C [x]
510 -- Then we want to generate the decl: type F [x] b = ()
511 | Just (rhs_ty, _loc) <- defs
512 = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst
513 (tyConTyVars fam_tc)
514 rhs' = substTyUnchecked subst' rhs_ty
515 tcv' = tyCoVarsOfTypesList pat_tys'
516 (tv', cv') = partition isTyVar tcv'
517 tvs' = toposortTyVars tv'
518 cvs' = toposortTyVars cv'
519 ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'
520 ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' cvs'
521 fam_tc pat_tys' rhs'
522 -- NB: no validity check. We check validity of default instances
523 -- in the class definition. Because type instance arguments cannot
524 -- be type family applications and cannot be polytypes, the
525 -- validity check is redundant.
526
527 ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty
528 , pprCoAxiom axiom ])
529 ; fam_inst <- newFamInst SynFamilyInst axiom
530 ; return [fam_inst] }
531
532 -- No defaults ==> generate a warning
533 | otherwise -- defs = Nothing
534 = do { warnMissingAT (tyConName fam_tc)
535 ; return [] }
536 where
537 subst_tv subst tc_tv
538 | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv
539 = (subst, ty)
540 | otherwise
541 = (extendTvSubst subst tc_tv ty', ty')
542 where
543 ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)
544
545 warnMissingAT :: Name -> TcM ()
546 warnMissingAT name
547 = do { warn <- woptM Opt_WarnMissingMethods
548 ; traceTc "warn" (ppr name <+> ppr warn)
549 ; hsc_src <- fmap tcg_src getGblEnv
550 -- Warn only if -Wmissing-methods AND not a signature
551 ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)
552 (text "No explicit" <+> text "associated type"
553 <+> text "or default declaration for"
554 <+> quotes (ppr name)) }