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