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