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