compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Typechecking class declarations
   7
   8 \begin{code}
   9 module TcClassDcl ( tcClassSigs, tcClassDecl2,
  10                     findMethodBind, instantiateMethod, tcInstanceMethodBody,
  11                     mkGenericDefMethBind, getGenericInstances,
  12                     tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
  13                   ) where
  14
  15 #include "HsVersions.h"
  16
  17 import HsSyn
  18 import RnHsSyn
  19 import RnExpr
  20 import Inst
  21 import InstEnv
  22 import TcEnv
  23 import TcBinds
  24 import TcSimplify
  25 import TcHsType
  26 import TcMType
  27 import TcType
  28 import TcRnMonad
  29 import BuildTyCl( TcMethInfo )
  30 import Generics
  31 import Class
  32 import TyCon
  33 import MkId
  34 import Id
  35 import Name
  36 import Var
  37 import NameEnv
  38 import NameSet
  39 import Outputable
  40 import PrelNames
  41 import DynFlags
  42 import ErrUtils
  43 import Util
  44 import ListSetOps
  45 import SrcLoc
  46 import Maybes
  47 import BasicTypes
  48 import Bag
  49 import FastString
  50
  51 import Control.Monad
  52 import Data.List
  53 \end{code}
  54
  55
  56 Dictionary handling
  57 ~~~~~~~~~~~~~~~~~~~
  58 Every class implicitly declares a new data type, corresponding to dictionaries
  59 of that class. So, for example:
  60
  61         class (D a) => C a where
  62           op1 :: a -> a
  63           op2 :: forall b. Ord b => a -> b -> b
  64
  65 would implicitly declare
  66
  67         data CDict a = CDict (D a)
  68                              (a -> a)
  69                              (forall b. Ord b => a -> b -> b)
  70
  71 (We could use a record decl, but that means changing more of the existing apparatus.
  72 One step at at time!)
  73
  74 For classes with just one superclass+method, we use a newtype decl instead:
  75
  76         class C a where
  77           op :: forallb. a -> b -> b
  78
  79 generates
  80
  81         newtype CDict a = CDict (forall b. a -> b -> b)
  82
  83 Now DictTy in Type is just a form of type synomym:
  84         DictTy c t = TyConTy CDict `AppTy` t
  85
  86 Death to "ExpandingDicts".
  87
  88
  89 %************************************************************************
  90 %*                                                                      *
  91                 Type-checking the class op signatures
  92 %*                                                                      *
  93 %************************************************************************
  94
  95 \begin{code}
  96 tcClassSigs :: Name                     -- Name of the class
  97             -> [LSig Name]
  98             -> LHsBinds Name
  99             -> TcM [TcMethInfo]
 100
 101 tcClassSigs clas sigs def_methods
 102   = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names))
 103                         (bagToList def_methods)
 104        ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
 105   where
 106     op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
 107     op_names = [n   |     (L _ (TypeSig (L _ n) _)) <- op_sigs]
 108
 109 checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
 110   -- Check default bindings
 111   --    a) must be for a class op for this class
 112   --    b) must be all generic or all non-generic
 113 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
 114   = do {        -- Check that the op is from this class
 115          checkTc (op `elem` ops) (badMethodErr clas op)
 116
 117         -- Check that all the defns ar generic, or none are
 118        ; case (none_generic, all_generic) of
 119            (True, _) -> return (op, VanillaDM)
 120            (_, True) -> return (op, GenericDM)
 121            _         -> failWith (mixedGenericErr op)
 122     }
 123   where
 124     n_generic    = count (isJust . maybeGenericMatch) matches
 125     none_generic = n_generic == 0
 126     all_generic  = matches `lengthIs` n_generic
 127
 128 checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
 129
 130
 131 tcClassSig :: NameEnv DefMethSpec       -- Info about default methods;
 132            -> LSig Name
 133            -> TcM TcMethInfo
 134
 135 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
 136   = setSrcSpan loc $ do
 137     { op_ty <- tcHsKindedType op_hs_ty  -- Class tyvars already in scope
 138     ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
 139     ; return (op_name, dm, op_ty) }
 140 tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
 141 \end{code}
 142
 143
 144 %************************************************************************
 145 %*                                                                      *
 146                 Class Declarations
 147 %*                                                                      *
 148 %************************************************************************
 149
 150 \begin{code}
 151 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
 152              -> TcM (LHsBinds Id)
 153
 154 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 155                                 tcdMeths = default_binds}))
 156   = recoverM (return emptyLHsBinds)     $
 157     setSrcSpan loc                      $
 158     do  { clas <- tcLookupLocatedClass class_name
 159
 160         -- We make a separate binding for each default method.
 161         -- At one time I used a single AbsBinds for all of them, thus
 162         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 163         -- But that desugars into
 164         --      ds = \d -> (..., ..., ...)
 165         --      dm1 = \d -> case ds d of (a,b,c) -> a
 166         -- And since ds is big, it doesn't get inlined, so we don't get good
 167         -- default methods.  Better to make separate AbsBinds for each
 168         ; let
 169               (tyvars, _, _, op_items) = classBigSig clas
 170               rigid_info  = ClsSkol clas
 171               prag_fn     = mkPragFun sigs default_binds
 172               sig_fn      = mkTcSigFun sigs
 173               clas_tyvars = tcSkolSigTyVars rigid_info tyvars
 174               pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
 175         ; inst_loc <- getInstLoc (SigOrigin rigid_info)
 176         ; this_dict <- newDictBndr inst_loc pred
 177
 178         ; let tc_dm = tcDefMeth clas clas_tyvars
 179                                 this_dict default_binds
 180                                 sig_fn prag_fn
 181
 182         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
 183                       mapM tc_dm op_items
 184
 185         ; return (listToBag (catMaybes dm_binds)) }
 186
 187 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
 188
 189 tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name
 190           -> TcSigFun -> TcPragFun -> ClassOpItem
 191           -> TcM (Maybe (LHsBind Id))
 192 -- Generate code for polymorphic default methods only (hence DefMeth)
 193 -- (Generic default methods have turned into instance decls by now.)
 194 -- This is incompatible with Hugs, which expects a polymorphic
 195 -- default method for every class op, regardless of whether or not
 196 -- the programmer supplied an explicit default decl for the class.
 197 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 198 tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
 199   = case dm_info of
 200       NoDefMeth       -> return Nothing
 201       GenDefMeth      -> return Nothing
 202       DefMeth dm_name -> do
 203         { let sel_name = idName sel_id
 204         ; local_dm_name <- newLocalName sel_name
 205           -- Base the local_dm_name on the selector name, because
 206           -- type errors from tcInstanceMethodBody come from here
 207
 208                 -- See Note [Silly default-method bind]
 209                 -- (possibly out of date)
 210
 211         ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
 212                           `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 213                 -- dm_info = DefMeth dm_name only if there is a binding in binds_in
 214
 215               dm_sig_fn  _  = sig_fn sel_name
 216               dm_id         = mkDefaultMethodId sel_id dm_name
 217               local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
 218               local_dm_id   = mkLocalId local_dm_name local_dm_type
 219
 220         ; (dm_id_w_inline, spec_prags)
 221                 <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
 222
 223         ; warnTc (not (null spec_prags))
 224                  (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
 225                   <+> quotes (ppr sel_name))
 226
 227         ; liftM Just $
 228           tcInstanceMethodBody (instLoc this_dict)
 229                                tyvars [this_dict]
 230                                ([], emptyBag)
 231                                dm_id_w_inline local_dm_id
 232                                dm_sig_fn IsDefaultMethod meth_bind }
 233
 234 ---------------
 235 tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
 236                      -> ([Inst], LHsBinds Id) -> Id -> Id
 237                      -> TcSigFun -> TcSpecPrags -> LHsBind Name
 238                      -> TcM (LHsBind Id)
 239 tcInstanceMethodBody inst_loc tyvars dfun_dicts
 240                      (this_dict, this_bind) meth_id local_meth_id
 241                      meth_sig_fn spec_prags bind@(L loc _)
 242   = do  {       -- Typecheck the binding, first extending the envt
 243                 -- so that when tcInstSig looks up the local_meth_id to find
 244                 -- its signature, we'll find it in the environment
 245         ; ((tc_bind, _), lie) <- getLIE $
 246                                  tcExtendIdEnv [local_meth_id] $
 247                                  tcPolyBinds TopLevel meth_sig_fn no_prag_fn
 248                                              NonRecursive NonRecursive
 249                                              (unitBag bind)
 250
 251         ; let avails = this_dict ++ dfun_dicts
 252                 -- Only need the this_dict stuff if there are type
 253                 -- variables involved; otherwise overlap is not possible
 254                 -- See Note [Subtle interaction of recursion and overlap]
 255                 -- in TcInstDcls
 256         ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
 257
 258         ; let full_bind = AbsBinds tyvars dfun_lam_vars
 259                                   [(tyvars, meth_id, local_meth_id, spec_prags)]
 260                                   (this_bind `unionBags` lie_binds
 261                                    `unionBags` tc_bind)
 262
 263               dfun_lam_vars = map instToVar dfun_dicts  -- Includes equalities
 264
 265         ; return (L loc full_bind) }
 266   where
 267     no_prag_fn  _ = []          -- No pragmas for local_meth_id;
 268                                 -- they are all for meth_id
 269 \end{code}
 270
 271 \begin{code}
 272 instantiateMethod :: Class -> Id -> [TcType] -> TcType
 273 -- Take a class operation, say
 274 --      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
 275 -- Instantiate it at [ty1,ty2]
 276 -- Return the "local method type":
 277 --      forall c. Ix x => (ty2,c) -> ty1
 278 instantiateMethod clas sel_id inst_tys
 279   = ASSERT( ok_first_pred ) local_meth_ty
 280   where
 281     (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
 282     rho_ty = ASSERT( length sel_tyvars == length inst_tys )
 283              substTyWith sel_tyvars inst_tys sel_rho
 284
 285     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
 286                 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
 287
 288     ok_first_pred = case getClassPredTys_maybe first_pred of
 289                       Just (clas1, _tys) -> clas == clas1
 290                       Nothing -> False
 291               -- The first predicate should be of form (C a b)
 292               -- where C is the class in question
 293
 294
 295 ---------------------------
 296 -- The renamer just puts the selector ID as the binder in the method binding
 297 -- but we must use the method name; so we substitute it here.  Crude but simple.
 298 findMethodBind  :: Name -> Name         -- Selector and method name
 299                 -> LHsBinds Name        -- A group of bindings
 300                 -> Maybe (LHsBind Name) -- The binding, with meth_name replacing sel_name
 301 findMethodBind sel_name meth_name binds
 302   = foldlBag mplus Nothing (mapBag f binds)
 303   where
 304         f (L loc1 bind@(FunBind { fun_id = L loc2 op_name }))
 305                  | op_name == sel_name
 306                  = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
 307         f _other = Nothing
 308 \end{code}
 309
 310 Note [Polymorphic methods]
 311 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 312 Consider
 313     class Foo a where
 314         op :: forall b. Ord b => a -> b -> b -> b
 315     instance Foo c => Foo [c] where
 316         op = e
 317
 318 When typechecking the binding 'op = e', we'll have a meth_id for op
 319 whose type is
 320       op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
 321
 322 So tcPolyBinds must be capable of dealing with nested polytypes;
 323 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
 324
 325 Note [Silly default-method bind]
 326 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 327 When we pass the default method binding to the type checker, it must
 328 look like    op2 = e
 329 not          $dmop2 = e
 330 otherwise the "$dm" stuff comes out error messages.  But we want the
 331 "$dm" to come out in the interface file.  So we typecheck the former,
 332 and wrap it in a let, thus
 333           $dmop2 = let op2 = e in op2
 334 This makes the error messages right.
 335
 336
 337 %************************************************************************
 338 %*                                                                      *
 339         Extracting generic instance declaration from class declarations
 340 %*                                                                      *
 341 %************************************************************************
 342
 343 @getGenericInstances@ extracts the generic instance declarations from a class
 344 declaration.  For exmaple
 345
 346         class C a where
 347           op :: a -> a
 348
 349           op{ x+y } (Inl v)   = ...
 350           op{ x+y } (Inr v)   = ...
 351           op{ x*y } (v :*: w) = ...
 352           op{ 1   } Unit      = ...
 353
 354 gives rise to the instance declarations
 355
 356         instance C (x+y) where
 357           op (Inl v)   = ...
 358           op (Inr v)   = ...
 359
 360         instance C (x*y) where
 361           op (v :*: w) = ...
 362
 363         instance C 1 where
 364           op Unit      = ...
 365
 366 \begin{code}
 367 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
 368 mkGenericDefMethBind clas inst_tys sel_id meth_name
 369   =     -- A generic default method
 370         -- If the method is defined generically, we can only do the job if the
 371         -- instance declaration is for a single-parameter type class with
 372         -- a type constructor applied to type arguments in the instance decl
 373         --      (checkTc, so False provokes the error)
 374     do  { checkTc (isJust maybe_tycon)
 375                   (badGenericInstance sel_id (notSimple inst_tys))
 376         ; checkTc (tyConHasGenerics tycon)
 377                   (badGenericInstance sel_id (notGeneric tycon))
 378
 379         ; dflags <- getDOpts
 380         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 381                    (vcat [ppr clas <+> ppr inst_tys,
 382                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 383
 384                 -- Rename it before returning it
 385         ; (rn_rhs, _) <- rnLExpr rhs
 386         ; return (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rn_rhs]) }
 387   where
 388     rhs = mkGenericRhs sel_id clas_tyvar tycon
 389
 390           -- The tycon is only used in the generic case, and in that
 391           -- case we require that the instance decl is for a single-parameter
 392           -- type class with type variable arguments:
 393           --    instance (...) => C (T a b)
 394     clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
 395     Just tycon  = maybe_tycon
 396     maybe_tycon = case inst_tys of
 397                         [ty] -> case tcSplitTyConApp_maybe ty of
 398                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 399                                   _                                               -> Nothing
 400                         _ -> Nothing
 401
 402
 403 ---------------------------
 404 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
 405 getGenericInstances class_decls
 406   = do  { gen_inst_infos <- mapM (addLocM get_generics) class_decls
 407         ; let { gen_inst_info = concat gen_inst_infos }
 408
 409         -- Return right away if there is no generic stuff
 410         ; if null gen_inst_info then return []
 411           else do
 412
 413         -- Otherwise print it out
 414         { dflags <- getDOpts
 415         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 416                  (vcat (map pprInstInfoDetails gen_inst_info)))
 417         ; return gen_inst_info }}
 418
 419 get_generics :: TyClDecl Name -> TcM [InstInfo Name]
 420 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 421   | null generic_binds
 422   = return [] -- The comon case: no generic default methods
 423
 424   | otherwise   -- A source class decl with generic default methods
 425   = recoverM (return [])                                $
 426     tcAddDeclCtxt decl                                  $ do
 427     clas <- tcLookupLocatedClass class_name
 428
 429         -- Group by type, and
 430         -- make an InstInfo out of each group
 431     let
 432         groups = groupWith listToBag generic_binds
 433
 434     inst_infos <- mapM (mkGenericInstance clas) groups
 435
 436         -- Check that there is only one InstInfo for each type constructor
 437         -- The main way this can fail is if you write
 438         --      f {| a+b |} ... = ...
 439         --      f {| x+y |} ... = ...
 440         -- Then at this point we'll have an InstInfo for each
 441         --
 442         -- The class should be unary, which is why simpleInstInfoTyCon should be ok
 443     let
 444         tc_inst_infos :: [(TyCon, InstInfo Name)]
 445         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 446
 447         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 448                               group `lengthExceeds` 1]
 449         get_uniq (tc,_) = getUnique tc
 450
 451     mapM_ (addErrTc . dupGenericInsts) bad_groups
 452
 453         -- Check that there is an InstInfo for each generic type constructor
 454     let
 455         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 456
 457     checkTc (null missing) (missingGenericInstances missing)
 458
 459     return inst_infos
 460   where
 461     generic_binds :: [(HsType Name, LHsBind Name)]
 462     generic_binds = getGenericBinds def_methods
 463 get_generics decl = pprPanic "get_generics" (ppr decl)
 464
 465
 466 ---------------------------------
 467 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 468   -- Takes a group of method bindings, finds the generic ones, and returns
 469   -- them in finite map indexed by the type parameter in the definition.
 470 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 471
 472 getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
 473 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
 474   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 475   where
 476     wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
 477 getGenericBind _
 478   = []
 479
 480 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 481 groupWith _  []          = []
 482 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 483     where
 484       vs              = map snd this
 485       (this,rest)     = partition same_t prs
 486       same_t (t', _v) = t `eqPatType` t'
 487
 488 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 489 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 490
 491 eqPatType :: HsType Name -> HsType Name -> Bool
 492 -- A very simple equality function, only for
 493 -- type patterns in generic function definitions.
 494 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 495 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
 496 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
 497 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 498 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 499 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 500 eqPatType _ _ = False
 501
 502 ---------------------------------
 503 mkGenericInstance :: Class
 504                   -> (HsType Name, LHsBinds Name)
 505                   -> TcM (InstInfo Name)
 506
 507 mkGenericInstance clas (hs_ty, binds) = do
 508   -- Make a generic instance declaration
 509   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 510
 511         -- Extract the universally quantified type variables
 512         -- and wrap them as forall'd tyvars, so that kind inference
 513         -- works in the standard way
 514     let
 515         sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
 516                   extractHsTyVars (noLoc hs_ty)
 517         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 518
 519         -- Type-check the instance type, and check its form
 520     forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
 521     let
 522         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 523
 524     checkTc (validGenericInstanceType inst_ty)
 525             (badGenericInstanceType binds)
 526
 527         -- Make the dictionary function.
 528     span <- getSrcSpanM
 529     overlap_flag <- getOverlapFlag
 530     dfun_name <- newDFunName clas [inst_ty] span
 531     let
 532         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 533         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 534         ispec      = mkLocalInstance dfun_id overlap_flag
 535
 536     return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
 537 \end{code}
 538
 539
 540 %************************************************************************
 541 %*                                                                      *
 542                 Error messages
 543 %*                                                                      *
 544 %************************************************************************
 545
 546 \begin{code}
 547 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
 548 tcAddDeclCtxt decl thing_inside
 549   = addErrCtxt ctxt thing_inside
 550   where
 551      thing | isClassDecl decl  = "class"
 552            | isTypeDecl decl   = "type synonym" ++ maybeInst
 553            | isDataDecl decl   = if tcdND decl == NewType
 554                                  then "newtype" ++ maybeInst
 555                                  else "data type" ++ maybeInst
 556            | isFamilyDecl decl = "family"
 557            | otherwise         = panic "tcAddDeclCtxt/thing"
 558
 559      maybeInst | isFamInstDecl decl = " instance"
 560                | otherwise          = ""
 561
 562      ctxt = hsep [ptext (sLit "In the"), text thing,
 563                   ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
 564
 565 badMethodErr :: Outputable a => a -> Name -> SDoc
 566 badMethodErr clas op
 567   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 568           ptext (sLit "does not have a method"), quotes (ppr op)]
 569
 570 badATErr :: Class -> Name -> SDoc
 571 badATErr clas at
 572   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 573           ptext (sLit "does not have an associated type"), quotes (ppr at)]
 574
 575 omittedATWarn :: Name -> SDoc
 576 omittedATWarn at
 577   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 578
 579 badGenericInstance :: Var -> SDoc -> SDoc
 580 badGenericInstance sel_id because
 581   = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
 582          because]
 583
 584 notSimple :: [Type] -> SDoc
 585 notSimple inst_tys
 586   = vcat [ptext (sLit "because the instance type(s)"),
 587           nest 2 (ppr inst_tys),
 588           ptext (sLit "is not a simple type of form (T a1 ... an)")]
 589
 590 notGeneric :: TyCon -> SDoc
 591 notGeneric tycon
 592   = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
 593           ptext (sLit "was not compiled with -XGenerics")]
 594
 595 badGenericInstanceType :: LHsBinds Name -> SDoc
 596 badGenericInstanceType binds
 597   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
 598           nest 4 (ppr binds)]
 599
 600 missingGenericInstances :: [Name] -> SDoc
 601 missingGenericInstances missing
 602   = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
 603
 604 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
 605 dupGenericInsts tc_inst_infos
 606   = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
 607           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 608           ptext (sLit "All the type patterns for a generic type constructor must be identical")
 609     ]
 610   where
 611     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 612
 613 mixedGenericErr :: Name -> SDoc
 614 mixedGenericErr op
 615   = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 616 \end{code}