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 RnHsSyn ( maybeGenericMatch, extractHsTyVars )
17 import RnExpr ( rnLExpr )
18 import RnEnv ( lookupTopBndrRn, lookupImportedName )
19 import Inst ( instToId, newDicts, newDictsAtLoc, 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 import TcHsType ( tcHsKindedType, tcHsSigType )
29 import TcSimplify ( tcSimplifyCheck )
30 import TcUnify ( checkSigTyVars, sigCtxt )
31 import TcMType ( tcSkolSigTyVars )
32 import TcType ( Type, SkolemInfo(ClsSkol, InstSkol), UserTypeCtxt( GenPatCtxt ),
33 TcType, TcThetaType, TcTyVar, mkTyVarTys,
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 Type ( substTyWith )
45 import MkId ( mkDefaultMethodId, mkDictFunId )
46 import Id ( Id, idType, idName, mkUserLocal )
47 import Name ( Name, NamedThing(..) )
48 import NameEnv ( NameEnv, lookupNameEnv, mkNameEnv )
49 import NameSet ( nameSetToList )
50 import OccName ( reportIfUnused, mkDefaultMethodOcc )
51 import RdrName ( RdrName, mkDerivedRdrName )
53 import PrelNames ( genericTyConNames )
55 import ErrUtils ( dumpIfSet_dyn )
56 import Util ( count, lengthIs, isSingleton, lengthExceeds )
57 import Unique ( Uniquable(..) )
58 import ListSetOps ( equivClassesByUniq, minusList )
59 import SrcLoc ( Located(..), srcSpanStart, unLoc, noLoc )
60 import Maybes ( seqMaybe, isJust, mapCatMaybes )
61 import List ( partition )
62 import BasicTypes ( RecFlag(..), Boxity(..) )
71 Every class implicitly declares a new data type, corresponding to dictionaries
72 of that class. So, for example:
74 class (D a) => C a where
76 op2 :: forall b. Ord b => a -> b -> b
78 would implicitly declare
80 data CDict a = CDict (D a)
82 (forall b. Ord b => a -> b -> b)
84 (We could use a record decl, but that means changing more of the existing apparatus.
87 For classes with just one superclass+method, we use a newtype decl instead:
90 op :: forallb. a -> b -> b
94 newtype CDict a = CDict (forall b. a -> b -> b)
96 Now DictTy in Type is just a form of type synomym:
97 DictTy c t = TyConTy CDict `AppTy` t
99 Death to "ExpandingDicts".
102 %************************************************************************
104 Type-checking the class op signatures
106 %************************************************************************
109 tcClassSigs :: Name -- Name of the class
114 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
115 -- between tcClassSigs and buildClass
116 tcClassSigs clas sigs def_methods
117 = do { dm_env <- checkDefaultBinds clas op_names def_methods
118 ; mappM (tcClassSig dm_env) op_sigs }
120 op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
121 op_names = [n | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
124 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
125 -- Check default bindings
126 -- a) must be for a class op for this class
127 -- b) must be all generic or all non-generic
128 -- and return a mapping from class-op to Bool
129 -- where True <=> it's a generic default method
130 checkDefaultBinds clas ops binds
131 = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
132 return (mkNameEnv dm_infos)
134 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
135 = do { -- Check that the op is from this class
136 checkTc (op `elem` ops) (badMethodErr clas op)
138 -- Check that all the defns ar generic, or none are
139 ; checkTc (all_generic || none_generic) (mixedGenericErr op)
141 ; returnM (op, all_generic)
144 n_generic = count (isJust . maybeGenericMatch) matches
145 none_generic = n_generic == 0
146 all_generic = matches `lengthIs` n_generic
149 tcClassSig :: NameEnv Bool -- Info about default methods;
153 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
154 = setSrcSpan loc $ do
155 { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
156 ; let dm = case lookupNameEnv dm_env op_name of
158 Just False -> DefMeth
159 Just True -> GenDefMeth
160 ; returnM (op_name, dm, op_ty) }
164 %************************************************************************
166 \subsection[Default methods]{Default methods}
168 %************************************************************************
170 The default methods for a class are each passed a dictionary for the
171 class, so that they get access to the other methods at the same type.
172 So, given the class decl
176 op2 :: Ord b => a -> b -> b -> b
179 op2 x y z = if (op1 x) && (y < z) then y else z
181 we get the default methods:
183 defm.Foo.op1 :: forall a. Foo a => a -> Bool
184 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
186 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
187 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
188 if (op1 a dfoo x) && (< b dord y z) then y else z
191 When we come across an instance decl, we may need to use the default
194 instance Foo Int where {}
198 const.Foo.Int.op1 :: Int -> Bool
199 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
201 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
202 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
204 dfun.Foo.Int :: Foo Int
205 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
207 Notice that, as with method selectors above, we assume that dictionary
208 application is curried, so there's no need to mention the Ord dictionary
209 in const.Foo.Int.op2 (or the type variable).
212 instance Foo a => Foo [a] where {}
214 dfun.Foo.List :: forall a. Foo a -> Foo [a]
216 = /\ a -> \ dfoo_a ->
218 op1 = defm.Foo.op1 [a] dfoo_list
219 op2 = defm.Foo.op2 [a] dfoo_list
220 dfoo_list = (op1, op2)
225 @tcClassDecls2@ generates bindings for polymorphic default methods
226 (generic default methods have by now turned into instance declarations)
229 tcClassDecl2 :: LTyClDecl Name -- The class declaration
230 -> TcM (LHsBinds Id, [Id])
232 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
233 tcdMeths = default_binds}))
234 = recoverM (returnM (emptyLHsBinds, [])) $
236 tcLookupLocatedClass class_name `thenM` \ clas ->
238 -- We make a separate binding for each default method.
239 -- At one time I used a single AbsBinds for all of them, thus
240 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
241 -- But that desugars into
242 -- ds = \d -> (..., ..., ...)
243 -- dm1 = \d -> case ds d of (a,b,c) -> a
244 -- And since ds is big, it doesn't get inlined, so we don't get good
245 -- default methods. Better to make separate AbsBinds for each
247 (tyvars, _, _, op_items) = classBigSig clas
248 prag_fn = mkPragFun sigs
249 tc_dm = tcDefMeth clas tyvars default_binds prag_fn
251 dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
252 -- Generate code for polymorphic default methods only
253 -- (Generic default methods have turned into instance decls by now.)
254 -- This is incompatible with Hugs, which expects a polymorphic
255 -- default method for every class op, regardless of whether or not
256 -- the programmer supplied an explicit default decl for the class.
257 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
259 mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
260 returnM (listToBag defm_binds, concat dm_ids_s)
262 tcDefMeth clas tyvars binds_in prag_fn sel_id
263 = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
264 ; let rigid_info = ClsSkol clas
265 clas_tyvars = tcSkolSigTyVars rigid_info tyvars
266 inst_tys = mkTyVarTys clas_tyvars
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 origin = SigOrigin rigid_info
272 ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
273 ; [this_dict] <- newDicts origin theta
274 ; (defm_bind, insts_needed) <- getLIE (tcMethodBind clas_tyvars theta
275 [this_dict] prag_fn meth_info)
277 ; addErrCtxt (defltMethCtxt clas) $ do
280 { dict_binds <- tcSimplifyCheck
281 (ptext SLIT("class") <+> ppr clas)
286 -- Simplification can do unification
287 ; checkSigTyVars clas_tyvars
290 -- We'll have an inline pragma on the local binding, made by tcMethodBind
291 -- but that's not enough; we want one on the global default method too
292 -- Specialisations, on the other hand, belong on the thing inside only, I think
293 ; let (_,dm_inst_id,_) = meth_info
294 sel_name = idName sel_id
295 inline_prags = filter isInlineLSig (prag_fn sel_name)
296 ; prags <- tcPrags dm_inst_id inline_prags
298 ; let full_bind = AbsBinds clas_tyvars
300 [(clas_tyvars, local_dm_id, dm_inst_id, prags)]
301 (dict_binds `unionBags` defm_bind)
302 ; returnM (noLoc full_bind, [local_dm_id]) }}
304 mkDefMethRdrName :: Id -> RdrName
305 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
309 %************************************************************************
311 \subsection{Typechecking a method}
313 %************************************************************************
315 @tcMethodBind@ is used to type-check both default-method and
316 instance-decl method declarations. We must type-check methods one at a
317 time, because their signatures may have different contexts and
321 type MethodSpec = (Id, -- Global selector Id
322 Id, -- Local Id (class tyvars instantiated)
323 LHsBind Name) -- Binding for the method
326 :: [TcTyVar] -- Skolemised 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 -- Also they are scoped, so we bring them into scope
331 -- Always equal the range of the type envt
332 -> TcThetaType -- Available theta; it's just used for the error message
333 -> [Inst] -- Available from context, used to simplify constraints
334 -- from the method body
335 -> TcPragFun -- Pragmas (e.g. inline pragmas)
336 -> MethodSpec -- Details of this method
339 tcMethodBind inst_tyvars inst_theta avail_insts prag_fn
340 (sel_id, meth_id, meth_bind)
341 = recoverM (returnM emptyLHsBinds) $
342 -- If anything fails, recover returning no bindings.
343 -- This is particularly useful when checking the default-method binding of
344 -- a class decl. If we don't recover, we don't add the default method to
345 -- the type enviroment, and we get a tcLookup failure on $dmeth later.
347 -- Check the bindings; first adding inst_tyvars to the envt
348 -- so that we don't quantify over them in nested places
351 let meth_sig = noLoc (TypeSig (noLoc (idName meth_id)) (noLoc bogus_ty))
352 bogus_ty = HsTupleTy Boxed [] -- *Only* used to extract scoped type
353 -- variables... and there aren't any
354 lookup_sig name = ASSERT( name == idName meth_id )
357 tcExtendTyVarEnv inst_tyvars (
358 tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
359 addErrCtxt (methodCtxt sel_id) $
361 tcMonoBinds [meth_bind] lookup_sig Recursive
362 ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
364 -- Now do context reduction. We simplify wrt both the local tyvars
365 -- and the ones of the class/instance decl, so that there is
368 -- op :: Eq a => a -> b -> a
370 -- We do this for each method independently to localise error messages
373 [(_, Just sig, local_meth_id)] = mono_bind_infos
376 addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
377 newDictsAtLoc (sig_loc sig) (sig_theta sig) `thenM` \ meth_dicts ->
379 meth_tvs = sig_tvs sig
380 all_tyvars = meth_tvs ++ inst_tyvars
381 all_insts = avail_insts ++ meth_dicts
382 sel_name = idName sel_id
385 (ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
386 all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
388 checkSigTyVars all_tyvars `thenM_`
390 tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
392 poly_meth_bind = noLoc $ AbsBinds meth_tvs
393 (map instToId meth_dicts)
394 [(meth_tvs, meth_id, local_meth_id, prags)]
395 (lie_binds `unionBags` meth_bind)
397 returnM (unitBag poly_meth_bind)
400 mkMethodBind :: InstOrigin
401 -> Class -> [TcType] -- Class and instance types
402 -> LHsBinds Name -- Method binding (pick the right one from in here)
404 -> TcM (Maybe Inst, -- Method inst
406 -- Find the binding for the specified method, or make
407 -- up a suitable default method if it isn't there
409 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
410 = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
412 meth_name = idName meth_id
414 -- Figure out what method binding to use
415 -- If the user suppplied one, use it, else construct a default one
416 getSrcSpanM `thenM` \ loc ->
417 (case find_bind (idName sel_id) meth_name meth_binds of
418 Just user_bind -> returnM user_bind
420 mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
422 returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
423 ) `thenM` \ meth_bind ->
425 returnM (mb_inst, (sel_id, meth_id, meth_bind))
427 mkMethId :: InstOrigin -> Class
428 -> Id -> [TcType] -- Selector, and instance types
429 -> TcM (Maybe Inst, Id)
431 -- mkMethId instantiates the selector Id at the specified types
432 mkMethId origin clas sel_id inst_tys
434 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
435 rho_ty = ASSERT( length tyvars == length inst_tys )
436 substTyWith tyvars inst_tys rho
437 (preds,tau) = tcSplitPhiTy rho_ty
438 first_pred = head preds
440 -- The first predicate should be of form (C a b)
441 -- where C is the class in question
442 ASSERT( not (null preds) &&
443 case getClassPredTys_maybe first_pred of
444 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
446 if isSingleton preds then
447 -- If it's the only one, make a 'method'
448 getInstLoc origin `thenM` \ inst_loc ->
449 newMethod inst_loc sel_id inst_tys `thenM` \ meth_inst ->
450 returnM (Just meth_inst, instToId meth_inst)
452 -- If it's not the only one we need to be careful
453 -- For example, given 'op' defined thus:
455 -- op :: (?x :: String) => a -> a
456 -- (mkMethId op T) should return an Inst with type
457 -- (?x :: String) => T -> T
458 -- That is, the class-op's context is still there.
459 -- BUT: it can't be a Method any more, because it breaks
460 -- INVARIANT 2 of methods. (See the data decl for Inst.)
461 newUnique `thenM` \ uniq ->
462 getSrcSpanM `thenM` \ loc ->
464 real_tau = mkPhiTy (tail preds) tau
465 meth_id = mkUserLocal (getOccName sel_id) uniq real_tau
466 (srcSpanStart loc) --TODO
468 returnM (Nothing, meth_id)
470 -- The user didn't supply a method binding,
471 -- so we have to make up a default binding
472 -- The RHS of a default method depends on the default-method info
473 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
474 = -- An polymorphic default method
475 lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
476 -- Might not be imported, but will be an OrigName
477 traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
478 returnM (nlHsVar dm_name)
480 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
481 = -- No default method
482 -- Warn only if -fwarn-missing-methods
483 doptM Opt_WarnMissingMethods `thenM` \ warn ->
484 warnTc (isInstDecl origin
486 && reportIfUnused (getOccName sel_id))
487 (omittedMethodWarn sel_id) `thenM_`
490 error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
491 simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
492 (nlHsLit (HsStringPrim (mkFastString error_msg)))
493 error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
495 -- When the type is of form t1 -> t2 -> t3
496 -- make a default method like (\ _ _ -> noMethBind "blah")
497 -- rather than simply (noMethBind "blah")
498 -- Reason: if t1 or t2 are higher-ranked types we get n
499 -- silly ambiguity messages.
500 -- Example: f :: (forall a. Eq a => a -> a) -> Int
502 -- Here, tcSub tries to force (error "urk") to have the right type,
503 -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
504 -- where 't' is fresh ty var. This leads directly to "ambiguous t".
506 -- NB: technically this changes the meaning of the default-default
507 -- method slightly, because `seq` can see the lambdas. Oh well.
508 (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
509 (_,_,tau2) = tcSplitSigmaTy tau1
510 -- Need two splits because the selector can have a type like
511 -- forall a. Foo a => forall b. Eq b => ...
512 (arg_tys, _) = tcSplitFunTys tau2
513 wild_pats = [nlWildPat | ty <- arg_tys]
515 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
516 = -- A generic default method
517 -- If the method is defined generically, we can only do the job if the
518 -- instance declaration is for a single-parameter type class with
519 -- a type constructor applied to type arguments in the instance decl
520 -- (checkTc, so False provokes the error)
521 ASSERT( isInstDecl origin ) -- We never get here from a class decl
522 do { checkTc (isJust maybe_tycon)
523 (badGenericInstance sel_id (notSimple inst_tys))
524 ; checkTc (tyConHasGenerics tycon)
525 (badGenericInstance sel_id (notGeneric tycon))
528 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
529 (vcat [ppr clas <+> ppr inst_tys,
530 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
532 -- Rename it before returning it
533 ; (rn_rhs, _) <- rnLExpr rhs
536 rhs = mkGenericRhs sel_id clas_tyvar tycon
538 -- The tycon is only used in the generic case, and in that
539 -- case we require that the instance decl is for a single-parameter
540 -- type class with type variable arguments:
541 -- instance (...) => C (T a b)
542 clas_tyvar = head (classTyVars clas)
543 Just tycon = maybe_tycon
544 maybe_tycon = case inst_tys of
545 [ty] -> case tcSplitTyConApp_maybe ty of
546 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
550 isInstDecl (SigOrigin (InstSkol _)) = True
551 isInstDecl (SigOrigin (ClsSkol _)) = False
556 -- The renamer just puts the selector ID as the binder in the method binding
557 -- but we must use the method name; so we substitute it here. Crude but simple.
558 find_bind sel_name meth_name binds
559 = foldlBag seqMaybe Nothing (mapBag f binds)
561 f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
562 = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
567 %************************************************************************
569 \subsection{Extracting generic instance declaration from class declarations}
571 %************************************************************************
573 @getGenericInstances@ extracts the generic instance declarations from a class
574 declaration. For exmaple
579 op{ x+y } (Inl v) = ...
580 op{ x+y } (Inr v) = ...
581 op{ x*y } (v :*: w) = ...
584 gives rise to the instance declarations
586 instance C (x+y) where
590 instance C (x*y) where
598 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
599 getGenericInstances class_decls
600 = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls
601 ; let { gen_inst_info = concat gen_inst_infos }
603 -- Return right away if there is no generic stuff
604 ; if null gen_inst_info then returnM []
607 -- Otherwise print it out
609 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
610 (vcat (map pprInstInfoDetails gen_inst_info)))
611 ; returnM gen_inst_info }}
613 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
615 = returnM [] -- The comon case: no generic default methods
617 | otherwise -- A source class decl with generic default methods
618 = recoverM (returnM []) $
620 tcLookupLocatedClass class_name `thenM` \ clas ->
622 -- Group by type, and
623 -- make an InstInfo out of each group
625 groups = groupWith listToBag generic_binds
627 mappM (mkGenericInstance clas) groups `thenM` \ inst_infos ->
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 tc_inst_infos :: [(TyCon, InstInfo)]
636 tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
638 bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
639 group `lengthExceeds` 1]
640 get_uniq (tc,_) = getUnique tc
642 mappM (addErrTc . dupGenericInsts) bad_groups `thenM_`
644 -- Check that there is an InstInfo for each generic type constructor
646 missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
648 checkTc (null missing) (missingGenericInstances missing) `thenM_`
652 generic_binds :: [(HsType Name, LHsBind Name)]
653 generic_binds = getGenericBinds def_methods
656 ---------------------------------
657 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
658 -- Takes a group of method bindings, finds the generic ones, and returns
659 -- them in finite map indexed by the type parameter in the definition.
660 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
662 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
663 = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
665 wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
669 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
671 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
674 (this,rest) = partition same_t prs
675 same_t (t',v) = t `eqPatType` t'
677 eqPatLType :: LHsType Name -> LHsType Name -> Bool
678 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
680 eqPatType :: HsType Name -> HsType Name -> Bool
681 -- A very simple equality function, only for
682 -- type patterns in generic function definitions.
683 eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
684 eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
685 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
686 eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
687 eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
688 eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
689 eqPatType _ _ = False
691 ---------------------------------
692 mkGenericInstance :: Class
693 -> (HsType Name, LHsBinds Name)
696 mkGenericInstance clas (hs_ty, binds)
697 -- Make a generic instance declaration
698 -- For example: instance (C a, C b) => C (a+b) where { binds }
700 = -- Extract the universally quantified type variables
701 -- and wrap them as forall'd tyvars, so that kind inference
702 -- works in the standard way
704 sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
705 hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
707 -- Type-check the instance type, and check its form
708 tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty ->
710 (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
712 checkTc (validGenericInstanceType inst_ty)
713 (badGenericInstanceType binds) `thenM_`
715 -- Make the dictionary function.
716 getSrcSpanM `thenM` \ span ->
717 getOverlapFlag `thenM` \ overlap_flag ->
718 newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name ->
720 inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
721 dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
722 ispec = mkLocalInstance dfun_id overlap_flag
724 returnM (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
728 %************************************************************************
732 %************************************************************************
735 tcAddDeclCtxt decl thing_inside
736 = addErrCtxt ctxt thing_inside
739 ClassDecl {} -> "class"
740 TySynonym {} -> "type synonym"
741 TyData {tcdND = NewType} -> "newtype"
742 TyData {tcdND = DataType} -> "data type"
744 ctxt = hsep [ptext SLIT("In the"), text thing,
745 ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
748 = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
751 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
754 = hsep [ptext SLIT("Class"), quotes (ppr clas),
755 ptext SLIT("does not have a method"), quotes (ppr op)]
757 omittedMethodWarn sel_id
758 = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
760 badGenericInstance sel_id because
761 = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
765 = vcat [ptext SLIT("because the instance type(s)"),
766 nest 2 (ppr inst_tys),
767 ptext SLIT("is not a simple type of form (T a b c)")]
770 = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
771 ptext SLIT("was not compiled with -fgenerics")]
773 badGenericInstanceType binds
774 = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
777 missingGenericInstances missing
778 = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
780 dupGenericInsts tc_inst_infos
781 = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
782 nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
783 ptext SLIT("All the type patterns for a generic type constructor must be identical")
786 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
789 = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)