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