2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Typechecking class declarations
9 module TcClassDcl ( tcClassSigs, tcClassDecl2,
11 MethodSpec, tcMethodBind, mkMethId,
12 tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
15 #include "HsVersions.h"
63 Every class implicitly declares a new data type, corresponding to dictionaries
64 of that class. So, for example:
66 class (D a) => C a where
68 op2 :: forall b. Ord b => a -> b -> b
70 would implicitly declare
72 data CDict a = CDict (D a)
74 (forall b. Ord b => a -> b -> b)
76 (We could use a record decl, but that means changing more of the existing apparatus.
79 For classes with just one superclass+method, we use a newtype decl instead:
82 op :: forallb. a -> b -> b
86 newtype CDict a = CDict (forall b. a -> b -> b)
88 Now DictTy in Type is just a form of type synomym:
89 DictTy c t = TyConTy CDict `AppTy` t
91 Death to "ExpandingDicts".
94 %************************************************************************
96 Type-checking the class op signatures
98 %************************************************************************
101 tcClassSigs :: Name -- Name of the class
106 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
107 -- between tcClassSigs and buildClass
108 tcClassSigs clas sigs def_methods
109 = do { dm_env <- checkDefaultBinds clas op_names def_methods
110 ; mapM (tcClassSig dm_env) op_sigs }
112 op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
113 op_names = [n | (L _ (TypeSig (L _ n) _)) <- op_sigs]
116 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
117 -- Check default bindings
118 -- a) must be for a class op for this class
119 -- b) must be all generic or all non-generic
120 -- and return a mapping from class-op to Bool
121 -- where True <=> it's a generic default method
122 checkDefaultBinds clas ops binds
123 = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
124 return (mkNameEnv dm_infos)
126 checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, Bool)
127 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
128 = do { -- Check that the op is from this class
129 checkTc (op `elem` ops) (badMethodErr clas op)
131 -- Check that all the defns ar generic, or none are
132 ; checkTc (all_generic || none_generic) (mixedGenericErr op)
134 ; return (op, all_generic)
137 n_generic = count (isJust . maybeGenericMatch) matches
138 none_generic = n_generic == 0
139 all_generic = matches `lengthIs` n_generic
140 checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
143 tcClassSig :: NameEnv Bool -- Info about default methods;
147 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
148 = setSrcSpan loc $ do
149 { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
150 ; let dm = case lookupNameEnv dm_env op_name of
152 Just False -> DefMeth
153 Just True -> GenDefMeth
154 ; return (op_name, dm, op_ty) }
155 tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
159 %************************************************************************
163 %************************************************************************
166 tcClassDecl2 :: LTyClDecl Name -- The class declaration
167 -> TcM (LHsBinds Id, [Id])
169 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
170 tcdMeths = default_binds}))
171 = recoverM (return (emptyLHsBinds, [])) $
173 clas <- tcLookupLocatedClass class_name
175 -- We make a separate binding for each default method.
176 -- At one time I used a single AbsBinds for all of them, thus
177 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
178 -- But that desugars into
179 -- ds = \d -> (..., ..., ...)
180 -- dm1 = \d -> case ds d of (a,b,c) -> a
181 -- And since ds is big, it doesn't get inlined, so we don't get good
182 -- default methods. Better to make separate AbsBinds for each
184 (tyvars, _, _, op_items) = classBigSig clas
185 rigid_info = ClsSkol clas
186 origin = SigOrigin rigid_info
187 prag_fn = mkPragFun sigs
188 sig_fn = mkTcSigFun sigs
189 clas_tyvars = tcSkolSigTyVars rigid_info tyvars
190 tc_dm = tcDefMeth origin clas clas_tyvars
191 default_binds sig_fn prag_fn
193 dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
194 -- Generate code for polymorphic default methods only
195 -- (Generic default methods have turned into instance decls by now.)
196 -- This is incompatible with Hugs, which expects a polymorphic
197 -- default method for every class op, regardless of whether or not
198 -- the programmer supplied an explicit default decl for the class.
199 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
201 (defm_binds, dm_ids_s) <- mapAndUnzipM tc_dm dm_sel_ids
202 return (listToBag defm_binds, concat dm_ids_s)
203 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
205 tcDefMeth :: InstOrigin -> Class -> [TyVar] -> LHsBinds Name
206 -> TcSigFun -> TcPragFun -> Id
207 -> TcM (LHsBindLR Id Var, [Id])
208 tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
209 = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
210 ; let inst_tys = mkTyVarTys tyvars
211 dm_ty = idType sel_id -- Same as dict selector!
212 cls_pred = mkClassPred clas inst_tys
213 local_dm_id = mkDefaultMethodId dm_name dm_ty
215 ; loc <- getInstLoc origin
216 ; this_dict <- newDictBndr loc cls_pred
217 ; (_, meth_id) <- mkMethId origin clas sel_id inst_tys
218 ; (defm_bind, insts_needed) <- getLIE $
219 tcMethodBind origin tyvars [cls_pred] this_dict []
220 sig_fn prag_fn binds_in
221 (sel_id, DefMeth) meth_id
223 ; addErrCtxt (defltMethCtxt clas) $ do
226 { dict_binds <- tcSimplifyCheck
232 -- Simplification can do unification
233 ; checkSigTyVars tyvars
236 -- We'll have an inline pragma on the local binding, made by tcMethodBind
237 -- but that's not enough; we want one on the global default method too
238 -- Specialisations, on the other hand, belong on the thing inside only, I think
239 ; let sel_name = idName sel_id
240 inline_prags = filter isInlineLSig (prag_fn sel_name)
241 ; prags <- tcPrags meth_id inline_prags
243 ; let full_bind = AbsBinds tyvars
245 [(tyvars, local_dm_id, meth_id, prags)]
246 (dict_binds `unionBags` defm_bind)
247 ; return (noLoc full_bind, [local_dm_id]) }}
249 mkDefMethRdrName :: Id -> RdrName
250 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
254 %************************************************************************
256 \subsection{Typechecking a method}
258 %************************************************************************
260 @tcMethodBind@ is used to type-check both default-method and
261 instance-decl method declarations. We must type-check methods one at a
262 time, because their signatures may have different contexts and
266 type MethodSpec = (Id, -- Global selector Id
267 Id, -- Local Id (class tyvars instantiated)
268 LHsBind Name) -- Binding for the method
272 -> [TcTyVar] -- Skolemised type variables for the
273 -- enclosing class/instance decl.
274 -- They'll be signature tyvars, and we
275 -- want to check that they don't get bound
276 -- Also they are scoped, so we bring them into scope
277 -- Always equal the range of the type envt
278 -> TcThetaType -- Available theta; it's just used for the error message
279 -> Inst -- Current dictionary (this_dict)
280 -> [Inst] -- Other stuff available from context, used to simplify
281 -- constraints from the method body (exclude this_dict)
282 -> TcSigFun -- For scoped tyvars, indexed by sel_name
283 -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name
284 -> LHsBinds Name -- Method binding (pick the right one from in here)
286 -> TcId -- The method Id
289 tcMethodBind origin inst_tyvars inst_theta
290 this_dict extra_insts
291 sig_fn prag_fn meth_binds
292 (sel_id, dm_info) meth_id
293 | Just user_bind <- find_bind sel_name meth_name meth_binds
294 = -- If there is a user-supplied method binding, typecheck it
295 tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts)
297 sel_id meth_id user_bind
299 | otherwise -- The user didn't supply a method binding, so we have to make
300 -- up a default binding, in a way depending on the default-method info
302 NoDefMeth -> do { warn <- doptM Opt_WarnMissingMethods
303 ; warnTc (isInstDecl origin
304 && warn -- Warn only if -fwarn-missing-methods
305 && reportIfUnused (getOccName sel_id))
306 -- Don't warn about _foo methods
307 (omittedMethodWarn sel_id)
308 ; return (unitBag $ L loc (VarBind meth_id error_rhs)) }
310 DefMeth -> do { -- An polymorphic default method
311 -- Might not be imported, but will be an OrigName
312 dm_name <- lookupImportedName (mkDefMethRdrName sel_id)
313 ; dm_id <- tcLookupId dm_name
314 -- Note [Default methods in instances]
315 ; return (unitBag $ L loc (VarBind meth_id (mk_dm_app dm_id))) }
317 GenDefMeth -> ASSERT( isInstDecl origin ) -- We never get here from a class decl
318 do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id meth_name
319 ; tc_method_bind inst_tyvars inst_theta (this_dict:extra_insts)
321 sel_id meth_id meth_bind }
324 meth_name = idName meth_id
325 sel_name = idName sel_id
326 loc = getSrcSpan meth_id
327 (clas, inst_tys) = getDictClassTys this_dict
329 this_dict_id = instToId this_dict
330 error_id = L loc (HsVar nO_METHOD_BINDING_ERROR_ID)
331 error_id_app = mkLHsWrap (WpTyApp (idType meth_id)) error_id
332 error_rhs = mkHsApp error_id_app $ L loc $
333 HsLit (HsStringPrim (mkFastString error_msg))
334 error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
336 mk_dm_app dm_id -- dm tys inst_dict
337 = mkLHsWrap (WpApp this_dict_id `WpCompose` mkWpTyApps inst_tys)
338 (L loc (HsVar dm_id))
341 ---------------------------
342 tc_method_bind :: [TyVar] -> TcThetaType -> [Inst] -> (Name -> Maybe [Name])
343 -> (Name -> [LSig Name]) -> Id -> Id -> LHsBind Name
344 -> TcRn (LHsBindsLR Id Var)
345 tc_method_bind inst_tyvars inst_theta avail_insts sig_fn prag_fn
346 sel_id meth_id meth_bind
347 = recoverM (return emptyLHsBinds) $
348 -- If anything fails, recover returning no bindings.
349 -- This is particularly useful when checking the default-method binding of
350 -- a class decl. If we don't recover, we don't add the default method to
351 -- the type enviroment, and we get a tcLookup failure on $dmeth later.
353 -- Check the bindings; first adding inst_tyvars to the envt
354 -- so that we don't quantify over them in nested places
356 do { let sel_name = idName sel_id
357 meth_name = idName meth_id
358 meth_sig_fn name = ASSERT( name == meth_name ) sig_fn sel_name
359 -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
361 ; ((meth_bind, mono_bind_infos), meth_lie)
362 <- tcExtendTyVarEnv inst_tyvars $
363 tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
364 addErrCtxt (methodCtxt sel_id) $
366 tcMonoBinds [meth_bind] meth_sig_fn Recursive
368 -- Now do context reduction. We simplify wrt both the local tyvars
369 -- and the ones of the class/instance decl, so that there is
372 -- op :: Eq a => a -> b -> a
374 -- We do this for each method independently to localise error messages
376 ; let [(_, Just sig, local_meth_id)] = mono_bind_infos
379 ; addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ do
380 { meth_dicts <- newDictBndrs loc (sig_theta sig)
381 ; let meth_tvs = sig_tvs sig
382 all_tyvars = meth_tvs ++ inst_tyvars
383 all_insts = avail_insts ++ meth_dicts
385 ; lie_binds <- tcSimplifyCheck loc all_tyvars all_insts meth_lie
387 ; checkSigTyVars all_tyvars
389 ; prags <- tcPrags meth_id (prag_fn sel_name)
390 ; let poly_meth_bind = noLoc $ AbsBinds meth_tvs
391 (map instToId meth_dicts)
392 [(meth_tvs, meth_id, local_meth_id, prags)]
393 (lie_binds `unionBags` meth_bind)
395 ; return (unitBag poly_meth_bind) }}
398 ---------------------------
399 mkMethId :: InstOrigin -> Class
400 -> Id -> [TcType] -- Selector, and instance types
401 -> TcM (Maybe Inst, Id)
403 -- mkMethId instantiates the selector Id at the specified types
404 mkMethId origin clas sel_id inst_tys
406 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
407 rho_ty = ASSERT( length tyvars == length inst_tys )
408 substTyWith tyvars inst_tys rho
409 (preds,tau) = tcSplitPhiTy rho_ty
410 first_pred = ASSERT( not (null preds)) head preds
412 -- The first predicate should be of form (C a b)
413 -- where C is the class in question
414 ASSERT( not (null preds) &&
415 case getClassPredTys_maybe first_pred of
416 { Just (clas1, _tys) -> clas == clas1 ; Nothing -> False }
418 if isSingleton preds then do
419 -- If it's the only one, make a 'method'
420 inst_loc <- getInstLoc origin
421 meth_inst <- newMethod inst_loc sel_id inst_tys
422 return (Just meth_inst, instToId meth_inst)
424 -- If it's not the only one we need to be careful
425 -- For example, given 'op' defined thus:
427 -- op :: (?x :: String) => a -> a
428 -- (mkMethId op T) should return an Inst with type
429 -- (?x :: String) => T -> T
430 -- That is, the class-op's context is still there.
431 -- BUT: it can't be a Method any more, because it breaks
432 -- INVARIANT 2 of methods. (See the data decl for Inst.)
436 real_tau = mkPhiTy (tail preds) tau
437 meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
439 return (Nothing, meth_id)
441 ---------------------------
442 -- The renamer just puts the selector ID as the binder in the method binding
443 -- but we must use the method name; so we substitute it here. Crude but simple.
444 find_bind :: Name -> Name -- Selector and method name
445 -> LHsBinds Name -- A group of bindings
446 -> Maybe (LHsBind Name) -- The binding, with meth_name replacing sel_name
447 find_bind sel_name meth_name binds
448 = foldlBag mplus Nothing (mapBag f binds)
450 f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
451 = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
454 ---------------------------
455 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
456 mkGenericDefMethBind clas inst_tys sel_id meth_name
457 = -- A generic default method
458 -- If the method is defined generically, we can only do the job if the
459 -- instance declaration is for a single-parameter type class with
460 -- a type constructor applied to type arguments in the instance decl
461 -- (checkTc, so False provokes the error)
462 do { checkTc (isJust maybe_tycon)
463 (badGenericInstance sel_id (notSimple inst_tys))
464 ; checkTc (tyConHasGenerics tycon)
465 (badGenericInstance sel_id (notGeneric tycon))
468 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
469 (vcat [ppr clas <+> ppr inst_tys,
470 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
472 -- Rename it before returning it
473 ; (rn_rhs, _) <- rnLExpr rhs
474 ; return (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rn_rhs]) }
476 rhs = mkGenericRhs sel_id clas_tyvar tycon
478 -- The tycon is only used in the generic case, and in that
479 -- case we require that the instance decl is for a single-parameter
480 -- type class with type variable arguments:
481 -- instance (...) => C (T a b)
482 clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
483 Just tycon = maybe_tycon
484 maybe_tycon = case inst_tys of
485 [ty] -> case tcSplitTyConApp_maybe ty of
486 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
490 isInstDecl :: InstOrigin -> Bool
491 isInstDecl (SigOrigin InstSkol) = True
492 isInstDecl (SigOrigin (ClsSkol _)) = False
493 isInstDecl o = pprPanic "isInstDecl" (ppr o)
497 Note [Default methods]
498 ~~~~~~~~~~~~~~~~~~~~~~~
499 The default methods for a class are each passed a dictionary for the
500 class, so that they get access to the other methods at the same type.
501 So, given the class decl
505 op2 :: forall b. Ord b => a -> b -> b -> b
508 op2 x y z = if (op1 x) && (y < z) then y else z
510 we get the default methods:
512 $dmop1 :: forall a. Foo a => a -> Bool
513 $dmop1 = /\a -> \dfoo -> \x -> True
515 $dmop2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
516 $dmop2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
517 if (op1 a dfoo x) && (< b dord y z) then y else z
519 When we come across an instance decl, we may need to use the default methods:
521 instance Foo Int where {}
524 $dFooInt = MkFoo ($dmop1 Int $dFooInt)
525 ($dmop2 Int $dFooInt)
527 Notice that, as with method selectors above, we assume that dictionary
528 application is curried, so there's no need to mention the Ord dictionary
529 in the application of $dmop2.
531 instance Foo a => Foo [a] where {}
533 $dFooList :: forall a. Foo a -> Foo [a]
534 $dFooList = /\ a -> \ dfoo_a ->
536 op1 = defm.Foo.op1 [a] dfoo_list
537 op2 = defm.Foo.op2 [a] dfoo_list
538 dfoo_list = MkFoo ($dmop1 [a] dfoo_list)
539 ($dmop2 [a] dfoo_list)
543 Note [Default methods in instances]
544 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
553 From the class decl we get
555 $dmfoo :: forall v x. Baz v x => x -> x
557 Notice that the type is ambiguous. That's fine, though. The instance decl generates
559 $dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
561 BUT this does mean we must generate the dictionary translation directly, rather
562 than generating source-code and type-checking it. That was the bug ing
563 Trac #1061. In any case it's less work to generate the translated version!
566 %************************************************************************
568 \subsection{Extracting generic instance declaration from class declarations}
570 %************************************************************************
572 @getGenericInstances@ extracts the generic instance declarations from a class
573 declaration. For exmaple
578 op{ x+y } (Inl v) = ...
579 op{ x+y } (Inr v) = ...
580 op{ x*y } (v :*: w) = ...
583 gives rise to the instance declarations
585 instance C (x+y) where
589 instance C (x*y) where
597 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
598 getGenericInstances class_decls
599 = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls
600 ; let { gen_inst_info = concat gen_inst_infos }
602 -- Return right away if there is no generic stuff
603 ; if null gen_inst_info then return []
606 -- Otherwise print it out
608 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
609 (vcat (map pprInstInfoDetails gen_inst_info)))
610 ; return gen_inst_info }}
612 get_generics :: TyClDecl Name -> TcM [InstInfo]
613 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
615 = return [] -- The comon case: no generic default methods
617 | otherwise -- A source class decl with generic default methods
618 = recoverM (return []) $
619 tcAddDeclCtxt decl $ do
620 clas <- tcLookupLocatedClass class_name
622 -- Group by type, and
623 -- make an InstInfo out of each group
625 groups = groupWith listToBag generic_binds
627 inst_infos <- mapM (mkGenericInstance clas) groups
629 -- Check that there is only one InstInfo for each type constructor
630 -- The main way this can fail is if you write
631 -- f {| a+b |} ... = ...
632 -- f {| x+y |} ... = ...
633 -- Then at this point we'll have an InstInfo for each
635 -- The class should be unary, which is why simpleInstInfoTyCon should be ok
637 tc_inst_infos :: [(TyCon, InstInfo)]
638 tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
640 bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
641 group `lengthExceeds` 1]
642 get_uniq (tc,_) = getUnique tc
644 mapM (addErrTc . dupGenericInsts) bad_groups
646 -- Check that there is an InstInfo for each generic type constructor
648 missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
650 checkTc (null missing) (missingGenericInstances missing)
654 generic_binds :: [(HsType Name, LHsBind Name)]
655 generic_binds = getGenericBinds def_methods
656 get_generics decl = pprPanic "get_generics" (ppr decl)
659 ---------------------------------
660 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
661 -- Takes a group of method bindings, finds the generic ones, and returns
662 -- them in finite map indexed by the type parameter in the definition.
663 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
665 getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
666 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
667 = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
669 wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
673 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
675 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
678 (this,rest) = partition same_t prs
679 same_t (t', _v) = t `eqPatType` t'
681 eqPatLType :: LHsType Name -> LHsType Name -> Bool
682 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
684 eqPatType :: HsType Name -> HsType Name -> Bool
685 -- A very simple equality function, only for
686 -- type patterns in generic function definitions.
687 eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
688 eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
689 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
690 eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
691 eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
692 eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
693 eqPatType _ _ = False
695 ---------------------------------
696 mkGenericInstance :: Class
697 -> (HsType Name, LHsBinds Name)
700 mkGenericInstance clas (hs_ty, binds) = do
701 -- Make a generic instance declaration
702 -- For example: instance (C a, C b) => C (a+b) where { binds }
704 -- Extract the universally quantified type variables
705 -- and wrap them as forall'd tyvars, so that kind inference
706 -- works in the standard way
708 sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
709 hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
711 -- Type-check the instance type, and check its form
712 forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
714 (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
716 checkTc (validGenericInstanceType inst_ty)
717 (badGenericInstanceType binds)
719 -- Make the dictionary function.
721 overlap_flag <- getOverlapFlag
722 dfun_name <- newDFunName clas [inst_ty] span
724 inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
725 dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
726 ispec = mkLocalInstance dfun_id overlap_flag
728 return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
732 %************************************************************************
736 %************************************************************************
739 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
740 tcAddDeclCtxt decl thing_inside
741 = addErrCtxt ctxt thing_inside
743 thing | isClassDecl decl = "class"
744 | isTypeDecl decl = "type synonym" ++ maybeInst
745 | isDataDecl decl = if tcdND decl == NewType
746 then "newtype" ++ maybeInst
747 else "data type" ++ maybeInst
748 | isFamilyDecl decl = "family"
749 | otherwise = panic "tcAddDeclCtxt/thing"
751 maybeInst | isFamInstDecl decl = " instance"
754 ctxt = hsep [ptext (sLit "In the"), text thing,
755 ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
757 defltMethCtxt :: Class -> SDoc
759 = ptext (sLit "When checking the default methods for class") <+> quotes (ppr clas)
761 methodCtxt :: Var -> SDoc
763 = ptext (sLit "In the definition for method") <+> quotes (ppr sel_id)
765 badMethodErr :: Outputable a => a -> Name -> SDoc
767 = hsep [ptext (sLit "Class"), quotes (ppr clas),
768 ptext (sLit "does not have a method"), quotes (ppr op)]
770 badATErr :: Class -> Name -> SDoc
772 = hsep [ptext (sLit "Class"), quotes (ppr clas),
773 ptext (sLit "does not have an associated type"), quotes (ppr at)]
775 omittedMethodWarn :: Id -> SDoc
776 omittedMethodWarn sel_id
777 = ptext (sLit "No explicit method nor default method for") <+> quotes (ppr sel_id)
779 omittedATWarn :: Name -> SDoc
781 = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
783 badGenericInstance :: Var -> SDoc -> SDoc
784 badGenericInstance sel_id because
785 = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
788 notSimple :: [Type] -> SDoc
790 = vcat [ptext (sLit "because the instance type(s)"),
791 nest 2 (ppr inst_tys),
792 ptext (sLit "is not a simple type of form (T a1 ... an)")]
794 notGeneric :: TyCon -> SDoc
796 = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
797 ptext (sLit "was not compiled with -fgenerics")]
799 badGenericInstanceType :: LHsBinds Name -> SDoc
800 badGenericInstanceType binds
801 = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
804 missingGenericInstances :: [Name] -> SDoc
805 missingGenericInstances missing
806 = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
808 dupGenericInsts :: [(TyCon, InstInfo)] -> SDoc
809 dupGenericInsts tc_inst_infos
810 = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
811 nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
812 ptext (sLit "All the type patterns for a generic type constructor must be identical")
815 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
817 mixedGenericErr :: Name -> SDoc
819 = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)