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
13 #include "HsVersions.h"
16 import BasicTypes ( RecFlag(..), NewOrData(..) )
17 import RnHsSyn ( maybeGenericMatch, extractHsTyVars )
18 import RnExpr ( rnLExpr )
19 import RnEnv ( lookupTopBndrRn, lookupImportedName )
21 import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod )
22 import TcEnv ( tcLookupLocatedClass, tcExtendLocalValEnv2,
24 InstInfo(..), pprInstInfoDetails,
25 simpleInstInfoTyCon, simpleInstInfoTy,
26 InstBindings(..), newDFunName
28 import TcBinds ( tcMonoBinds, tcSpecSigs )
29 import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType )
30 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
31 import TcUnify ( checkSigTyVars, sigCtxt )
32 import TcMType ( tcInstTyVars, UserTypeCtxt( GenPatCtxt ) )
33 import TcType ( Type, TyVarDetails(..), TcType, TcThetaType, TcTyVar,
34 mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
35 tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
36 getClassPredTys_maybe, mkPhiTy, mkTyVarTy
39 import Generics ( mkGenericRhs, validGenericInstanceType )
40 import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
41 import Class ( classTyVars, classBigSig,
42 Class, ClassOpItem, DefMeth (..) )
43 import TyCon ( TyCon, tyConName, tyConHasGenerics )
44 import Subst ( substTyWith )
45 import MkId ( mkDefaultMethodId, mkDictFunId )
46 import Id ( Id, idType, idName, mkUserLocal, setInlinePragma )
47 import Name ( Name, NamedThing(..) )
48 import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv,
49 plusNameEnv, mkNameEnv )
50 import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
51 import OccName ( reportIfUnused, mkDefaultMethodOcc )
52 import RdrName ( RdrName, mkDerivedRdrName )
55 import PrelNames ( genericTyConNames )
57 import UnicodeUtil ( stringToUtf8 )
58 import ErrUtils ( dumpIfSet_dyn )
59 import Util ( count, lengthIs, isSingleton, lengthExceeds )
60 import Unique ( Uniquable(..) )
61 import ListSetOps ( equivClassesByUniq, minusList )
62 import SrcLoc ( SrcLoc, Located(..), srcSpanStart, unLoc, noLoc )
63 import Maybes ( seqMaybe, isJust, mapCatMaybes )
64 import List ( partition )
73 Every class implicitly declares a new data type, corresponding to dictionaries
74 of that class. So, for example:
76 class (D a) => C a where
78 op2 :: forall b. Ord b => a -> b -> b
80 would implicitly declare
82 data CDict a = CDict (D a)
84 (forall b. Ord b => a -> b -> b)
86 (We could use a record decl, but that means changing more of the existing apparatus.
89 For classes with just one superclass+method, we use a newtype decl instead:
92 op :: forallb. a -> b -> b
96 newtype CDict a = CDict (forall b. a -> b -> b)
98 Now DictTy in Type is just a form of type synomym:
99 DictTy c t = TyConTy CDict `AppTy` t
101 Death to "ExpandingDicts".
104 %************************************************************************
106 Type-checking the class op signatures
108 %************************************************************************
111 tcClassSigs :: Name -- Name of the class
116 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
117 -- between tcClassSigs and buildClass
118 tcClassSigs clas sigs def_methods
119 = do { dm_env <- checkDefaultBinds clas op_names def_methods
120 ; mappM (tcClassSig dm_env) op_sigs }
122 op_sigs = [sig | sig@(L _ (Sig _ _)) <- sigs]
123 op_names = [n | sig@(L _ (Sig (L _ n) _)) <- op_sigs]
126 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
127 -- Check default bindings
128 -- a) must be for a class op for this class
129 -- b) must be all generic or all non-generic
130 -- and return a mapping from class-op to Bool
131 -- where True <=> it's a generic default method
132 checkDefaultBinds clas ops binds
133 = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
134 return (mkNameEnv dm_infos)
136 checkDefaultBind clas ops (FunBind (L _ op) _ matches)
137 = do { -- Check that the op is from this class
138 checkTc (op `elem` ops) (badMethodErr clas op)
140 -- Check that all the defns ar generic, or none are
141 ; checkTc (all_generic || none_generic) (mixedGenericErr op)
143 ; returnM (op, all_generic)
146 n_generic = count (isJust . maybeGenericMatch) matches
147 none_generic = n_generic == 0
148 all_generic = matches `lengthIs` n_generic
151 tcClassSig :: NameEnv Bool -- Info about default methods;
155 tcClassSig dm_env (L loc (Sig (L _ op_name) op_hs_ty))
156 = addSrcSpan loc $ do
157 { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
158 ; let dm = case lookupNameEnv dm_env op_name of
160 Just False -> DefMeth
161 Just True -> GenDefMeth
162 ; returnM (op_name, dm, op_ty) }
166 %************************************************************************
168 \subsection[Default methods]{Default methods}
170 %************************************************************************
172 The default methods for a class are each passed a dictionary for the
173 class, so that they get access to the other methods at the same type.
174 So, given the class decl
178 op2 :: Ord b => a -> b -> b -> b
181 op2 x y z = if (op1 x) && (y < z) then y else z
183 we get the default methods:
185 defm.Foo.op1 :: forall a. Foo a => a -> Bool
186 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
188 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
189 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
190 if (op1 a dfoo x) && (< b dord y z) then y else z
193 When we come across an instance decl, we may need to use the default
196 instance Foo Int where {}
200 const.Foo.Int.op1 :: Int -> Bool
201 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
203 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
204 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
206 dfun.Foo.Int :: Foo Int
207 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
209 Notice that, as with method selectors above, we assume that dictionary
210 application is curried, so there's no need to mention the Ord dictionary
211 in const.Foo.Int.op2 (or the type variable).
214 instance Foo a => Foo [a] where {}
216 dfun.Foo.List :: forall a. Foo a -> Foo [a]
218 = /\ a -> \ dfoo_a ->
220 op1 = defm.Foo.op1 [a] dfoo_list
221 op2 = defm.Foo.op2 [a] dfoo_list
222 dfoo_list = (op1, op2)
227 @tcClassDecls2@ generates bindings for polymorphic default methods
228 (generic default methods have by now turned into instance declarations)
231 tcClassDecl2 :: LTyClDecl Name -- The class declaration
232 -> TcM (LHsBinds Id, [Id])
234 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
235 tcdMeths = default_binds}))
236 = recoverM (returnM (emptyBag, [])) $
238 tcLookupLocatedClass class_name `thenM` \ clas ->
240 -- We make a separate binding for each default method.
241 -- At one time I used a single AbsBinds for all of them, thus
242 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
243 -- But that desugars into
244 -- ds = \d -> (..., ..., ...)
245 -- dm1 = \d -> case ds d of (a,b,c) -> a
246 -- And since ds is big, it doesn't get inlined, so we don't get good
247 -- default methods. Better to make separate AbsBinds for each
249 (tyvars, _, _, op_items) = classBigSig clas
250 prags = filter (isPragSig.unLoc) sigs
251 tc_dm = tcDefMeth clas tyvars default_binds prags
253 dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
254 -- Generate code for polymorphic default methods only
255 -- (Generic default methods have turned into instance decls by now.)
256 -- This is incompatible with Hugs, which expects a polymorphic
257 -- default method for every class op, regardless of whether or not
258 -- the programmer supplied an explicit default decl for the class.
259 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
261 mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
262 returnM (listToBag defm_binds, concat dm_ids_s)
264 tcDefMeth clas tyvars binds_in prags sel_id
265 = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
266 tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
268 dm_ty = idType sel_id -- Same as dict selector!
269 theta = [mkClassPred clas inst_tys]
270 local_dm_id = mkDefaultMethodId dm_name dm_ty
271 xtve = tyvars `zip` clas_tyvars
272 origin = ClassDeclOrigin
274 mkMethodBind origin clas inst_tys
275 binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) ->
276 newDicts origin theta `thenM` \ [this_dict] ->
277 getLIE (tcMethodBind xtve clas_tyvars theta
278 [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) ->
280 addErrCtxt (defltMethCtxt clas) $
284 (ptext SLIT("class") <+> ppr clas)
287 insts_needed `thenM` \ dict_binds ->
289 -- Simplification can do unification
290 checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' ->
293 (_,dm_inst_id,_) = meth_info
297 [(clas_tyvars', local_dm_id, dm_inst_id)]
298 emptyNameSet -- No inlines (yet)
299 (dict_binds `unionBags` defm_bind)
301 returnM (noLoc full_bind, [local_dm_id])
303 mkDefMethRdrName :: Id -> RdrName
304 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
308 %************************************************************************
310 \subsection{Typechecking a method}
312 %************************************************************************
314 @tcMethodBind@ is used to type-check both default-method and
315 instance-decl method declarations. We must type-check methods one at a
316 time, because their signatures may have different contexts and
320 type MethodSpec = (Id, -- Global selector Id
321 Id, -- Local Id (class tyvars instantiated)
322 LHsBind Name) -- Binding for the method
325 :: [(TyVar,TcTyVar)] -- Bindings for type environment
326 -> [TcTyVar] -- Instantiated type variables for the
327 -- enclosing class/instance decl.
328 -- They'll be signature tyvars, and we
329 -- want to check that they don't get bound
330 -- Always equal the range of the type envt
331 -> TcThetaType -- Available theta; it's just used for the error message
332 -> [Inst] -- Available from context, used to simplify constraints
333 -- from the method body
334 -> [LSig Name] -- Pragmas (e.g. inline pragmas)
335 -> MethodSpec -- Details of this method
338 tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
339 (sel_id, meth_id, meth_bind)
340 = -- Check the bindings; first adding inst_tyvars to the envt
341 -- so that we don't quantify over them in nested places
342 mkTcSig meth_id `thenM` \ meth_sig ->
344 tcExtendTyVarEnv2 xtve (
345 addErrCtxt (methodCtxt sel_id) $
347 tcMonoBinds (unitBag meth_bind) [meth_sig] NonRecursive
348 ) `thenM` \ ((meth_bind,_), meth_lie) ->
350 -- Now do context reduction. We simplify wrt both the local tyvars
351 -- and the ones of the class/instance decl, so that there is
354 -- op :: Eq a => a -> b -> a
356 -- We do this for each method independently to localise error messages
359 TySigInfo { sig_poly_id = meth_id, sig_tvs = meth_tvs,
360 sig_theta = meth_theta, sig_mono_id = local_meth_id } = meth_sig
362 addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
363 newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts ->
365 all_tyvars = meth_tvs ++ inst_tyvars
366 all_insts = avail_insts ++ meth_dicts
369 (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
370 all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
372 checkSigTyVars all_tyvars `thenM` \ all_tyvars' ->
375 sel_name = idName sel_id
376 inline_prags = [ (is_inl, phase)
377 | L _ (InlineSig is_inl (L _ name) phase) <- prags,
380 | prag@(L _ (SpecSig (L _ name) _)) <- prags,
383 -- Attach inline pragmas as appropriate
384 (final_meth_id, inlines)
385 | ((is_inline, phase) : _) <- inline_prags
386 = (meth_id `setInlinePragma` phase,
387 if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
389 = (meth_id, emptyNameSet)
391 meth_tvs' = take (length meth_tvs) all_tyvars'
392 poly_meth_bind = noLoc $ AbsBinds meth_tvs'
393 (map instToId meth_dicts)
394 [(meth_tvs', final_meth_id, local_meth_id)]
396 (lie_binds `unionBags` meth_bind)
399 -- Deal with specialisation pragmas
400 -- The sel_name is what appears in the pragma
401 tcExtendLocalValEnv2 [(sel_name, final_meth_id)] (
402 getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) ->
404 -- The prag_lie for a SPECIALISE pragma will mention the function itself,
405 -- so we have to simplify them away right now lest they float outwards!
406 bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 ->
407 returnM (spec_binds1 `unionBags` spec_binds2)
408 ) `thenM` \ spec_binds ->
410 returnM (poly_meth_bind `consBag` spec_binds)
413 mkMethodBind :: InstOrigin
414 -> Class -> [TcType] -- Class and instance types
415 -> LHsBinds Name -- Method binding (pick the right one from in here)
417 -> TcM (Maybe Inst, -- Method inst
419 -- Find the binding for the specified method, or make
420 -- up a suitable default method if it isn't there
422 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
423 = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
425 meth_name = idName meth_id
427 -- Figure out what method binding to use
428 -- If the user suppplied one, use it, else construct a default one
429 getSrcSpanM `thenM` \ loc ->
430 (case find_bind (idName sel_id) meth_name meth_binds of
431 Just user_bind -> returnM user_bind
433 mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
435 returnM (noLoc $ FunBind (noLoc meth_name) False
436 [mkSimpleMatch [] rhs placeHolderType])
437 ) `thenM` \ meth_bind ->
439 returnM (mb_inst, (sel_id, meth_id, meth_bind))
441 mkMethId :: InstOrigin -> Class
442 -> Id -> [TcType] -- Selector, and instance types
443 -> TcM (Maybe Inst, Id)
445 -- mkMethId instantiates the selector Id at the specified types
446 mkMethId origin clas sel_id inst_tys
448 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
449 rho_ty = ASSERT( length tyvars == length inst_tys )
450 substTyWith tyvars inst_tys rho
451 (preds,tau) = tcSplitPhiTy rho_ty
452 first_pred = head preds
454 -- The first predicate should be of form (C a b)
455 -- where C is the class in question
456 ASSERT( not (null preds) &&
457 case getClassPredTys_maybe first_pred of
458 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
460 if isSingleton preds then
461 -- If it's the only one, make a 'method'
462 getInstLoc origin `thenM` \ inst_loc ->
463 newMethod inst_loc sel_id inst_tys preds tau `thenM` \ meth_inst ->
464 returnM (Just meth_inst, instToId meth_inst)
466 -- If it's not the only one we need to be careful
467 -- For example, given 'op' defined thus:
469 -- op :: (?x :: String) => a -> a
470 -- (mkMethId op T) should return an Inst with type
471 -- (?x :: String) => T -> T
472 -- That is, the class-op's context is still there.
473 -- BUT: it can't be a Method any more, because it breaks
474 -- INVARIANT 2 of methods. (See the data decl for Inst.)
475 newUnique `thenM` \ uniq ->
476 getSrcSpanM `thenM` \ loc ->
478 real_tau = mkPhiTy (tail preds) tau
479 meth_id = mkUserLocal (getOccName sel_id) uniq real_tau
480 (srcSpanStart loc) --TODO
482 returnM (Nothing, meth_id)
484 -- The user didn't supply a method binding,
485 -- so we have to make up a default binding
486 -- The RHS of a default method depends on the default-method info
487 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
488 = -- An polymorphic default method
489 lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
490 -- Might not be imported, but will be an OrigName
491 traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
492 returnM (nlHsVar dm_name)
494 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
495 = -- No default method
496 -- Warn only if -fwarn-missing-methods
497 doptM Opt_WarnMissingMethods `thenM` \ warn ->
498 warnTc (isInstDecl origin
500 && reportIfUnused (getOccName sel_id))
501 (omittedMethodWarn sel_id) `thenM_`
504 error_rhs = noLoc $ HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType)
505 simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
506 (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
507 error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
509 -- When the type is of form t1 -> t2 -> t3
510 -- make a default method like (\ _ _ -> noMethBind "blah")
511 -- rather than simply (noMethBind "blah")
512 -- Reason: if t1 or t2 are higher-ranked types we get n
513 -- silly ambiguity messages.
514 -- Example: f :: (forall a. Eq a => a -> a) -> Int
516 -- Here, tcSub tries to force (error "urk") to have the right type,
517 -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
518 -- where 't' is fresh ty var. This leads directly to "ambiguous t".
520 -- NB: technically this changes the meaning of the default-default
521 -- method slightly, because `seq` can see the lambdas. Oh well.
522 (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
523 (_,_,tau2) = tcSplitSigmaTy tau1
524 -- Need two splits because the selector can have a type like
525 -- forall a. Foo a => forall b. Eq b => ...
526 (arg_tys, _) = tcSplitFunTys tau2
527 wild_pats = [wildPat | ty <- arg_tys]
529 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
530 = -- A generic default method
531 -- If the method is defined generically, we can only do the job if the
532 -- instance declaration is for a single-parameter type class with
533 -- a type constructor applied to type arguments in the instance decl
534 -- (checkTc, so False provokes the error)
535 ASSERT( isInstDecl origin ) -- We never get here from a class decl
536 do { checkTc (isJust maybe_tycon)
537 (badGenericInstance sel_id (notSimple inst_tys))
538 ; checkTc (tyConHasGenerics tycon)
539 (badGenericInstance sel_id (notGeneric tycon))
542 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
543 (vcat [ppr clas <+> ppr inst_tys,
544 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
546 -- Rename it before returning it
547 ; (rn_rhs, _) <- rnLExpr rhs
550 rhs = mkGenericRhs sel_id clas_tyvar tycon
552 -- The tycon is only used in the generic case, and in that
553 -- case we require that the instance decl is for a single-parameter
554 -- type class with type variable arguments:
555 -- instance (...) => C (T a b)
556 clas_tyvar = head (classTyVars clas)
557 Just tycon = maybe_tycon
558 maybe_tycon = case inst_tys of
559 [ty] -> case tcSplitTyConApp_maybe ty of
560 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
564 isInstDecl InstanceDeclOrigin = True
565 isInstDecl ClassDeclOrigin = False
570 -- The renamer just puts the selector ID as the binder in the method binding
571 -- but we must use the method name; so we substitute it here. Crude but simple.
572 find_bind sel_name meth_name binds
573 = foldlBag seqMaybe Nothing (mapBag f binds)
575 f (L loc1 (FunBind (L loc2 op_name) fix matches)) | op_name == sel_name
576 = Just (L loc1 (FunBind (L loc2 meth_name) fix matches))
581 %************************************************************************
583 \subsection{Extracting generic instance declaration from class declarations}
585 %************************************************************************
587 @getGenericInstances@ extracts the generic instance declarations from a class
588 declaration. For exmaple
593 op{ x+y } (Inl v) = ...
594 op{ x+y } (Inr v) = ...
595 op{ x*y } (v :*: w) = ...
598 gives rise to the instance declarations
600 instance C (x+y) where
604 instance C (x*y) where
612 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
613 getGenericInstances class_decls
614 = do { gen_inst_infos <- mappM get_generics class_decls
615 ; let { gen_inst_info = concat gen_inst_infos }
617 -- Return right away if there is no generic stuff
618 ; if null gen_inst_info then returnM []
621 -- Otherwise print it out
623 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
624 (vcat (map pprInstInfoDetails gen_inst_info)))
625 ; returnM gen_inst_info }}
627 get_generics decl@(L loc (ClassDecl {tcdLName = class_name, tcdMeths = def_methods}))
629 = returnM [] -- The comon case: no generic default methods
631 | otherwise -- A source class decl with generic default methods
632 = recoverM (returnM []) $
634 tcLookupLocatedClass class_name `thenM` \ clas ->
636 -- Group by type, and
637 -- make an InstInfo out of each group
639 groups = groupWith listToBag generic_binds
641 mappM (mkGenericInstance clas (srcSpanStart loc)) groups
642 `thenM` \ inst_infos ->
644 -- Check that there is only one InstInfo for each type constructor
645 -- The main way this can fail is if you write
646 -- f {| a+b |} ... = ...
647 -- f {| x+y |} ... = ...
648 -- Then at this point we'll have an InstInfo for each
650 tc_inst_infos :: [(TyCon, InstInfo)]
651 tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
653 bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
654 group `lengthExceeds` 1]
655 get_uniq (tc,_) = getUnique tc
657 mappM (addErrTc . dupGenericInsts) bad_groups `thenM_`
659 -- Check that there is an InstInfo for each generic type constructor
661 missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
663 checkTc (null missing) (missingGenericInstances missing) `thenM_`
667 generic_binds :: [(HsType Name, LHsBind Name)]
668 generic_binds = getGenericBinds def_methods
671 ---------------------------------
672 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
673 -- Takes a group of method bindings, finds the generic ones, and returns
674 -- them in finite map indexed by the type parameter in the definition.
675 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
677 getGenericBind (L loc (FunBind id infixop matches))
678 = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
680 wrap ms = L loc (FunBind id infixop ms)
684 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
686 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
689 (this,rest) = partition same_t prs
690 same_t (t',v) = t `eqPatType` t'
692 eqPatLType :: LHsType Name -> LHsType Name -> Bool
693 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
695 eqPatType :: HsType Name -> HsType Name -> Bool
696 -- A very simple equality function, only for
697 -- type patterns in generic function definitions.
698 eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
699 eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
700 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
701 eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
702 eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
703 eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
704 eqPatType _ _ = False
706 ---------------------------------
707 mkGenericInstance :: Class -> SrcLoc
708 -> (HsType Name, LHsBinds Name)
711 mkGenericInstance clas loc (hs_ty, binds)
712 -- Make a generic instance declaration
713 -- For example: instance (C a, C b) => C (a+b) where { binds }
715 = -- Extract the universally quantified type variables
716 -- and wrap them as forall'd tyvars, so that kind inference
717 -- works in the standard way
719 sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
720 hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
722 -- Type-check the instance type, and check its form
723 tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty ->
725 (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
727 checkTc (validGenericInstanceType inst_ty)
728 (badGenericInstanceType binds) `thenM_`
730 -- Make the dictionary function.
731 newDFunName clas [inst_ty] loc `thenM` \ dfun_name ->
733 inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
734 dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
737 returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] })
741 %************************************************************************
745 %************************************************************************
748 tcAddDeclCtxt (L loc decl) thing_inside
754 ClassDecl {} -> "class"
755 TySynonym {} -> "type synonym"
756 TyData {tcdND = NewType} -> "newtype"
757 TyData {tcdND = DataType} -> "data type"
759 ctxt = hsep [ptext SLIT("In the"), text thing,
760 ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
763 = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
766 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
769 = hsep [ptext SLIT("Class"), quotes (ppr clas),
770 ptext SLIT("does not have a method"), quotes (ppr op)]
772 omittedMethodWarn sel_id
773 = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
775 badGenericInstance sel_id because
776 = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
780 = vcat [ptext SLIT("because the instance type(s)"),
781 nest 2 (ppr inst_tys),
782 ptext SLIT("is not a simple type of form (T a b c)")]
785 = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
786 ptext SLIT("was not compiled with -fgenerics")]
788 badGenericInstanceType binds
789 = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
792 missingGenericInstances missing
793 = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
795 dupGenericInsts tc_inst_infos
796 = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
797 nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
798 ptext SLIT("All the type patterns for a generic type constructor must be identical")
801 ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
804 = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)