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