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