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