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