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 ([Id], 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_stuff <- tcExtendTyVarEnv clas_tyvars $
 183                       mapM tc_dm op_items
 184         ; let (dm_ids, defm_binds) = unzip (catMaybes dm_stuff)
 185
 186         ; return (dm_ids, listToBag defm_binds) }
 187
 188 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
 189
 190 tcDefMeth :: Class -> [TyVar] -> Inst -> LHsBinds Name
 191           -> TcSigFun -> TcPragFun -> ClassOpItem
 192           -> TcM (Maybe (Id, LHsBind Id))
 193 -- Generate code for polymorphic default methods only (hence DefMeth)
 194 -- (Generic default methods have turned into instance decls by now.)
 195 -- This is incompatible with Hugs, which expects a polymorphic
 196 -- default method for every class op, regardless of whether or not
 197 -- the programmer supplied an explicit default decl for the class.
 198 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 199 tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
 200   = case dm_info of
 201       NoDefMeth       -> return Nothing
 202       GenDefMeth      -> return Nothing
 203       DefMeth dm_name -> do
 204         { let sel_name = idName sel_id
 205         ; local_dm_name <- newLocalName sel_name
 206           -- Base the local_dm_name on the selector name, because
 207           -- type errors from tcInstanceMethodBody come from here
 208
 209                 -- See Note [Silly default-method bind]
 210                 -- (possibly out of date)
 211
 212         ; let meth_bind = findMethodBind sel_name local_dm_name binds_in
 213                           `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 214                 -- dm_info = DefMeth dm_name only if there is a binding in binds_in
 215
 216               dm_sig_fn  _ = sig_fn sel_name
 217               dm_ty = idType sel_id
 218               dm_id = mkDefaultMethodId dm_name dm_ty
 219               local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
 220               local_dm_id   = mkLocalId local_dm_name local_dm_type
 221
 222         ; (dm_id_w_inline, spec_prags)
 223                 <- tcPrags NonRecursive False True dm_id (prag_fn sel_name)
 224
 225         ; warnTc (not (null spec_prags))
 226                  (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
 227                   <+> quotes (ppr sel_name))
 228
 229         ; liftM Just $
 230           tcInstanceMethodBody (instLoc this_dict)
 231                                tyvars [this_dict]
 232                                ([], emptyBag)
 233                                dm_id_w_inline local_dm_id
 234                                dm_sig_fn IsDefaultMethod meth_bind }
 235
 236 ---------------
 237 tcInstanceMethodBody :: InstLoc -> [TcTyVar] -> [Inst]
 238                      -> ([Inst], LHsBinds Id) -> Id -> Id
 239                      -> TcSigFun -> TcSpecPrags -> LHsBind Name
 240                      -> TcM (Id, LHsBind Id)
 241 tcInstanceMethodBody inst_loc tyvars dfun_dicts
 242                      (this_dict, this_bind) meth_id local_meth_id
 243                      meth_sig_fn spec_prags bind@(L loc _)
 244   = do  {       -- Typecheck the binding, first extending the envt
 245                 -- so that when tcInstSig looks up the local_meth_id to find
 246                 -- its signature, we'll find it in the environment
 247         ; ((tc_bind, _), lie) <- getLIE $
 248                                  tcExtendIdEnv [local_meth_id] $
 249                                  tcPolyBinds TopLevel meth_sig_fn no_prag_fn
 250                                              NonRecursive NonRecursive
 251                                              (unitBag bind)
 252
 253         ; let avails = this_dict ++ dfun_dicts
 254                 -- Only need the this_dict stuff if there are type
 255                 -- variables involved; otherwise overlap is not possible
 256                 -- See Note [Subtle interaction of recursion and overlap]
 257                 -- in TcInstDcls
 258         ; lie_binds <- tcSimplifyCheck inst_loc tyvars avails lie
 259
 260         ; let full_bind = AbsBinds tyvars dfun_lam_vars
 261                                   [(tyvars, meth_id, local_meth_id, spec_prags)]
 262                                   (this_bind `unionBags` lie_binds
 263                                    `unionBags` tc_bind)
 264
 265               dfun_lam_vars = map instToVar dfun_dicts  -- Includes equalities
 266
 267         ; return (meth_id, L loc full_bind) }
 268   where
 269     no_prag_fn  _ = []          -- No pragmas for local_meth_id;
 270                                 -- they are all for meth_id
 271 \end{code}
 272
 273 \begin{code}
 274 instantiateMethod :: Class -> Id -> [TcType] -> TcType
 275 -- Take a class operation, say
 276 --      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
 277 -- Instantiate it at [ty1,ty2]
 278 -- Return the "local method type":
 279 --      forall c. Ix x => (ty2,c) -> ty1
 280 instantiateMethod clas sel_id inst_tys
 281   = ASSERT( ok_first_pred ) local_meth_ty
 282   where
 283     (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
 284     rho_ty = ASSERT( length sel_tyvars == length inst_tys )
 285              substTyWith sel_tyvars inst_tys sel_rho
 286
 287     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
 288                 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
 289
 290     ok_first_pred = case getClassPredTys_maybe first_pred of
 291                       Just (clas1, _tys) -> clas == clas1
 292                       Nothing -> False
 293               -- The first predicate should be of form (C a b)
 294               -- where C is the class in question
 295
 296
 297 ---------------------------
 298 -- The renamer just puts the selector ID as the binder in the method binding
 299 -- but we must use the method name; so we substitute it here.  Crude but simple.
 300 findMethodBind  :: Name -> Name         -- Selector and method name
 301                 -> LHsBinds Name        -- A group of bindings
 302                 -> Maybe (LHsBind Name) -- The binding, with meth_name replacing sel_name
 303 findMethodBind sel_name meth_name binds
 304   = foldlBag mplus Nothing (mapBag f binds)
 305   where
 306         f (L loc1 bind@(FunBind { fun_id = L loc2 op_name }))
 307                  | op_name == sel_name
 308                  = Just (L loc1 (bind { fun_id = L loc2 meth_name }))
 309         f _other = Nothing
 310 \end{code}
 311
 312 Note [Polymorphic methods]
 313 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 314 Consider
 315     class Foo a where
 316         op :: forall b. Ord b => a -> b -> b -> b
 317     instance Foo c => Foo [c] where
 318         op = e
 319
 320 When typechecking the binding 'op = e', we'll have a meth_id for op
 321 whose type is
 322       op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
 323
 324 So tcPolyBinds must be capable of dealing with nested polytypes;
 325 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
 326
 327 Note [Silly default-method bind]
 328 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 329 When we pass the default method binding to the type checker, it must
 330 look like    op2 = e
 331 not          $dmop2 = e
 332 otherwise the "$dm" stuff comes out error messages.  But we want the
 333 "$dm" to come out in the interface file.  So we typecheck the former,
 334 and wrap it in a let, thus
 335           $dmop2 = let op2 = e in op2
 336 This makes the error messages right.
 337
 338
 339 %************************************************************************
 340 %*                                                                      *
 341         Extracting generic instance declaration from class declarations
 342 %*                                                                      *
 343 %************************************************************************
 344
 345 @getGenericInstances@ extracts the generic instance declarations from a class
 346 declaration.  For exmaple
 347
 348         class C a where
 349           op :: a -> a
 350
 351           op{ x+y } (Inl v)   = ...
 352           op{ x+y } (Inr v)   = ...
 353           op{ x*y } (v :*: w) = ...
 354           op{ 1   } Unit      = ...
 355
 356 gives rise to the instance declarations
 357
 358         instance C (x+y) where
 359           op (Inl v)   = ...
 360           op (Inr v)   = ...
 361
 362         instance C (x*y) where
 363           op (v :*: w) = ...
 364
 365         instance C 1 where
 366           op Unit      = ...
 367
 368 \begin{code}
 369 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
 370 mkGenericDefMethBind clas inst_tys sel_id meth_name
 371   =     -- A generic default method
 372         -- If the method is defined generically, we can only do the job if the
 373         -- instance declaration is for a single-parameter type class with
 374         -- a type constructor applied to type arguments in the instance decl
 375         --      (checkTc, so False provokes the error)
 376     do  { checkTc (isJust maybe_tycon)
 377                   (badGenericInstance sel_id (notSimple inst_tys))
 378         ; checkTc (tyConHasGenerics tycon)
 379                   (badGenericInstance sel_id (notGeneric tycon))
 380
 381         ; dflags <- getDOpts
 382         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 383                    (vcat [ppr clas <+> ppr inst_tys,
 384                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 385
 386                 -- Rename it before returning it
 387         ; (rn_rhs, _) <- rnLExpr rhs
 388         ; return (noLoc $ mkFunBind (noLoc meth_name) [mkSimpleMatch [] rn_rhs]) }
 389   where
 390     rhs = mkGenericRhs sel_id clas_tyvar tycon
 391
 392           -- The tycon is only used in the generic case, and in that
 393           -- case we require that the instance decl is for a single-parameter
 394           -- type class with type variable arguments:
 395           --    instance (...) => C (T a b)
 396     clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
 397     Just tycon  = maybe_tycon
 398     maybe_tycon = case inst_tys of
 399                         [ty] -> case tcSplitTyConApp_maybe ty of
 400                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 401                                   _                                               -> Nothing
 402                         _ -> Nothing
 403
 404
 405 ---------------------------
 406 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
 407 getGenericInstances class_decls
 408   = do  { gen_inst_infos <- mapM (addLocM get_generics) class_decls
 409         ; let { gen_inst_info = concat gen_inst_infos }
 410
 411         -- Return right away if there is no generic stuff
 412         ; if null gen_inst_info then return []
 413           else do
 414
 415         -- Otherwise print it out
 416         { dflags <- getDOpts
 417         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 418                  (vcat (map pprInstInfoDetails gen_inst_info)))
 419         ; return gen_inst_info }}
 420
 421 get_generics :: TyClDecl Name -> TcM [InstInfo Name]
 422 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 423   | null generic_binds
 424   = return [] -- The comon case: no generic default methods
 425
 426   | otherwise   -- A source class decl with generic default methods
 427   = recoverM (return [])                                $
 428     tcAddDeclCtxt decl                                  $ do
 429     clas <- tcLookupLocatedClass class_name
 430
 431         -- Group by type, and
 432         -- make an InstInfo out of each group
 433     let
 434         groups = groupWith listToBag generic_binds
 435
 436     inst_infos <- mapM (mkGenericInstance clas) groups
 437
 438         -- Check that there is only one InstInfo for each type constructor
 439         -- The main way this can fail is if you write
 440         --      f {| a+b |} ... = ...
 441         --      f {| x+y |} ... = ...
 442         -- Then at this point we'll have an InstInfo for each
 443         --
 444         -- The class should be unary, which is why simpleInstInfoTyCon should be ok
 445     let
 446         tc_inst_infos :: [(TyCon, InstInfo Name)]
 447         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 448
 449         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 450                               group `lengthExceeds` 1]
 451         get_uniq (tc,_) = getUnique tc
 452
 453     mapM_ (addErrTc . dupGenericInsts) bad_groups
 454
 455         -- Check that there is an InstInfo for each generic type constructor
 456     let
 457         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 458
 459     checkTc (null missing) (missingGenericInstances missing)
 460
 461     return inst_infos
 462   where
 463     generic_binds :: [(HsType Name, LHsBind Name)]
 464     generic_binds = getGenericBinds def_methods
 465 get_generics decl = pprPanic "get_generics" (ppr decl)
 466
 467
 468 ---------------------------------
 469 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 470   -- Takes a group of method bindings, finds the generic ones, and returns
 471   -- them in finite map indexed by the type parameter in the definition.
 472 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 473
 474 getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
 475 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
 476   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 477   where
 478     wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
 479 getGenericBind _
 480   = []
 481
 482 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 483 groupWith _  []          = []
 484 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 485     where
 486       vs              = map snd this
 487       (this,rest)     = partition same_t prs
 488       same_t (t', _v) = t `eqPatType` t'
 489
 490 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 491 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 492
 493 eqPatType :: HsType Name -> HsType Name -> Bool
 494 -- A very simple equality function, only for
 495 -- type patterns in generic function definitions.
 496 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 497 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
 498 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
 499 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 500 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 501 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 502 eqPatType _ _ = False
 503
 504 ---------------------------------
 505 mkGenericInstance :: Class
 506                   -> (HsType Name, LHsBinds Name)
 507                   -> TcM (InstInfo Name)
 508
 509 mkGenericInstance clas (hs_ty, binds) = do
 510   -- Make a generic instance declaration
 511   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 512
 513         -- Extract the universally quantified type variables
 514         -- and wrap them as forall'd tyvars, so that kind inference
 515         -- works in the standard way
 516     let
 517         sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
 518                   extractHsTyVars (noLoc hs_ty)
 519         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 520
 521         -- Type-check the instance type, and check its form
 522     forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
 523     let
 524         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 525
 526     checkTc (validGenericInstanceType inst_ty)
 527             (badGenericInstanceType binds)
 528
 529         -- Make the dictionary function.
 530     span <- getSrcSpanM
 531     overlap_flag <- getOverlapFlag
 532     dfun_name <- newDFunName clas [inst_ty] span
 533     let
 534         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 535         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 536         ispec      = mkLocalInstance dfun_id overlap_flag
 537
 538     return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
 539 \end{code}
 540
 541
 542 %************************************************************************
 543 %*                                                                      *
 544                 Error messages
 545 %*                                                                      *
 546 %************************************************************************
 547
 548 \begin{code}
 549 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
 550 tcAddDeclCtxt decl thing_inside
 551   = addErrCtxt ctxt thing_inside
 552   where
 553      thing | isClassDecl decl  = "class"
 554            | isTypeDecl decl   = "type synonym" ++ maybeInst
 555            | isDataDecl decl   = if tcdND decl == NewType
 556                                  then "newtype" ++ maybeInst
 557                                  else "data type" ++ maybeInst
 558            | isFamilyDecl decl = "family"
 559            | otherwise         = panic "tcAddDeclCtxt/thing"
 560
 561      maybeInst | isFamInstDecl decl = " instance"
 562                | otherwise          = ""
 563
 564      ctxt = hsep [ptext (sLit "In the"), text thing,
 565                   ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
 566
 567 badMethodErr :: Outputable a => a -> Name -> SDoc
 568 badMethodErr clas op
 569   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 570           ptext (sLit "does not have a method"), quotes (ppr op)]
 571
 572 badATErr :: Class -> Name -> SDoc
 573 badATErr clas at
 574   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 575           ptext (sLit "does not have an associated type"), quotes (ppr at)]
 576
 577 omittedATWarn :: Name -> SDoc
 578 omittedATWarn at
 579   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 580
 581 badGenericInstance :: Var -> SDoc -> SDoc
 582 badGenericInstance sel_id because
 583   = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
 584          because]
 585
 586 notSimple :: [Type] -> SDoc
 587 notSimple inst_tys
 588   = vcat [ptext (sLit "because the instance type(s)"),
 589           nest 2 (ppr inst_tys),
 590           ptext (sLit "is not a simple type of form (T a1 ... an)")]
 591
 592 notGeneric :: TyCon -> SDoc
 593 notGeneric tycon
 594   = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
 595           ptext (sLit "was not compiled with -XGenerics")]
 596
 597 badGenericInstanceType :: LHsBinds Name -> SDoc
 598 badGenericInstanceType binds
 599   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
 600           nest 4 (ppr binds)]
 601
 602 missingGenericInstances :: [Name] -> SDoc
 603 missingGenericInstances missing
 604   = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
 605
 606 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
 607 dupGenericInsts tc_inst_infos
 608   = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
 609           nest 4 (vcat (map ppr_inst_ty tc_inst_infos)),
 610           ptext (sLit "All the type patterns for a generic type constructor must be identical")
 611     ]
 612   where
 613     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 614
 615 mixedGenericErr :: Name -> SDoc
 616 mixedGenericErr op
 617   = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 618 \end{code}