2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 Typechecking class declarations
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module TcClassDcl ( tcClassSigs, tcClassDecl2,
18 MethodSpec, tcMethodBind, mkMethodBind,
19 tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
22 #include "HsVersions.h"
68 Every class implicitly declares a new data type, corresponding to dictionaries
69 of that class. So, for example:
71 class (D a) => C a where
73 op2 :: forall b. Ord b => a -> b -> b
75 would implicitly declare
77 data CDict a = CDict (D a)
79 (forall b. Ord b => a -> b -> b)
81 (We could use a record decl, but that means changing more of the existing apparatus.
84 For classes with just one superclass+method, we use a newtype decl instead:
87 op :: forallb. a -> b -> b
91 newtype CDict a = CDict (forall b. a -> b -> b)
93 Now DictTy in Type is just a form of type synomym:
94 DictTy c t = TyConTy CDict `AppTy` t
96 Death to "ExpandingDicts".
99 %************************************************************************
101 Type-checking the class op signatures
103 %************************************************************************
106 tcClassSigs :: Name -- Name of the class
111 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
112 -- between tcClassSigs and buildClass
113 tcClassSigs clas sigs def_methods
114 = do { dm_env <- checkDefaultBinds clas op_names def_methods
115 ; mappM (tcClassSig dm_env) op_sigs }
117 op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
118 op_names = [n | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
121 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
122 -- Check default bindings
123 -- a) must be for a class op for this class
124 -- b) must be all generic or all non-generic
125 -- and return a mapping from class-op to Bool
126 -- where True <=> it's a generic default method
127 checkDefaultBinds clas ops binds
128 = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
129 return (mkNameEnv dm_infos)
131 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
132 = do { -- Check that the op is from this class
133 checkTc (op `elem` ops) (badMethodErr clas op)
135 -- Check that all the defns ar generic, or none are
136 ; checkTc (all_generic || none_generic) (mixedGenericErr op)
138 ; returnM (op, all_generic)
141 n_generic = count (isJust . maybeGenericMatch) matches
142 none_generic = n_generic == 0
143 all_generic = matches `lengthIs` n_generic
146 tcClassSig :: NameEnv Bool -- Info about default methods;
150 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
151 = setSrcSpan loc $ do
152 { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
153 ; let dm = case lookupNameEnv dm_env op_name of
155 Just False -> DefMeth
156 Just True -> GenDefMeth
157 ; returnM (op_name, dm, op_ty) }
161 %************************************************************************
163 \subsection[Default methods]{Default methods}
165 %************************************************************************
167 The default methods for a class are each passed a dictionary for the
168 class, so that they get access to the other methods at the same type.
169 So, given the class decl
173 op2 :: Ord b => a -> b -> b -> b
176 op2 x y z = if (op1 x) && (y < z) then y else z
178 we get the default methods:
180 defm.Foo.op1 :: forall a. Foo a => a -> Bool
181 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
183 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
184 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
185 if (op1 a dfoo x) && (< b dord y z) then y else z
188 When we come across an instance decl, we may need to use the default
191 instance Foo Int where {}
195 const.Foo.Int.op1 :: Int -> Bool
196 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
198 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
199 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
201 dfun.Foo.Int :: Foo Int
202 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
204 Notice that, as with method selectors above, we assume that dictionary
205 application is curried, so there's no need to mention the Ord dictionary
206 in const.Foo.Int.op2 (or the type variable).
209 instance Foo a => Foo [a] where {}
211 dfun.Foo.List :: forall a. Foo a -> Foo [a]
213 = /\ a -> \ dfoo_a ->
215 op1 = defm.Foo.op1 [a] dfoo_list
216 op2 = defm.Foo.op2 [a] dfoo_list
217 dfoo_list = (op1, op2)
222 @tcClassDecls2@ generates bindings for polymorphic default methods
223 (generic default methods have by now turned into instance declarations)
226 tcClassDecl2 :: LTyClDecl Name -- The class declaration
227 -> TcM (LHsBinds Id, [Id])
229 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
230 tcdMeths = default_binds}))
231 = recoverM (returnM (emptyLHsBinds, [])) $
233 tcLookupLocatedClass class_name `thenM` \ clas ->
235 -- We make a separate binding for each default method.
236 -- At one time I used a single AbsBinds for all of them, thus
237 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
238 -- But that desugars into
239 -- ds = \d -> (..., ..., ...)
240 -- dm1 = \d -> case ds d of (a,b,c) -> a
241 -- And since ds is big, it doesn't get inlined, so we don't get good
242 -- default methods. Better to make separate AbsBinds for each
244 (tyvars, _, _, op_items) = classBigSig clas
245 rigid_info = ClsSkol clas
246 origin = SigOrigin rigid_info
247 prag_fn = mkPragFun sigs
248 sig_fn = mkTcSigFun sigs
249 clas_tyvars = tcSkolSigTyVars rigid_info tyvars
250 tc_dm = tcDefMeth origin clas clas_tyvars
251 default_binds sig_fn prag_fn
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 origin clas tyvars binds_in sig_fn prag_fn sel_id
265 = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
266 ; let inst_tys = mkTyVarTys tyvars
267 dm_ty = idType sel_id -- Same as dict selector!
268 cls_pred = mkClassPred clas inst_tys
269 local_dm_id = mkDefaultMethodId dm_name dm_ty
271 ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
272 ; loc <- getInstLoc origin
273 ; this_dict <- newDictBndr loc cls_pred
274 ; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
275 sig_fn prag_fn meth_info)
277 ; addErrCtxt (defltMethCtxt clas) $ do
280 { dict_binds <- tcSimplifyCheck
286 -- Simplification can do unification
287 ; checkSigTyVars 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 tyvars
300 [(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 -> TcSigFun -- For scoped tyvars, indexed by sel_name
336 -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name
337 -> MethodSpec -- Details of this method
340 tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
341 (sel_id, meth_id, meth_bind)
342 = recoverM (returnM emptyLHsBinds) $
343 -- If anything fails, recover returning no bindings.
344 -- This is particularly useful when checking the default-method binding of
345 -- a class decl. If we don't recover, we don't add the default method to
346 -- the type enviroment, and we get a tcLookup failure on $dmeth later.
348 -- Check the bindings; first adding inst_tyvars to the envt
349 -- so that we don't quantify over them in nested places
351 let sel_name = idName sel_id
352 meth_sig_fn meth_name = ASSERT( meth_name == idName meth_id ) sig_fn sel_name
353 -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
355 tcExtendTyVarEnv inst_tyvars (
356 tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
357 addErrCtxt (methodCtxt sel_id) $
359 tcMonoBinds [meth_bind] meth_sig_fn Recursive
360 ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
362 -- Now do context reduction. We simplify wrt both the local tyvars
363 -- and the ones of the class/instance decl, so that there is
366 -- op :: Eq a => a -> b -> a
368 -- We do this for each method independently to localise error messages
371 [(_, Just sig, local_meth_id)] = mono_bind_infos
375 addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
376 newDictBndrs loc (sig_theta sig) `thenM` \ meth_dicts ->
378 meth_tvs = sig_tvs sig
379 all_tyvars = meth_tvs ++ inst_tyvars
380 all_insts = avail_insts ++ meth_dicts
383 loc all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
385 checkSigTyVars all_tyvars `thenM_`
387 tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
389 poly_meth_bind = noLoc $ AbsBinds meth_tvs
390 (map instToId meth_dicts)
391 [(meth_tvs, meth_id, local_meth_id, prags)]
392 (lie_binds `unionBags` meth_bind)
394 returnM (unitBag poly_meth_bind)
397 mkMethodBind :: InstOrigin
398 -> Class -> [TcType] -- Class and instance types
399 -> LHsBinds Name -- Method binding (pick the right one from in here)
401 -> TcM (Maybe Inst, -- Method inst
403 -- Find the binding for the specified method, or make
404 -- up a suitable default method if it isn't there
406 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
407 = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
409 meth_name = idName meth_id
411 -- Figure out what method binding to use
412 -- If the user suppplied one, use it, else construct a default one
413 getSrcSpanM `thenM` \ loc ->
414 (case find_bind (idName sel_id) meth_name meth_binds of
415 Just user_bind -> returnM user_bind
417 mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
419 returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
420 ) `thenM` \ meth_bind ->
422 returnM (mb_inst, (sel_id, meth_id, meth_bind))
424 mkMethId :: InstOrigin -> Class
425 -> Id -> [TcType] -- Selector, and instance types
426 -> TcM (Maybe Inst, Id)
428 -- mkMethId instantiates the selector Id at the specified types
429 mkMethId origin clas sel_id inst_tys
431 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
432 rho_ty = ASSERT( length tyvars == length inst_tys )
433 substTyWith tyvars inst_tys rho
434 (preds,tau) = tcSplitPhiTy rho_ty
435 first_pred = ASSERT( not (null preds)) head preds
437 -- The first predicate should be of form (C a b)
438 -- where C is the class in question
439 ASSERT( not (null preds) &&
440 case getClassPredTys_maybe first_pred of
441 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
443 if isSingleton preds then
444 -- If it's the only one, make a 'method'
445 getInstLoc origin `thenM` \ inst_loc ->
446 newMethod inst_loc sel_id inst_tys `thenM` \ meth_inst ->
447 returnM (Just meth_inst, instToId meth_inst)
449 -- If it's not the only one we need to be careful
450 -- For example, given 'op' defined thus:
452 -- op :: (?x :: String) => a -> a
453 -- (mkMethId op T) should return an Inst with type
454 -- (?x :: String) => T -> T
455 -- That is, the class-op's context is still there.
456 -- BUT: it can't be a Method any more, because it breaks
457 -- INVARIANT 2 of methods. (See the data decl for Inst.)
458 newUnique `thenM` \ uniq ->
459 getSrcSpanM `thenM` \ loc ->
461 real_tau = mkPhiTy (tail preds) tau
462 meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
464 returnM (Nothing, meth_id)
466 -- The user didn't supply a method binding,
467 -- so we have to make up a default binding
468 -- The RHS of a default method depends on the default-method info
469 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
470 = -- An polymorphic default method
471 lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
472 -- Might not be imported, but will be an OrigName
473 traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
474 returnM (nlHsVar dm_name)
476 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
477 = -- No default method
478 -- Warn only if -fwarn-missing-methods
479 doptM Opt_WarnMissingMethods `thenM` \ warn ->
480 warnTc (isInstDecl origin
482 && reportIfUnused (getOccName sel_id))
483 (omittedMethodWarn sel_id) `thenM_`
486 error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
487 simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
488 (nlHsLit (HsStringPrim (mkFastString error_msg)))
489 error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
491 -- When the type is of form t1 -> t2 -> t3
492 -- make a default method like (\ _ _ -> noMethBind "blah")
493 -- rather than simply (noMethBind "blah")
494 -- Reason: if t1 or t2 are higher-ranked types we get n
495 -- silly ambiguity messages.
496 -- Example: f :: (forall a. Eq a => a -> a) -> Int
498 -- Here, tcSub tries to force (error "urk") to have the right type,
499 -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
500 -- where 't' is fresh ty var. This leads directly to "ambiguous t".
502 -- NB: technically this changes the meaning of the default-default
503 -- method slightly, because `seq` can see the lambdas. Oh well.
504 (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
505 (_,_,tau2) = tcSplitSigmaTy tau1
506 -- Need two splits because the selector can have a type like
507 -- forall a. Foo a => forall b. Eq b => ...
508 (arg_tys, _) = tcSplitFunTys tau2
509 wild_pats = [nlWildPat | ty <- arg_tys]
511 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
512 = -- A generic default method
513 -- If the method is defined generically, we can only do the job if the
514 -- instance declaration is for a single-parameter type class with
515 -- a type constructor applied to type arguments in the instance decl
516 -- (checkTc, so False provokes the error)
517 ASSERT( isInstDecl origin ) -- We never get here from a class decl
518 do { checkTc (isJust maybe_tycon)
519 (badGenericInstance sel_id (notSimple inst_tys))
520 ; checkTc (tyConHasGenerics tycon)
521 (badGenericInstance sel_id (notGeneric tycon))
524 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
525 (vcat [ppr clas <+> ppr inst_tys,
526 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
528 -- Rename it before returning it
529 ; (rn_rhs, _) <- rnLExpr rhs
532 rhs = mkGenericRhs sel_id clas_tyvar tycon
534 -- The tycon is only used in the generic case, and in that
535 -- case we require that the instance decl is for a single-parameter
536 -- type class with type variable arguments:
537 -- instance (...) => C (T a b)
538 clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
539 Just tycon = maybe_tycon
540 maybe_tycon = case inst_tys of
541 [ty] -> case tcSplitTyConApp_maybe ty of
542 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
546 isInstDecl (SigOrigin InstSkol) = True
547 isInstDecl (SigOrigin (ClsSkol _)) = False
552 -- The renamer just puts the selector ID as the binder in the method binding
553 -- but we must use the method name; so we substitute it here. Crude but simple.
554 find_bind sel_name meth_name binds
555 = foldlBag seqMaybe Nothing (mapBag f binds)
557 f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
558 = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
563 %************************************************************************
565 \subsection{Extracting generic instance declaration from class declarations}
567 %************************************************************************
569 @getGenericInstances@ extracts the generic instance declarations from a class
570 declaration. For exmaple
575 op{ x+y } (Inl v) = ...
576 op{ x+y } (Inr v) = ...
577 op{ x*y } (v :*: w) = ...
580 gives rise to the instance declarations
582 instance C (x+y) where
586 instance C (x*y) where
594 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
595 getGenericInstances class_decls
596 = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls
597 ; let { gen_inst_info = concat gen_inst_infos }
599 -- Return right away if there is no generic stuff
600 ; if null gen_inst_info then returnM []
603 -- Otherwise print it out
605 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
606 (vcat (map pprInstInfoDetails gen_inst_info)))
607 ; returnM gen_inst_info }}
609 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
611 = returnM [] -- The comon case: no generic default methods
613 | otherwise -- A source class decl with generic default methods
614 = recoverM (returnM []) $
616 tcLookupLocatedClass class_name `thenM` \ clas ->
618 -- Group by type, and
619 -- make an InstInfo out of each group
621 groups = groupWith listToBag generic_binds
623 mappM (mkGenericInstance clas) groups `thenM` \ inst_infos ->
625 -- Check that there is only one InstInfo for each type constructor
626 -- The main way this can fail is if you write
627 -- f {| a+b |} ... = ...
628 -- f {| x+y |} ... = ...
629 -- Then at this point we'll have an InstInfo for each
631 -- The class should be unary, which is why simpleInstInfoTyCon should be ok
633 tc_inst_infos :: [(TyCon, InstInfo)]
634 tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
636 bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
637 group `lengthExceeds` 1]
638 get_uniq (tc,_) = getUnique tc
640 mappM (addErrTc . dupGenericInsts) bad_groups `thenM_`
642 -- Check that there is an InstInfo for each generic type constructor
644 missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
646 checkTc (null missing) (missingGenericInstances missing) `thenM_`
650 generic_binds :: [(HsType Name, LHsBind Name)]
651 generic_binds = getGenericBinds def_methods
654 ---------------------------------
655 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
656 -- Takes a group of method bindings, finds the generic ones, and returns
657 -- them in finite map indexed by the type parameter in the definition.
658 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
660 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
661 = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
663 wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
667 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
669 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
672 (this,rest) = partition same_t prs
673 same_t (t',v) = t `eqPatType` t'
675 eqPatLType :: LHsType Name -> LHsType Name -> Bool
676 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
678 eqPatType :: HsType Name -> HsType Name -> Bool
679 -- A very simple equality function, only for
680 -- type patterns in generic function definitions.
681 eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2
682 eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2
683 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2
684 eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2
685 eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2
686 eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2
687 eqPatType _ _ = False
689 ---------------------------------
690 mkGenericInstance :: Class
691 -> (HsType Name, LHsBinds Name)
694 mkGenericInstance clas (hs_ty, binds)
695 -- Make a generic instance declaration
696 -- For example: instance (C a, C b) => C (a+b) where { binds }
698 = -- Extract the universally quantified type variables
699 -- and wrap them as forall'd tyvars, so that kind inference
700 -- works in the standard way
702 sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty)))
703 hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
705 -- Type-check the instance type, and check its form
706 tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty ->
708 (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
710 checkTc (validGenericInstanceType inst_ty)
711 (badGenericInstanceType binds) `thenM_`
713 -- Make the dictionary function.
714 getSrcSpanM `thenM` \ span ->
715 getOverlapFlag `thenM` \ overlap_flag ->
716 newDFunName clas [inst_ty] span `thenM` \ dfun_name ->
718 inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
719 dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
720 ispec = mkLocalInstance dfun_id overlap_flag
722 returnM (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] })
726 %************************************************************************
730 %************************************************************************
733 tcAddDeclCtxt decl thing_inside
734 = addErrCtxt ctxt thing_inside
736 thing | isClassDecl decl = "class"
737 | isTypeDecl decl = "type synonym" ++ maybeInst
738 | isDataDecl decl = if tcdND decl == NewType
739 then "newtype" ++ maybeInst
740 else "data type" ++ maybeInst
741 | isFamilyDecl decl = "family"
743 maybeInst | isFamInstDecl decl = " instance"
746 ctxt = hsep [ptext SLIT("In the"), text thing,
747 ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
750 = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
753 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
756 = hsep [ptext SLIT("Class"), quotes (ppr clas),
757 ptext SLIT("does not have a method"), quotes (ppr op)]
760 = hsep [ptext SLIT("Class"), quotes (ppr clas),
761 ptext SLIT("does not have an associated type"), quotes (ppr at)]
763 omittedMethodWarn sel_id
764 = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
767 = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
769 badGenericInstance sel_id because
770 = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
774 = vcat [ptext SLIT("because the instance type(s)"),
775 nest 2 (ppr inst_tys),
776 ptext SLIT("is not a simple type of form (T a1 ... an)")]
779 = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
780 ptext SLIT("was not compiled with -fgenerics")]
782 badGenericInstanceType binds
783 = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
786 missingGenericInstances missing
787 = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
789 dupGenericInsts tc_inst_infos
790 = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
791 nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
792 ptext SLIT("All the type patterns for a generic type constructor must be identical")
795 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
798 = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)