2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcClassDcl]{Typechecking class declarations}
7 module TcClassDcl ( tcClassSigs, tcClassDecl2,
9 MethodSpec, tcMethodBind, mkMethodBind,
10 tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
13 #include "HsVersions.h"
16 import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
17 import RnExpr ( rnLExpr )
18 import RnEnv ( lookupTopBndrRn, lookupImportedName )
19 import Inst ( instToId, newDictBndr, newDictBndrs, newMethod, getOverlapFlag )
20 import InstEnv ( mkLocalInstance )
21 import TcEnv ( tcLookupLocatedClass,
22 tcExtendTyVarEnv, tcExtendIdEnv,
23 InstInfo(..), pprInstInfoDetails,
24 simpleInstInfoTyCon, simpleInstInfoTy,
25 InstBindings(..), newDFunName
27 import TcBinds ( TcPragFun, tcMonoBinds, tcPrags, mkPragFun, TcSigInfo(..),
28 TcSigFun, mkTcSigFun )
29 import TcHsType ( tcHsKindedType, tcHsSigType )
30 import TcSimplify ( tcSimplifyCheck )
31 import TcUnify ( checkSigTyVars, sigCtxt )
32 import TcMType ( tcSkolSigTyVars )
33 import TcType ( Type, SkolemInfo(ClsSkol, InstSkol), UserTypeCtxt( GenPatCtxt ),
34 TcType, TcThetaType, TcTyVar, mkTyVarTys,
35 mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
36 tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
37 getClassPredTys_maybe, mkPhiTy, mkTyVarTy
40 import Generics ( mkGenericRhs, validGenericInstanceType )
41 import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
42 import Class ( classTyVars, classBigSig,
43 Class, ClassOpItem, DefMeth (..) )
44 import TyCon ( TyCon, tyConName, tyConHasGenerics )
45 import Type ( substTyWith )
46 import MkId ( mkDefaultMethodId, mkDictFunId )
47 import Id ( Id, idType, idName, mkUserLocal )
48 import Name ( Name, NamedThing(..) )
49 import NameEnv ( NameEnv, lookupNameEnv, mkNameEnv )
50 import NameSet ( nameSetToList )
51 import OccName ( reportIfUnused, mkDefaultMethodOcc )
52 import RdrName ( RdrName, mkDerivedRdrName )
54 import PrelNames ( genericTyConNames )
56 import ErrUtils ( dumpIfSet_dyn )
57 import Util ( count, lengthIs, isSingleton, lengthExceeds )
58 import Unique ( Uniquable(..) )
59 import ListSetOps ( equivClassesByUniq, minusList )
60 import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
61 import Maybes ( seqMaybe, isJust, mapCatMaybes )
62 import List ( partition )
63 import BasicTypes ( RecFlag(..), Boxity(..) )
72 Every class implicitly declares a new data type, corresponding to dictionaries
73 of that class. So, for example:
75 class (D a) => C a where
77 op2 :: forall b. Ord b => a -> b -> b
79 would implicitly declare
81 data CDict a = CDict (D a)
83 (forall b. Ord b => a -> b -> b)
85 (We could use a record decl, but that means changing more of the existing apparatus.
88 For classes with just one superclass+method, we use a newtype decl instead:
91 op :: forallb. a -> b -> b
95 newtype CDict a = CDict (forall b. a -> b -> b)
97 Now DictTy in Type is just a form of type synomym:
98 DictTy c t = TyConTy CDict `AppTy` t
100 Death to "ExpandingDicts".
103 %************************************************************************
105 Type-checking the class op signatures
107 %************************************************************************
110 tcClassSigs :: Name -- Name of the class
115 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
116 -- between tcClassSigs and buildClass
117 tcClassSigs clas sigs def_methods
118 = do { dm_env <- checkDefaultBinds clas op_names def_methods
119 ; mappM (tcClassSig dm_env) op_sigs }
121 op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
122 op_names = [n | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
125 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
126 -- Check default bindings
127 -- a) must be for a class op for this class
128 -- b) must be all generic or all non-generic
129 -- and return a mapping from class-op to Bool
130 -- where True <=> it's a generic default method
131 checkDefaultBinds clas ops binds
132 = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
133 return (mkNameEnv dm_infos)
135 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
136 = do { -- Check that the op is from this class
137 checkTc (op `elem` ops) (badMethodErr clas op)
139 -- Check that all the defns ar generic, or none are
140 ; checkTc (all_generic || none_generic) (mixedGenericErr op)
142 ; returnM (op, all_generic)
145 n_generic = count (isJust . maybeGenericMatch) matches
146 none_generic = n_generic == 0
147 all_generic = matches `lengthIs` n_generic
150 tcClassSig :: NameEnv Bool -- Info about default methods;
154 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
155 = setSrcSpan loc $ do
156 { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
157 ; let dm = case lookupNameEnv dm_env op_name of
159 Just False -> DefMeth
160 Just True -> GenDefMeth
161 ; returnM (op_name, dm, op_ty) }
165 %************************************************************************
167 \subsection[Default methods]{Default methods}
169 %************************************************************************
171 The default methods for a class are each passed a dictionary for the
172 class, so that they get access to the other methods at the same type.
173 So, given the class decl
177 op2 :: Ord b => a -> b -> b -> b
180 op2 x y z = if (op1 x) && (y < z) then y else z
182 we get the default methods:
184 defm.Foo.op1 :: forall a. Foo a => a -> Bool
185 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
187 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
188 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
189 if (op1 a dfoo x) && (< b dord y z) then y else z
192 When we come across an instance decl, we may need to use the default
195 instance Foo Int where {}
199 const.Foo.Int.op1 :: Int -> Bool
200 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
202 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
203 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
205 dfun.Foo.Int :: Foo Int
206 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
208 Notice that, as with method selectors above, we assume that dictionary
209 application is curried, so there's no need to mention the Ord dictionary
210 in const.Foo.Int.op2 (or the type variable).
213 instance Foo a => Foo [a] where {}
215 dfun.Foo.List :: forall a. Foo a -> Foo [a]
217 = /\ a -> \ dfoo_a ->
219 op1 = defm.Foo.op1 [a] dfoo_list
220 op2 = defm.Foo.op2 [a] dfoo_list
221 dfoo_list = (op1, op2)
226 @tcClassDecls2@ generates bindings for polymorphic default methods
227 (generic default methods have by now turned into instance declarations)
230 tcClassDecl2 :: LTyClDecl Name -- The class declaration
231 -> TcM (LHsBinds Id, [Id])
233 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
234 tcdMeths = default_binds}))
235 = recoverM (returnM (emptyLHsBinds, [])) $
237 tcLookupLocatedClass class_name `thenM` \ clas ->
239 -- We make a separate binding for each default method.
240 -- At one time I used a single AbsBinds for all of them, thus
241 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
242 -- But that desugars into
243 -- ds = \d -> (..., ..., ...)
244 -- dm1 = \d -> case ds d of (a,b,c) -> a
245 -- And since ds is big, it doesn't get inlined, so we don't get good
246 -- default methods. Better to make separate AbsBinds for each
248 (tyvars, _, _, op_items) = classBigSig clas
249 rigid_info = ClsSkol clas
250 origin = SigOrigin rigid_info
251 prag_fn = mkPragFun sigs
252 sig_fn = mkTcSigFun sigs
253 clas_tyvars = tcSkolSigTyVars rigid_info tyvars
254 tc_dm = tcDefMeth origin clas clas_tyvars
255 default_binds sig_fn prag_fn
257 dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
258 -- Generate code for polymorphic default methods only
259 -- (Generic default methods have turned into instance decls by now.)
260 -- This is incompatible with Hugs, which expects a polymorphic
261 -- default method for every class op, regardless of whether or not
262 -- the programmer supplied an explicit default decl for the class.
263 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
265 mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
266 returnM (listToBag defm_binds, concat dm_ids_s)
268 tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
269 = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
270 ; let inst_tys = mkTyVarTys tyvars
271 dm_ty = idType sel_id -- Same as dict selector!
272 cls_pred = mkClassPred clas inst_tys
273 local_dm_id = mkDefaultMethodId dm_name dm_ty
275 ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
276 ; loc <- getInstLoc origin
277 ; this_dict <- newDictBndr loc cls_pred
278 ; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
279 sig_fn prag_fn meth_info)
281 ; addErrCtxt (defltMethCtxt clas) $ do
284 { dict_binds <- tcSimplifyCheck
285 (ptext SLIT("class") <+> ppr clas)
290 -- Simplification can do unification
291 ; checkSigTyVars tyvars
294 -- We'll have an inline pragma on the local binding, made by tcMethodBind
295 -- but that's not enough; we want one on the global default method too
296 -- Specialisations, on the other hand, belong on the thing inside only, I think
297 ; let (_,dm_inst_id,_) = meth_info
298 sel_name = idName sel_id
299 inline_prags = filter isInlineLSig (prag_fn sel_name)
300 ; prags <- tcPrags dm_inst_id inline_prags
302 ; let full_bind = AbsBinds tyvars
304 [(tyvars, local_dm_id, dm_inst_id, prags)]
305 (dict_binds `unionBags` defm_bind)
306 ; returnM (noLoc full_bind, [local_dm_id]) }}
308 mkDefMethRdrName :: Id -> RdrName
309 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
313 %************************************************************************
315 \subsection{Typechecking a method}
317 %************************************************************************
319 @tcMethodBind@ is used to type-check both default-method and
320 instance-decl method declarations. We must type-check methods one at a
321 time, because their signatures may have different contexts and
325 type MethodSpec = (Id, -- Global selector Id
326 Id, -- Local Id (class tyvars instantiated)
327 LHsBind Name) -- Binding for the method
330 :: [TcTyVar] -- Skolemised type variables for the
331 -- enclosing class/instance decl.
332 -- They'll be signature tyvars, and we
333 -- want to check that they don't get bound
334 -- Also they are scoped, so we bring them into scope
335 -- Always equal the range of the type envt
336 -> TcThetaType -- Available theta; it's just used for the error message
337 -> [Inst] -- Available from context, used to simplify constraints
338 -- from the method body
339 -> TcSigFun -- For scoped tyvars, indexed by sel_name
340 -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name
341 -> MethodSpec -- Details of this method
344 tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
345 (sel_id, meth_id, meth_bind)
346 = recoverM (returnM emptyLHsBinds) $
347 -- If anything fails, recover returning no bindings.
348 -- This is particularly useful when checking the default-method binding of
349 -- a class decl. If we don't recover, we don't add the default method to
350 -- the type enviroment, and we get a tcLookup failure on $dmeth later.
352 -- Check the bindings; first adding inst_tyvars to the envt
353 -- so that we don't quantify over them in nested places
355 let sel_name = idName sel_id
356 meth_sig_fn meth_name = ASSERT( meth_name == idName meth_id ) sig_fn sel_name
357 -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
359 tcExtendTyVarEnv inst_tyvars (
360 tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
361 addErrCtxt (methodCtxt sel_id) $
363 tcMonoBinds [meth_bind] meth_sig_fn Recursive
364 ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
366 -- Now do context reduction. We simplify wrt both the local tyvars
367 -- and the ones of the class/instance decl, so that there is
370 -- op :: Eq a => a -> b -> a
372 -- We do this for each method independently to localise error messages
375 [(_, Just sig, local_meth_id)] = mono_bind_infos
378 addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
379 newDictBndrs (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
381 meth_tvs = sig_tvs sig
382 all_tyvars = meth_tvs ++ inst_tyvars
383 all_insts = avail_insts ++ meth_dicts
386 (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
387 all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
389 checkSigTyVars all_tyvars `thenM_`
391 tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
393 poly_meth_bind = noLoc $ AbsBinds meth_tvs
394 (map instToId meth_dicts)
395 [(meth_tvs, meth_id, local_meth_id, prags)]
396 (lie_binds `unionBags` meth_bind)
398 returnM (unitBag poly_meth_bind)
401 mkMethodBind :: InstOrigin
402 -> Class -> [TcType] -- Class and instance types
403 -> LHsBinds Name -- Method binding (pick the right one from in here)
405 -> TcM (Maybe Inst, -- Method inst
407 -- Find the binding for the specified method, or make
408 -- up a suitable default method if it isn't there
410 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
411 = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
413 meth_name = idName meth_id
415 -- Figure out what method binding to use
416 -- If the user suppplied one, use it, else construct a default one
417 getSrcSpanM `thenM` \ loc ->
418 (case find_bind (idName sel_id) meth_name meth_binds of
419 Just user_bind -> returnM user_bind
421 mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
423 returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
424 ) `thenM` \ meth_bind ->
426 returnM (mb_inst, (sel_id, meth_id, meth_bind))
428 mkMethId :: InstOrigin -> Class
429 -> Id -> [TcType] -- Selector, and instance types
430 -> TcM (Maybe Inst, Id)
432 -- mkMethId instantiates the selector Id at the specified types
433 mkMethId origin clas sel_id inst_tys
435 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
436 rho_ty = ASSERT( length tyvars == length inst_tys )
437 substTyWith tyvars inst_tys rho
438 (preds,tau) = tcSplitPhiTy rho_ty
439 first_pred = head preds
441 -- The first predicate should be of form (C a b)
442 -- where C is the class in question
443 ASSERT( not (null preds) &&
444 case getClassPredTys_maybe first_pred of
445 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
447 if isSingleton preds then
448 -- If it's the only one, make a 'method'
449 getInstLoc origin `thenM` \ inst_loc ->
450 newMethod inst_loc sel_id inst_tys `thenM` \ meth_inst ->
451 returnM (Just meth_inst, instToId meth_inst)
453 -- If it's not the only one we need to be careful
454 -- For example, given 'op' defined thus:
456 -- op :: (?x :: String) => a -> a
457 -- (mkMethId op T) should return an Inst with type
458 -- (?x :: String) => T -> T
459 -- That is, the class-op's context is still there.
460 -- BUT: it can't be a Method any more, because it breaks
461 -- INVARIANT 2 of methods. (See the data decl for Inst.)
462 newUnique `thenM` \ uniq ->
463 getSrcSpanM `thenM` \ loc ->
465 real_tau = mkPhiTy (tail preds) tau
466 meth_id = mkUserLocal (getOccName sel_id) uniq real_tau
467 (srcSpanStart loc) --TODO
469 returnM (Nothing, meth_id)
471 -- The user didn't supply a method binding,
472 -- so we have to make up a default binding
473 -- The RHS of a default method depends on the default-method info
474 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
475 = -- An polymorphic default method
476 lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
477 -- Might not be imported, but will be an OrigName
478 traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
479 returnM (nlHsVar dm_name)
481 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
482 = -- No default method
483 -- Warn only if -fwarn-missing-methods
484 doptM Opt_WarnMissingMethods `thenM` \ warn ->
485 warnTc (isInstDecl origin
487 && reportIfUnused (getOccName sel_id))
488 (omittedMethodWarn sel_id) `thenM_`
491 error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
492 simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
493 (nlHsLit (HsStringPrim (mkFastString error_msg)))
494 error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
496 -- When the type is of form t1 -> t2 -> t3
497 -- make a default method like (\ _ _ -> noMethBind "blah")
498 -- rather than simply (noMethBind "blah")
499 -- Reason: if t1 or t2 are higher-ranked types we get n
500 -- silly ambiguity messages.
501 -- Example: f :: (forall a. Eq a => a -> a) -> Int
503 -- Here, tcSub tries to force (error "urk") to have the right type,
504 -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
505 -- where 't' is fresh ty var. This leads directly to "ambiguous t".
507 -- NB: technically this changes the meaning of the default-default
508 -- method slightly, because `seq` can see the lambdas. Oh well.
509 (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
510 (_,_,tau2) = tcSplitSigmaTy tau1
511 -- Need two splits because the selector can have a type like
512 -- forall a. Foo a => forall b. Eq b => ...
513 (arg_tys, _) = tcSplitFunTys tau2
514 wild_pats = [nlWildPat | ty <- arg_tys]
516 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
517 = -- A generic default method
518 -- If the method is defined generically, we can only do the job if the
519 -- instance declaration is for a single-parameter type class with
520 -- a type constructor applied to type arguments in the instance decl
521 -- (checkTc, so False provokes the error)
522 ASSERT( isInstDecl origin ) -- We never get here from a class decl
523 do { checkTc (isJust maybe_tycon)
524 (badGenericInstance sel_id (notSimple inst_tys))
525 ; checkTc (tyConHasGenerics tycon)
526 (badGenericInstance sel_id (notGeneric tycon))
529 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
530 (vcat [ppr clas <+> ppr inst_tys,
531 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
533 -- Rename it before returning it
534 ; (rn_rhs, _) <- rnLExpr rhs
537 rhs = mkGenericRhs sel_id clas_tyvar tycon
539 -- The tycon is only used in the generic case, and in that
540 -- case we require that the instance decl is for a single-parameter
541 -- type class with type variable arguments:
542 -- instance (...) => C (T a b)
543 clas_tyvar = head (classTyVars clas)
544 Just tycon = maybe_tycon
545 maybe_tycon = case inst_tys of
546 [ty] -> case tcSplitTyConApp_maybe ty of
547 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
551 isInstDecl (SigOrigin (InstSkol _)) = True
552 isInstDecl (SigOrigin (ClsSkol _)) = False
557 -- The renamer just puts the selector ID as the binder in the method binding
558 -- but we must use the method name; so we substitute it here. Crude but simple.
559 find_bind sel_name meth_name binds
560 = foldlBag seqMaybe Nothing (mapBag f binds)
562 f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
563 = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
568 %************************************************************************
570 \subsection{Extracting generic instance declaration from class declarations}
572 %************************************************************************
574 @getGenericInstances@ extracts the generic instance declarations from a class
575 declaration. For exmaple
580 op{ x+y } (Inl v) = ...
581 op{ x+y } (Inr v) = ...
582 op{ x*y } (v :*: w) = ...
585 gives rise to the instance declarations
587 instance C (x+y) where
591 instance C (x*y) where
599 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
600 getGenericInstances class_decls
601 = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls
602 ; let { gen_inst_info = concat gen_inst_infos }
604 -- Return right away if there is no generic stuff
605 ; if null gen_inst_info then returnM []
608 -- Otherwise print it out
610 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
611 (vcat (map pprInstInfoDetails gen_inst_info)))
612 ; returnM gen_inst_info }}
614 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
616 = returnM [] -- The comon case: no generic default methods
618 | otherwise -- A source class decl with generic default methods
619 = recoverM (returnM []) $
621 tcLookupLocatedClass class_name `thenM` \ clas ->
623 -- Group by type, and
624 -- make an InstInfo out of each group
626 groups = groupWith listToBag generic_binds
628 mappM (mkGenericInstance clas) groups `thenM` \ inst_infos ->
630 -- Check that there is only one InstInfo for each type constructor
631 -- The main way this can fail is if you write
632 -- f {| a+b |} ... = ...
633 -- f {| x+y |} ... = ...
634 -- Then at this point we'll have an InstInfo for each
636 tc_inst_infos :: [(TyCon, InstInfo)]
637 tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
639 bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
640 group `lengthExceeds` 1]
641 get_uniq (tc,_) = getUnique tc
643 mappM (addErrTc . dupGenericInsts) bad_groups `thenM_`
645 -- Check that there is an InstInfo for each generic type constructor
647 missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
649 checkTc (null missing) (missingGenericInstances missing) `thenM_`
653 generic_binds :: [(HsType Name, LHsBind Name)]
654 generic_binds = getGenericBinds def_methods
657 ---------------------------------
658 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
659 -- Takes a group of method bindings, finds the generic ones, and returns
660 -- them in finite map indexed by the type parameter in the definition.
661 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
663 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
664 = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
666 wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
670 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
672 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
675 (this,rest) = partition same_t prs
676 same_t (t',v) = t `eqPatType` t'
678 eqPatLType :: LHsType Name -> LHsType Name -> Bool
679 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
681 eqPatType :: HsType Name -> HsType Name -> Bool
682 -- A very simple equality function, only for
683 -- type patterns in generic function definitions.
684 eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
685 eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
686 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
687 eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
688 eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
689 eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
690 eqPatType _ _ = False
692 ---------------------------------
693 mkGenericInstance :: Class
694 -> (HsType Name, LHsBinds Name)
697 mkGenericInstance clas (hs_ty, binds)
698 -- Make a generic instance declaration
699 -- For example: instance (C a, C b) => C (a+b) where { binds }
701 = -- Extract the universally quantified type variables
702 -- and wrap them as forall'd tyvars, so that kind inference
703 -- works in the standard way
705 sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
706 hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
708 -- Type-check the instance type, and check its form
709 tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty ->
711 (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
713 checkTc (validGenericInstanceType inst_ty)
714 (badGenericInstanceType binds) `thenM_`
716 -- Make the dictionary function.
717 getSrcSpanM `thenM` \ span ->
718 getOverlapFlag `thenM` \ overlap_flag ->
719 newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name ->
721 inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
722 dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
723 ispec = mkLocalInstance dfun_id overlap_flag
725 returnM (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
729 %************************************************************************
733 %************************************************************************
736 tcAddDeclCtxt decl thing_inside
737 = addErrCtxt ctxt thing_inside
740 ClassDecl {} -> "class"
741 TySynonym {} -> "type synonym"
742 TyFunction {} -> "type function signature"
743 TyData {tcdND = NewType} -> "newtype" ++ maybeSig
744 TyData {tcdND = DataType} -> "data type" ++ maybeSig
746 maybeSig | isKindSigDecl decl = " signature"
749 ctxt = hsep [ptext SLIT("In the"), text thing,
750 ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
753 = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
756 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
759 = hsep [ptext SLIT("Class"), quotes (ppr clas),
760 ptext SLIT("does not have a method"), quotes (ppr op)]
763 = hsep [ptext SLIT("Class"), quotes (ppr clas),
764 ptext SLIT("does not have an associated type"), quotes (ppr at)]
766 omittedMethodWarn sel_id
767 = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
770 = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
772 badGenericInstance sel_id because
773 = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
777 = vcat [ptext SLIT("because the instance type(s)"),
778 nest 2 (ppr inst_tys),
779 ptext SLIT("is not a simple type of form (T a b c)")]
782 = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
783 ptext SLIT("was not compiled with -fgenerics")]
785 badGenericInstanceType binds
786 = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
789 missingGenericInstances missing
790 = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
792 dupGenericInsts tc_inst_infos
793 = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
794 nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
795 ptext SLIT("All the type patterns for a generic type constructor must be identical")
798 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
801 = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)