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(..) )
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, mkNameEnv )
49 import NameSet ( emptyNameSet, unitNameSet, nameSetToList )
50 import OccName ( reportIfUnused, mkDefaultMethodOcc )
51 import RdrName ( RdrName, mkDerivedRdrName )
54 import PrelNames ( genericTyConNames )
56 import UnicodeUtil ( stringToUtf8 )
57 import ErrUtils ( dumpIfSet_dyn )
58 import Util ( count, lengthIs, isSingleton, lengthExceeds )
59 import Unique ( Uniquable(..) )
60 import ListSetOps ( equivClassesByUniq, minusList )
61 import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
62 import Maybes ( seqMaybe, isJust, mapCatMaybes )
63 import List ( partition )
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 _ (Sig _ _)) <- sigs]
122 op_names = [n | sig@(L _ (Sig (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 (L _ op) _ 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 (Sig (L _ op_name) op_hs_ty))
155 = addSrcSpan 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 (emptyBag, [])) $
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 prags = filter (isPragSig.unLoc) sigs
250 tc_dm = tcDefMeth clas tyvars default_binds prags
252 dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
253 -- Generate code for polymorphic default methods only
254 -- (Generic default methods have turned into instance decls by now.)
255 -- This is incompatible with Hugs, which expects a polymorphic
256 -- default method for every class op, regardless of whether or not
257 -- the programmer supplied an explicit default decl for the class.
258 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
260 mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
261 returnM (listToBag defm_binds, concat dm_ids_s)
263 tcDefMeth clas tyvars binds_in prags sel_id
264 = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
265 tcInstTyVars ClsTv tyvars `thenM` \ (clas_tyvars, inst_tys, _) ->
267 dm_ty = idType sel_id -- Same as dict selector!
268 theta = [mkClassPred clas inst_tys]
269 local_dm_id = mkDefaultMethodId dm_name dm_ty
270 xtve = tyvars `zip` clas_tyvars
271 origin = ClassDeclOrigin
273 mkMethodBind origin clas inst_tys
274 binds_in (sel_id, DefMeth) `thenM` \ (_, meth_info) ->
275 newDicts origin theta `thenM` \ [this_dict] ->
276 getLIE (tcMethodBind xtve clas_tyvars theta
277 [this_dict] prags meth_info) `thenM` \ (defm_bind, insts_needed) ->
279 addErrCtxt (defltMethCtxt clas) $
283 (ptext SLIT("class") <+> ppr clas)
286 insts_needed `thenM` \ dict_binds ->
288 -- Simplification can do unification
289 checkSigTyVars clas_tyvars `thenM` \ clas_tyvars' ->
292 (_,dm_inst_id,_) = meth_info
296 [(clas_tyvars', local_dm_id, dm_inst_id)]
297 emptyNameSet -- No inlines (yet)
298 (dict_binds `unionBags` defm_bind)
300 returnM (noLoc full_bind, [local_dm_id])
302 mkDefMethRdrName :: Id -> RdrName
303 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
307 %************************************************************************
309 \subsection{Typechecking a method}
311 %************************************************************************
313 @tcMethodBind@ is used to type-check both default-method and
314 instance-decl method declarations. We must type-check methods one at a
315 time, because their signatures may have different contexts and
319 type MethodSpec = (Id, -- Global selector Id
320 Id, -- Local Id (class tyvars instantiated)
321 LHsBind Name) -- Binding for the method
324 :: [(TyVar,TcTyVar)] -- Bindings for type environment
325 -> [TcTyVar] -- Instantiated type variables for the
326 -- enclosing class/instance decl.
327 -- They'll be signature tyvars, and we
328 -- want to check that they don't get bound
329 -- Always equal the range of the type envt
330 -> TcThetaType -- Available theta; it's just used for the error message
331 -> [Inst] -- Available from context, used to simplify constraints
332 -- from the method body
333 -> [LSig Name] -- Pragmas (e.g. inline pragmas)
334 -> MethodSpec -- Details of this method
337 tcMethodBind xtve inst_tyvars inst_theta avail_insts prags
338 (sel_id, meth_id, meth_bind)
339 = recoverM (returnM emptyBag) $
340 -- If anything fails, recover returning no bindings.
341 -- This is particularly useful when checking the default-method binding of
342 -- a class decl. If we don't recover, we don't add the default method to
343 -- the type enviroment, and we get a tcLookup failure on $dmeth later.
345 -- Check the bindings; first adding inst_tyvars to the envt
346 -- so that we don't quantify over them in nested places
347 mkTcSig meth_id `thenM` \ meth_sig ->
349 tcExtendTyVarEnv2 xtve (
350 addErrCtxt (methodCtxt sel_id) $
352 tcMonoBinds (unitBag meth_bind) [meth_sig] NonRecursive
353 ) `thenM` \ ((meth_bind,_), meth_lie) ->
355 -- Now do context reduction. We simplify wrt both the local tyvars
356 -- and the ones of the class/instance decl, so that there is
359 -- op :: Eq a => a -> b -> a
361 -- We do this for each method independently to localise error messages
364 TySigInfo { sig_poly_id = meth_id, sig_tvs = meth_tvs,
365 sig_theta = meth_theta, sig_mono_id = local_meth_id } = meth_sig
367 addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
368 newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts ->
370 all_tyvars = meth_tvs ++ inst_tyvars
371 all_insts = avail_insts ++ meth_dicts
374 (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
375 all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
377 checkSigTyVars all_tyvars `thenM` \ all_tyvars' ->
380 sel_name = idName sel_id
381 inline_prags = [ (is_inl, phase)
382 | L _ (InlineSig is_inl (L _ name) phase) <- prags,
385 | prag@(L _ (SpecSig (L _ name) _)) <- prags,
388 -- Attach inline pragmas as appropriate
389 (final_meth_id, inlines)
390 | ((is_inline, phase) : _) <- inline_prags
391 = (meth_id `setInlinePragma` phase,
392 if is_inline then unitNameSet (idName meth_id) else emptyNameSet)
394 = (meth_id, emptyNameSet)
396 meth_tvs' = take (length meth_tvs) all_tyvars'
397 poly_meth_bind = noLoc $ AbsBinds meth_tvs'
398 (map instToId meth_dicts)
399 [(meth_tvs', final_meth_id, local_meth_id)]
401 (lie_binds `unionBags` meth_bind)
404 -- Deal with specialisation pragmas
405 -- The sel_name is what appears in the pragma
406 tcExtendLocalValEnv2 [(sel_name, final_meth_id)] (
407 getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) ->
409 -- The prag_lie for a SPECIALISE pragma will mention the function itself,
410 -- so we have to simplify them away right now lest they float outwards!
411 bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 ->
412 returnM (spec_binds1 `unionBags` spec_binds2)
413 ) `thenM` \ spec_binds ->
415 returnM (poly_meth_bind `consBag` spec_binds)
418 mkMethodBind :: InstOrigin
419 -> Class -> [TcType] -- Class and instance types
420 -> LHsBinds Name -- Method binding (pick the right one from in here)
422 -> TcM (Maybe Inst, -- Method inst
424 -- Find the binding for the specified method, or make
425 -- up a suitable default method if it isn't there
427 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
428 = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
430 meth_name = idName meth_id
432 -- Figure out what method binding to use
433 -- If the user suppplied one, use it, else construct a default one
434 getSrcSpanM `thenM` \ loc ->
435 (case find_bind (idName sel_id) meth_name meth_binds of
436 Just user_bind -> returnM user_bind
438 mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
440 returnM (noLoc $ FunBind (noLoc meth_name) False
441 [mkSimpleMatch [] rhs placeHolderType])
442 ) `thenM` \ meth_bind ->
444 returnM (mb_inst, (sel_id, meth_id, meth_bind))
446 mkMethId :: InstOrigin -> Class
447 -> Id -> [TcType] -- Selector, and instance types
448 -> TcM (Maybe Inst, Id)
450 -- mkMethId instantiates the selector Id at the specified types
451 mkMethId origin clas sel_id inst_tys
453 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
454 rho_ty = ASSERT( length tyvars == length inst_tys )
455 substTyWith tyvars inst_tys rho
456 (preds,tau) = tcSplitPhiTy rho_ty
457 first_pred = head preds
459 -- The first predicate should be of form (C a b)
460 -- where C is the class in question
461 ASSERT( not (null preds) &&
462 case getClassPredTys_maybe first_pred of
463 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
465 if isSingleton preds then
466 -- If it's the only one, make a 'method'
467 getInstLoc origin `thenM` \ inst_loc ->
468 newMethod inst_loc sel_id inst_tys preds tau `thenM` \ meth_inst ->
469 returnM (Just meth_inst, instToId meth_inst)
471 -- If it's not the only one we need to be careful
472 -- For example, given 'op' defined thus:
474 -- op :: (?x :: String) => a -> a
475 -- (mkMethId op T) should return an Inst with type
476 -- (?x :: String) => T -> T
477 -- That is, the class-op's context is still there.
478 -- BUT: it can't be a Method any more, because it breaks
479 -- INVARIANT 2 of methods. (See the data decl for Inst.)
480 newUnique `thenM` \ uniq ->
481 getSrcSpanM `thenM` \ loc ->
483 real_tau = mkPhiTy (tail preds) tau
484 meth_id = mkUserLocal (getOccName sel_id) uniq real_tau
485 (srcSpanStart loc) --TODO
487 returnM (Nothing, meth_id)
489 -- The user didn't supply a method binding,
490 -- so we have to make up a default binding
491 -- The RHS of a default method depends on the default-method info
492 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
493 = -- An polymorphic default method
494 lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
495 -- Might not be imported, but will be an OrigName
496 traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
497 returnM (nlHsVar dm_name)
499 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
500 = -- No default method
501 -- Warn only if -fwarn-missing-methods
502 doptM Opt_WarnMissingMethods `thenM` \ warn ->
503 warnTc (isInstDecl origin
505 && reportIfUnused (getOccName sel_id))
506 (omittedMethodWarn sel_id) `thenM_`
509 error_rhs = noLoc $ HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType)
510 simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
511 (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg))))
512 error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
514 -- When the type is of form t1 -> t2 -> t3
515 -- make a default method like (\ _ _ -> noMethBind "blah")
516 -- rather than simply (noMethBind "blah")
517 -- Reason: if t1 or t2 are higher-ranked types we get n
518 -- silly ambiguity messages.
519 -- Example: f :: (forall a. Eq a => a -> a) -> Int
521 -- Here, tcSub tries to force (error "urk") to have the right type,
522 -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
523 -- where 't' is fresh ty var. This leads directly to "ambiguous t".
525 -- NB: technically this changes the meaning of the default-default
526 -- method slightly, because `seq` can see the lambdas. Oh well.
527 (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
528 (_,_,tau2) = tcSplitSigmaTy tau1
529 -- Need two splits because the selector can have a type like
530 -- forall a. Foo a => forall b. Eq b => ...
531 (arg_tys, _) = tcSplitFunTys tau2
532 wild_pats = [wildPat | ty <- arg_tys]
534 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
535 = -- A generic default method
536 -- If the method is defined generically, we can only do the job if the
537 -- instance declaration is for a single-parameter type class with
538 -- a type constructor applied to type arguments in the instance decl
539 -- (checkTc, so False provokes the error)
540 ASSERT( isInstDecl origin ) -- We never get here from a class decl
541 do { checkTc (isJust maybe_tycon)
542 (badGenericInstance sel_id (notSimple inst_tys))
543 ; checkTc (tyConHasGenerics tycon)
544 (badGenericInstance sel_id (notGeneric tycon))
547 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
548 (vcat [ppr clas <+> ppr inst_tys,
549 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
551 -- Rename it before returning it
552 ; (rn_rhs, _) <- rnLExpr rhs
555 rhs = mkGenericRhs sel_id clas_tyvar tycon
557 -- The tycon is only used in the generic case, and in that
558 -- case we require that the instance decl is for a single-parameter
559 -- type class with type variable arguments:
560 -- instance (...) => C (T a b)
561 clas_tyvar = head (classTyVars clas)
562 Just tycon = maybe_tycon
563 maybe_tycon = case inst_tys of
564 [ty] -> case tcSplitTyConApp_maybe ty of
565 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
569 isInstDecl InstanceDeclOrigin = True
570 isInstDecl ClassDeclOrigin = False
575 -- The renamer just puts the selector ID as the binder in the method binding
576 -- but we must use the method name; so we substitute it here. Crude but simple.
577 find_bind sel_name meth_name binds
578 = foldlBag seqMaybe Nothing (mapBag f binds)
580 f (L loc1 (FunBind (L loc2 op_name) fix matches)) | op_name == sel_name
581 = Just (L loc1 (FunBind (L loc2 meth_name) fix matches))
586 %************************************************************************
588 \subsection{Extracting generic instance declaration from class declarations}
590 %************************************************************************
592 @getGenericInstances@ extracts the generic instance declarations from a class
593 declaration. For exmaple
598 op{ x+y } (Inl v) = ...
599 op{ x+y } (Inr v) = ...
600 op{ x*y } (v :*: w) = ...
603 gives rise to the instance declarations
605 instance C (x+y) where
609 instance C (x*y) where
617 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
618 getGenericInstances class_decls
619 = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls
620 ; let { gen_inst_info = concat gen_inst_infos }
622 -- Return right away if there is no generic stuff
623 ; if null gen_inst_info then returnM []
626 -- Otherwise print it out
628 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
629 (vcat (map pprInstInfoDetails gen_inst_info)))
630 ; returnM gen_inst_info }}
632 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
634 = returnM [] -- The comon case: no generic default methods
636 | otherwise -- A source class decl with generic default methods
637 = recoverM (returnM []) $
639 tcLookupLocatedClass class_name `thenM` \ clas ->
641 -- Group by type, and
642 -- make an InstInfo out of each group
644 groups = groupWith listToBag generic_binds
646 mappM (mkGenericInstance clas) groups `thenM` \ inst_infos ->
648 -- Check that there is only one InstInfo for each type constructor
649 -- The main way this can fail is if you write
650 -- f {| a+b |} ... = ...
651 -- f {| x+y |} ... = ...
652 -- Then at this point we'll have an InstInfo for each
654 tc_inst_infos :: [(TyCon, InstInfo)]
655 tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
657 bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
658 group `lengthExceeds` 1]
659 get_uniq (tc,_) = getUnique tc
661 mappM (addErrTc . dupGenericInsts) bad_groups `thenM_`
663 -- Check that there is an InstInfo for each generic type constructor
665 missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
667 checkTc (null missing) (missingGenericInstances missing) `thenM_`
671 generic_binds :: [(HsType Name, LHsBind Name)]
672 generic_binds = getGenericBinds def_methods
675 ---------------------------------
676 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
677 -- Takes a group of method bindings, finds the generic ones, and returns
678 -- them in finite map indexed by the type parameter in the definition.
679 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
681 getGenericBind (L loc (FunBind id infixop matches))
682 = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
684 wrap ms = L loc (FunBind id infixop ms)
688 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
690 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
693 (this,rest) = partition same_t prs
694 same_t (t',v) = t `eqPatType` t'
696 eqPatLType :: LHsType Name -> LHsType Name -> Bool
697 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
699 eqPatType :: HsType Name -> HsType Name -> Bool
700 -- A very simple equality function, only for
701 -- type patterns in generic function definitions.
702 eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
703 eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
704 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
705 eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
706 eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
707 eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
708 eqPatType _ _ = False
710 ---------------------------------
711 mkGenericInstance :: Class
712 -> (HsType Name, LHsBinds Name)
715 mkGenericInstance clas (hs_ty, binds)
716 -- Make a generic instance declaration
717 -- For example: instance (C a, C b) => C (a+b) where { binds }
719 = -- Extract the universally quantified type variables
720 -- and wrap them as forall'd tyvars, so that kind inference
721 -- works in the standard way
723 sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
724 hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
726 -- Type-check the instance type, and check its form
727 tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty ->
729 (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
731 checkTc (validGenericInstanceType inst_ty)
732 (badGenericInstanceType binds) `thenM_`
734 -- Make the dictionary function.
735 getSrcSpanM `thenM` \ span ->
736 newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name ->
738 inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
739 dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
742 returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] })
746 %************************************************************************
750 %************************************************************************
753 tcAddDeclCtxt decl thing_inside
754 = addErrCtxt ctxt thing_inside
757 ClassDecl {} -> "class"
758 TySynonym {} -> "type synonym"
759 TyData {tcdND = NewType} -> "newtype"
760 TyData {tcdND = DataType} -> "data type"
762 ctxt = hsep [ptext SLIT("In the"), text thing,
763 ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
766 = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
769 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
772 = hsep [ptext SLIT("Class"), quotes (ppr clas),
773 ptext SLIT("does not have a method"), quotes (ppr op)]
775 omittedMethodWarn sel_id
776 = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
778 badGenericInstance sel_id because
779 = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
783 = vcat [ptext SLIT("because the instance type(s)"),
784 nest 2 (ppr inst_tys),
785 ptext SLIT("is not a simple type of form (T a b c)")]
788 = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
789 ptext SLIT("was not compiled with -fgenerics")]
791 badGenericInstanceType binds
792 = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
795 missingGenericInstances missing
796 = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
798 dupGenericInsts tc_inst_infos
799 = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
800 nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
801 ptext SLIT("All the type patterns for a generic type constructor must be identical")
804 ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst)
807 = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)