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"
70 Every class implicitly declares a new data type, corresponding to dictionaries
71 of that class. So, for example:
73 class (D a) => C a where
75 op2 :: forall b. Ord b => a -> b -> b
77 would implicitly declare
79 data CDict a = CDict (D a)
81 (forall b. Ord b => a -> b -> b)
83 (We could use a record decl, but that means changing more of the existing apparatus.
86 For classes with just one superclass+method, we use a newtype decl instead:
89 op :: forallb. a -> b -> b
93 newtype CDict a = CDict (forall b. a -> b -> b)
95 Now DictTy in Type is just a form of type synomym:
96 DictTy c t = TyConTy CDict `AppTy` t
98 Death to "ExpandingDicts".
101 %************************************************************************
103 Type-checking the class op signatures
105 %************************************************************************
108 tcClassSigs :: Name -- Name of the class
113 type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate
114 -- between tcClassSigs and buildClass
115 tcClassSigs clas sigs def_methods
116 = do { dm_env <- checkDefaultBinds clas op_names def_methods
117 ; mappM (tcClassSig dm_env) op_sigs }
119 op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs]
120 op_names = [n | sig@(L _ (TypeSig (L _ n) _)) <- op_sigs]
123 checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool)
124 -- Check default bindings
125 -- a) must be for a class op for this class
126 -- b) must be all generic or all non-generic
127 -- and return a mapping from class-op to Bool
128 -- where True <=> it's a generic default method
129 checkDefaultBinds clas ops binds
130 = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds)
131 return (mkNameEnv dm_infos)
133 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
134 = do { -- Check that the op is from this class
135 checkTc (op `elem` ops) (badMethodErr clas op)
137 -- Check that all the defns ar generic, or none are
138 ; checkTc (all_generic || none_generic) (mixedGenericErr op)
140 ; returnM (op, all_generic)
143 n_generic = count (isJust . maybeGenericMatch) matches
144 none_generic = n_generic == 0
145 all_generic = matches `lengthIs` n_generic
148 tcClassSig :: NameEnv Bool -- Info about default methods;
152 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
153 = setSrcSpan loc $ do
154 { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope
155 ; let dm = case lookupNameEnv dm_env op_name of
157 Just False -> DefMeth
158 Just True -> GenDefMeth
159 ; returnM (op_name, dm, op_ty) }
163 %************************************************************************
165 \subsection[Default methods]{Default methods}
167 %************************************************************************
169 The default methods for a class are each passed a dictionary for the
170 class, so that they get access to the other methods at the same type.
171 So, given the class decl
175 op2 :: Ord b => a -> b -> b -> b
178 op2 x y z = if (op1 x) && (y < z) then y else z
180 we get the default methods:
182 defm.Foo.op1 :: forall a. Foo a => a -> Bool
183 defm.Foo.op1 = /\a -> \dfoo -> \x -> True
185 defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b
186 defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z ->
187 if (op1 a dfoo x) && (< b dord y z) then y else z
190 When we come across an instance decl, we may need to use the default
193 instance Foo Int where {}
197 const.Foo.Int.op1 :: Int -> Bool
198 const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int
200 const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b
201 const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int
203 dfun.Foo.Int :: Foo Int
204 dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2)
206 Notice that, as with method selectors above, we assume that dictionary
207 application is curried, so there's no need to mention the Ord dictionary
208 in const.Foo.Int.op2 (or the type variable).
211 instance Foo a => Foo [a] where {}
213 dfun.Foo.List :: forall a. Foo a -> Foo [a]
215 = /\ a -> \ dfoo_a ->
217 op1 = defm.Foo.op1 [a] dfoo_list
218 op2 = defm.Foo.op2 [a] dfoo_list
219 dfoo_list = (op1, op2)
224 @tcClassDecls2@ generates bindings for polymorphic default methods
225 (generic default methods have by now turned into instance declarations)
228 tcClassDecl2 :: LTyClDecl Name -- The class declaration
229 -> TcM (LHsBinds Id, [Id])
231 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
232 tcdMeths = default_binds}))
233 = recoverM (returnM (emptyLHsBinds, [])) $
235 tcLookupLocatedClass class_name `thenM` \ clas ->
237 -- We make a separate binding for each default method.
238 -- At one time I used a single AbsBinds for all of them, thus
239 -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
240 -- But that desugars into
241 -- ds = \d -> (..., ..., ...)
242 -- dm1 = \d -> case ds d of (a,b,c) -> a
243 -- And since ds is big, it doesn't get inlined, so we don't get good
244 -- default methods. Better to make separate AbsBinds for each
246 (tyvars, _, _, op_items) = classBigSig clas
247 rigid_info = ClsSkol clas
248 origin = SigOrigin rigid_info
249 prag_fn = mkPragFun sigs
250 sig_fn = mkTcSigFun sigs
251 clas_tyvars = tcSkolSigTyVars rigid_info tyvars
252 tc_dm = tcDefMeth origin clas clas_tyvars
253 default_binds sig_fn prag_fn
255 dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items]
256 -- Generate code for polymorphic default methods only
257 -- (Generic default methods have turned into instance decls by now.)
258 -- This is incompatible with Hugs, which expects a polymorphic
259 -- default method for every class op, regardless of whether or not
260 -- the programmer supplied an explicit default decl for the class.
261 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
263 mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) ->
264 returnM (listToBag defm_binds, concat dm_ids_s)
266 tcDefMeth origin clas tyvars binds_in sig_fn prag_fn sel_id
267 = do { dm_name <- lookupTopBndrRn (mkDefMethRdrName sel_id)
268 ; let inst_tys = mkTyVarTys tyvars
269 dm_ty = idType sel_id -- Same as dict selector!
270 cls_pred = mkClassPred clas inst_tys
271 local_dm_id = mkDefaultMethodId dm_name dm_ty
273 ; (_, meth_info) <- mkMethodBind origin clas inst_tys binds_in (sel_id, DefMeth)
274 ; loc <- getInstLoc origin
275 ; this_dict <- newDictBndr loc cls_pred
276 ; (defm_bind, insts_needed) <- getLIE (tcMethodBind tyvars [cls_pred] [this_dict]
277 sig_fn prag_fn meth_info)
279 ; addErrCtxt (defltMethCtxt clas) $ do
282 { dict_binds <- tcSimplifyCheck
288 -- Simplification can do unification
289 ; checkSigTyVars tyvars
292 -- We'll have an inline pragma on the local binding, made by tcMethodBind
293 -- but that's not enough; we want one on the global default method too
294 -- Specialisations, on the other hand, belong on the thing inside only, I think
295 ; let (_,dm_inst_id,_) = meth_info
296 sel_name = idName sel_id
297 inline_prags = filter isInlineLSig (prag_fn sel_name)
298 ; prags <- tcPrags dm_inst_id inline_prags
300 ; let full_bind = AbsBinds tyvars
302 [(tyvars, local_dm_id, dm_inst_id, prags)]
303 (dict_binds `unionBags` defm_bind)
304 ; returnM (noLoc full_bind, [local_dm_id]) }}
306 mkDefMethRdrName :: Id -> RdrName
307 mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc
311 %************************************************************************
313 \subsection{Typechecking a method}
315 %************************************************************************
317 @tcMethodBind@ is used to type-check both default-method and
318 instance-decl method declarations. We must type-check methods one at a
319 time, because their signatures may have different contexts and
323 type MethodSpec = (Id, -- Global selector Id
324 Id, -- Local Id (class tyvars instantiated)
325 LHsBind Name) -- Binding for the method
328 :: [TcTyVar] -- Skolemised type variables for the
329 -- enclosing class/instance decl.
330 -- They'll be signature tyvars, and we
331 -- want to check that they don't get bound
332 -- Also they are scoped, so we bring them into scope
333 -- Always equal the range of the type envt
334 -> TcThetaType -- Available theta; it's just used for the error message
335 -> [Inst] -- Available from context, used to simplify constraints
336 -- from the method body
337 -> TcSigFun -- For scoped tyvars, indexed by sel_name
338 -> TcPragFun -- Pragmas (e.g. inline pragmas), indexed by sel_name
339 -> MethodSpec -- Details of this method
342 tcMethodBind inst_tyvars inst_theta avail_insts sig_fn prag_fn
343 (sel_id, meth_id, meth_bind)
344 = recoverM (returnM emptyLHsBinds) $
345 -- If anything fails, recover returning no bindings.
346 -- This is particularly useful when checking the default-method binding of
347 -- a class decl. If we don't recover, we don't add the default method to
348 -- the type enviroment, and we get a tcLookup failure on $dmeth later.
350 -- Check the bindings; first adding inst_tyvars to the envt
351 -- so that we don't quantify over them in nested places
353 let sel_name = idName sel_id
354 meth_sig_fn meth_name = ASSERT( meth_name == idName meth_id ) sig_fn sel_name
355 -- The meth_bind metions the meth_name, but sig_fn is indexed by sel_name
357 tcExtendTyVarEnv inst_tyvars (
358 tcExtendIdEnv [meth_id] $ -- In scope for tcInstSig
359 addErrCtxt (methodCtxt sel_id) $
361 tcMonoBinds [meth_bind] meth_sig_fn 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
377 addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
378 newDictBndrs loc (sig_theta sig) `thenM` \ meth_dicts ->
380 meth_tvs = sig_tvs sig
381 all_tyvars = meth_tvs ++ inst_tyvars
382 all_insts = avail_insts ++ meth_dicts
385 loc all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
387 checkSigTyVars all_tyvars `thenM_`
389 tcPrags meth_id (prag_fn sel_name) `thenM` \ prags ->
391 poly_meth_bind = noLoc $ AbsBinds meth_tvs
392 (map instToId meth_dicts)
393 [(meth_tvs, meth_id, local_meth_id, prags)]
394 (lie_binds `unionBags` meth_bind)
396 returnM (unitBag poly_meth_bind)
399 mkMethodBind :: InstOrigin
400 -> Class -> [TcType] -- Class and instance types
401 -> LHsBinds Name -- Method binding (pick the right one from in here)
403 -> TcM (Maybe Inst, -- Method inst
405 -- Find the binding for the specified method, or make
406 -- up a suitable default method if it isn't there
408 mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info)
409 = mkMethId origin clas sel_id inst_tys `thenM` \ (mb_inst, meth_id) ->
411 meth_name = idName meth_id
413 -- Figure out what method binding to use
414 -- If the user suppplied one, use it, else construct a default one
415 getSrcSpanM `thenM` \ loc ->
416 (case find_bind (idName sel_id) meth_name meth_binds of
417 Just user_bind -> returnM user_bind
419 mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs ->
421 returnM (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rhs])
422 ) `thenM` \ meth_bind ->
424 returnM (mb_inst, (sel_id, meth_id, meth_bind))
426 mkMethId :: InstOrigin -> Class
427 -> Id -> [TcType] -- Selector, and instance types
428 -> TcM (Maybe Inst, Id)
430 -- mkMethId instantiates the selector Id at the specified types
431 mkMethId origin clas sel_id inst_tys
433 (tyvars,rho) = tcSplitForAllTys (idType sel_id)
434 rho_ty = ASSERT( length tyvars == length inst_tys )
435 substTyWith tyvars inst_tys rho
436 (preds,tau) = tcSplitPhiTy rho_ty
437 first_pred = ASSERT( not (null preds)) head preds
439 -- The first predicate should be of form (C a b)
440 -- where C is the class in question
441 ASSERT( not (null preds) &&
442 case getClassPredTys_maybe first_pred of
443 { Just (clas1,tys) -> clas == clas1 ; Nothing -> False }
445 if isSingleton preds then
446 -- If it's the only one, make a 'method'
447 getInstLoc origin `thenM` \ inst_loc ->
448 newMethod inst_loc sel_id inst_tys `thenM` \ meth_inst ->
449 returnM (Just meth_inst, instToId meth_inst)
451 -- If it's not the only one we need to be careful
452 -- For example, given 'op' defined thus:
454 -- op :: (?x :: String) => a -> a
455 -- (mkMethId op T) should return an Inst with type
456 -- (?x :: String) => T -> T
457 -- That is, the class-op's context is still there.
458 -- BUT: it can't be a Method any more, because it breaks
459 -- INVARIANT 2 of methods. (See the data decl for Inst.)
460 newUnique `thenM` \ uniq ->
461 getSrcSpanM `thenM` \ loc ->
463 real_tau = mkPhiTy (tail preds) tau
464 meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc
466 returnM (Nothing, meth_id)
468 -- The user didn't supply a method binding,
469 -- so we have to make up a default binding
470 -- The RHS of a default method depends on the default-method info
471 mkDefMethRhs origin clas inst_tys sel_id loc DefMeth
472 = -- An polymorphic default method
473 lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name ->
474 -- Might not be imported, but will be an OrigName
475 traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_`
476 returnM (nlHsVar dm_name)
478 mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth
479 = -- No default method
480 -- Warn only if -fwarn-missing-methods
481 doptM Opt_WarnMissingMethods `thenM` \ warn ->
482 warnTc (isInstDecl origin
484 && reportIfUnused (getOccName sel_id))
485 (omittedMethodWarn sel_id) `thenM_`
488 error_rhs = noLoc $ HsLam (mkMatchGroup [mkSimpleMatch wild_pats simple_rhs])
489 simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID))
490 (nlHsLit (HsStringPrim (mkFastString error_msg)))
491 error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
493 -- When the type is of form t1 -> t2 -> t3
494 -- make a default method like (\ _ _ -> noMethBind "blah")
495 -- rather than simply (noMethBind "blah")
496 -- Reason: if t1 or t2 are higher-ranked types we get n
497 -- silly ambiguity messages.
498 -- Example: f :: (forall a. Eq a => a -> a) -> Int
500 -- Here, tcSub tries to force (error "urk") to have the right type,
501 -- thus: f = \(x::forall a. Eq a => a->a) -> error "urk" (x t)
502 -- where 't' is fresh ty var. This leads directly to "ambiguous t".
504 -- NB: technically this changes the meaning of the default-default
505 -- method slightly, because `seq` can see the lambdas. Oh well.
506 (_,_,tau1) = tcSplitSigmaTy (idType sel_id)
507 (_,_,tau2) = tcSplitSigmaTy tau1
508 -- Need two splits because the selector can have a type like
509 -- forall a. Foo a => forall b. Eq b => ...
510 (arg_tys, _) = tcSplitFunTys tau2
511 wild_pats = [nlWildPat | ty <- arg_tys]
513 mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth
514 = -- A generic default method
515 -- If the method is defined generically, we can only do the job if the
516 -- instance declaration is for a single-parameter type class with
517 -- a type constructor applied to type arguments in the instance decl
518 -- (checkTc, so False provokes the error)
519 ASSERT( isInstDecl origin ) -- We never get here from a class decl
520 do { checkTc (isJust maybe_tycon)
521 (badGenericInstance sel_id (notSimple inst_tys))
522 ; checkTc (tyConHasGenerics tycon)
523 (badGenericInstance sel_id (notGeneric tycon))
526 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
527 (vcat [ppr clas <+> ppr inst_tys,
528 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
530 -- Rename it before returning it
531 ; (rn_rhs, _) <- rnLExpr rhs
534 rhs = mkGenericRhs sel_id clas_tyvar tycon
536 -- The tycon is only used in the generic case, and in that
537 -- case we require that the instance decl is for a single-parameter
538 -- type class with type variable arguments:
539 -- instance (...) => C (T a b)
540 clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
541 Just tycon = maybe_tycon
542 maybe_tycon = case inst_tys of
543 [ty] -> case tcSplitTyConApp_maybe ty of
544 Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
548 isInstDecl (SigOrigin InstSkol) = True
549 isInstDecl (SigOrigin (ClsSkol _)) = False
554 -- The renamer just puts the selector ID as the binder in the method binding
555 -- but we must use the method name; so we substitute it here. Crude but simple.
556 find_bind sel_name meth_name binds
557 = foldlBag mplus Nothing (mapBag f binds)
559 f (L loc1 bind@(FunBind { fun_id = L loc2 op_name })) | op_name == sel_name
560 = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
565 %************************************************************************
567 \subsection{Extracting generic instance declaration from class declarations}
569 %************************************************************************
571 @getGenericInstances@ extracts the generic instance declarations from a class
572 declaration. For exmaple
577 op{ x+y } (Inl v) = ...
578 op{ x+y } (Inr v) = ...
579 op{ x*y } (v :*: w) = ...
582 gives rise to the instance declarations
584 instance C (x+y) where
588 instance C (x*y) where
596 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo]
597 getGenericInstances class_decls
598 = do { gen_inst_infos <- mappM (addLocM get_generics) class_decls
599 ; let { gen_inst_info = concat gen_inst_infos }
601 -- Return right away if there is no generic stuff
602 ; if null gen_inst_info then returnM []
605 -- Otherwise print it out
607 ; ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
608 (vcat (map pprInstInfoDetails gen_inst_info)))
609 ; returnM gen_inst_info }}
611 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
613 = returnM [] -- The comon case: no generic default methods
615 | otherwise -- A source class decl with generic default methods
616 = recoverM (returnM []) $
618 tcLookupLocatedClass class_name `thenM` \ clas ->
620 -- Group by type, and
621 -- make an InstInfo out of each group
623 groups = groupWith listToBag generic_binds
625 mappM (mkGenericInstance clas) groups `thenM` \ inst_infos ->
627 -- Check that there is only one InstInfo for each type constructor
628 -- The main way this can fail is if you write
629 -- f {| a+b |} ... = ...
630 -- f {| x+y |} ... = ...
631 -- Then at this point we'll have an InstInfo for each
633 -- The class should be unary, which is why simpleInstInfoTyCon should be ok
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] 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
738 thing | isClassDecl decl = "class"
739 | isTypeDecl decl = "type synonym" ++ maybeInst
740 | isDataDecl decl = if tcdND decl == NewType
741 then "newtype" ++ maybeInst
742 else "data type" ++ maybeInst
743 | isFamilyDecl decl = "family"
745 maybeInst | isFamInstDecl decl = " instance"
748 ctxt = hsep [ptext SLIT("In the"), text thing,
749 ptext SLIT("declaration for"), quotes (ppr (tcdName decl))]
752 = ptext SLIT("When checking the default methods for class") <+> quotes (ppr clas)
755 = ptext SLIT("In the definition for method") <+> quotes (ppr sel_id)
758 = hsep [ptext SLIT("Class"), quotes (ppr clas),
759 ptext SLIT("does not have a method"), quotes (ppr op)]
762 = hsep [ptext SLIT("Class"), quotes (ppr clas),
763 ptext SLIT("does not have an associated type"), quotes (ppr at)]
765 omittedMethodWarn sel_id
766 = ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
769 = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
771 badGenericInstance sel_id because
772 = sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
776 = vcat [ptext SLIT("because the instance type(s)"),
777 nest 2 (ppr inst_tys),
778 ptext SLIT("is not a simple type of form (T a1 ... an)")]
781 = vcat [ptext SLIT("because the instance type constructor") <+> quotes (ppr tycon) <+>
782 ptext SLIT("was not compiled with -fgenerics")]
784 badGenericInstanceType binds
785 = vcat [ptext SLIT("Illegal type pattern in the generic bindings"),
788 missingGenericInstances missing
789 = ptext SLIT("Missing type patterns for") <+> pprQuotedList missing
791 dupGenericInsts tc_inst_infos
792 = vcat [ptext SLIT("More than one type pattern for a single generic type constructor:"),
793 nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
794 ptext SLIT("All the type patterns for a generic type constructor must be identical")
797 ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
800 = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)