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