compiler/typecheck/TcClassDcl.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Typechecking class declarations
   7
   8 \begin{code}
   9 module TcClassDcl ( tcClassSigs, tcClassDecl2,
  10                     findMethodBind, instantiateMethod, tcInstanceMethodBody,
  11                     mkGenericDefMethBind, getGenericInstances,
  12                     tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
  13                   ) where
  14
  15 #include "HsVersions.h"
  16
  17 import HsSyn
  18 import RnHsSyn
  19 import RnExpr
  20 import Inst
  21 import InstEnv
  22 import TcPat( addInlinePrags )
  23 import TcEnv
  24 import TcBinds
  25 import TcUnify
  26 import TcHsType
  27 import TcMType
  28 import TcType
  29 import TcRnMonad
  30 import BuildTyCl( TcMethInfo )
  31 import Generics
  32 import Class
  33 import TyCon
  34 import MkId
  35 import Id
  36 import Name
  37 import Var
  38 import NameEnv
  39 import NameSet
  40 import Outputable
  41 import PrelNames
  42 import DynFlags
  43 import ErrUtils
  44 import Util
  45 import ListSetOps
  46 import SrcLoc
  47 import Maybes
  48 import BasicTypes
  49 import Bag
  50 import FastString
  51
  52 import Control.Monad
  53 import Data.List
  54 \end{code}
  55
  56
  57 Dictionary handling
  58 ~~~~~~~~~~~~~~~~~~~
  59 Every class implicitly declares a new data type, corresponding to dictionaries
  60 of that class. So, for example:
  61
  62         class (D a) => C a where
  63           op1 :: a -> a
  64           op2 :: forall b. Ord b => a -> b -> b
  65
  66 would implicitly declare
  67
  68         data CDict a = CDict (D a)
  69                              (a -> a)
  70                              (forall b. Ord b => a -> b -> b)
  71
  72 (We could use a record decl, but that means changing more of the existing apparatus.
  73 One step at at time!)
  74
  75 For classes with just one superclass+method, we use a newtype decl instead:
  76
  77         class C a where
  78           op :: forallb. a -> b -> b
  79
  80 generates
  81
  82         newtype CDict a = CDict (forall b. a -> b -> b)
  83
  84 Now DictTy in Type is just a form of type synomym:
  85         DictTy c t = TyConTy CDict `AppTy` t
  86
  87 Death to "ExpandingDicts".
  88
  89
  90 %************************************************************************
  91 %*                                                                      *
  92                 Type-checking the class op signatures
  93 %*                                                                      *
  94 %************************************************************************
  95
  96 \begin{code}
  97 tcClassSigs :: Name                     -- Name of the class
  98             -> [LSig Name]
  99             -> LHsBinds Name
 100             -> TcM [TcMethInfo]
 101
 102 tcClassSigs clas sigs def_methods
 103   = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names))
 104                         (bagToList def_methods)
 105        ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs }
 106   where
 107     op_sigs  = [sig | sig@(L _ (TypeSig _ _))       <- sigs]
 108     op_names = [n   |     (L _ (TypeSig (L _ n) _)) <- op_sigs]
 109
 110 checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec)
 111   -- Check default bindings
 112   --    a) must be for a class op for this class
 113   --    b) must be all generic or all non-generic
 114 checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ })
 115   = do {        -- Check that the op is from this class
 116          checkTc (op `elem` ops) (badMethodErr clas op)
 117
 118         -- Check that all the defns ar generic, or none are
 119        ; case (none_generic, all_generic) of
 120            (True, _) -> return (op, VanillaDM)
 121            (_, True) -> return (op, GenericDM)
 122            _         -> failWith (mixedGenericErr op)
 123     }
 124   where
 125     n_generic    = count (isJust . maybeGenericMatch) matches
 126     none_generic = n_generic == 0
 127     all_generic  = matches `lengthIs` n_generic
 128
 129 checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b)
 130
 131
 132 tcClassSig :: NameEnv DefMethSpec       -- Info about default methods;
 133            -> LSig Name
 134            -> TcM TcMethInfo
 135
 136 tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty))
 137   = setSrcSpan loc $ do
 138     { op_ty <- tcHsKindedType op_hs_ty  -- Class tyvars already in scope
 139     ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM
 140     ; return (op_name, dm, op_ty) }
 141 tcClassSig _ s = pprPanic "tcClassSig" (ppr s)
 142 \end{code}
 143
 144
 145 %************************************************************************
 146 %*                                                                      *
 147                 Class Declarations
 148 %*                                                                      *
 149 %************************************************************************
 150
 151 \begin{code}
 152 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
 153              -> TcM (LHsBinds Id)
 154
 155 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 156                                 tcdMeths = default_binds}))
 157   = recoverM (return emptyLHsBinds)     $
 158     setSrcSpan loc                      $
 159     do  { clas <- tcLookupLocatedClass class_name
 160
 161         -- We make a separate binding for each default method.
 162         -- At one time I used a single AbsBinds for all of them, thus
 163         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 164         -- But that desugars into
 165         --      ds = \d -> (..., ..., ...)
 166         --      dm1 = \d -> case ds d of (a,b,c) -> a
 167         -- And since ds is big, it doesn't get inlined, so we don't get good
 168         -- default methods.  Better to make separate AbsBinds for each
 169         ; let
 170               (tyvars, _, _, op_items) = classBigSig clas
 171               rigid_info  = ClsSkol clas
 172               prag_fn     = mkPragFun sigs default_binds
 173               sig_fn      = mkSigFun sigs
 174               clas_tyvars = tcSkolSigTyVars rigid_info tyvars
 175               pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
 176         ; this_dict <- newEvVar pred
 177
 178         ; let tc_dm = tcDefMeth clas clas_tyvars
 179                                 this_dict default_binds
 180                                 sig_fn prag_fn
 181
 182         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
 183                       mapM tc_dm op_items
 184
 185         ; return (listToBag (catMaybes dm_binds)) }
 186
 187 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
 188
 189 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name
 190           -> SigFun -> PragFun -> ClassOpItem
 191           -> TcM (Maybe (LHsBind Id))
 192 -- Generate code for polymorphic default methods only (hence DefMeth)
 193 -- (Generic default methods have turned into instance decls by now.)
 194 -- This is incompatible with Hugs, which expects a polymorphic
 195 -- default method for every class op, regardless of whether or not
 196 -- the programmer supplied an explicit default decl for the class.
 197 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 198 tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info)
 199   = case dm_info of
 200       NoDefMeth       -> return Nothing
 201       GenDefMeth      -> return Nothing
 202       DefMeth dm_name -> do
 203         { let sel_name = idName sel_id
 204         ; local_dm_name <- newLocalName sel_name
 205           -- Base the local_dm_name on the selector name, because
 206           -- type errors from tcInstanceMethodBody come from here
 207
 208                 -- See Note [Silly default-method bind]
 209                 -- (possibly out of date)
 210
 211         ; let meth_bind = findMethodBind sel_name binds_in
 212                           `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 213                 -- dm_info = DefMeth dm_name only if there is a binding in binds_in
 214
 215               dm_sig_fn  _  = sig_fn sel_name
 216               dm_id         = mkDefaultMethodId sel_id dm_name
 217               local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars)
 218               local_dm_id   = mkLocalId local_dm_name local_dm_type
 219               prags         = prag_fn sel_name
 220
 221         ; dm_id_w_inline <- addInlinePrags dm_id prags
 222         ; spec_prags     <- tcSpecPrags dm_id prags
 223
 224         ; warnTc (not (null spec_prags))
 225                  (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
 226                   <+> quotes (ppr sel_name))
 227
 228         ; liftM Just $
 229           tcInstanceMethodBody (ClsSkol clas)
 230                                tyvars
 231                                [this_dict]
 232                                dm_id_w_inline local_dm_id
 233                                dm_sig_fn IsDefaultMethod meth_bind }
 234
 235 ---------------
 236 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
 237                      -> Id -> Id
 238                      -> SigFun -> TcSpecPrags -> LHsBind Name
 239                      -> TcM (LHsBind Id)
 240 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
 241                      meth_id local_meth_id
 242                      meth_sig_fn specs
 243                      (L loc bind)
 244   = do  {       -- Typecheck the binding, first extending the envt
 245                 -- so that when tcInstSig looks up the local_meth_id to find
 246                 -- its signature, we'll find it in the environment
 247           let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
 248                              -- Substitute the local_meth_name for the binder
 249                              -- NB: the binding is always a FunBind
 250
 251         ; (ev_binds, (tc_bind, _))
 252                <- checkConstraints skol_info tyvars dfun_ev_vars $
 253                   tcExtendIdEnv [local_meth_id] $
 254                   tcPolyBinds TopLevel meth_sig_fn no_prag_fn
 255                              NonRecursive NonRecursive
 256                              [lm_bind]
 257
 258         ; let full_bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
 259                                    , abs_exports = [(tyvars, meth_id, local_meth_id, specs)]
 260                                    , abs_ev_binds = ev_binds
 261                                    , abs_binds = tc_bind }
 262
 263         ; return (L loc full_bind) }
 264   where
 265     no_prag_fn  _ = []          -- No pragmas for local_meth_id;
 266                                 -- they are all for meth_id
 267 \end{code}
 268
 269 \begin{code}
 270 instantiateMethod :: Class -> Id -> [TcType] -> TcType
 271 -- Take a class operation, say
 272 --      op :: forall ab. C a => forall c. Ix c => (b,c) -> a
 273 -- Instantiate it at [ty1,ty2]
 274 -- Return the "local method type":
 275 --      forall c. Ix x => (ty2,c) -> ty1
 276 instantiateMethod clas sel_id inst_tys
 277   = ASSERT( ok_first_pred ) local_meth_ty
 278   where
 279     (sel_tyvars,sel_rho) = tcSplitForAllTys (idType sel_id)
 280     rho_ty = ASSERT( length sel_tyvars == length inst_tys )
 281              substTyWith sel_tyvars inst_tys sel_rho
 282
 283     (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty
 284                 `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)
 285
 286     ok_first_pred = case getClassPredTys_maybe first_pred of
 287                       Just (clas1, _tys) -> clas == clas1
 288                       Nothing -> False
 289               -- The first predicate should be of form (C a b)
 290               -- where C is the class in question
 291
 292
 293 ---------------------------
 294 findMethodBind  :: Name                 -- Selector name
 295                 -> LHsBinds Name        -- A group of bindings
 296                 -> Maybe (LHsBind Name) -- The binding
 297 findMethodBind sel_name binds
 298   = foldlBag mplus Nothing (mapBag f binds)
 299   where
 300     f bind@(L _ (FunBind { fun_id = L _ op_name }))
 301              | op_name == sel_name
 302              = Just bind
 303     f _other = Nothing
 304 \end{code}
 305
 306 Note [Polymorphic methods]
 307 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 308 Consider
 309     class Foo a where
 310         op :: forall b. Ord b => a -> b -> b -> b
 311     instance Foo c => Foo [c] where
 312         op = e
 313
 314 When typechecking the binding 'op = e', we'll have a meth_id for op
 315 whose type is
 316       op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b
 317
 318 So tcPolyBinds must be capable of dealing with nested polytypes;
 319 and so it is. See TcBinds.tcMonoBinds (with type-sig case).
 320
 321 Note [Silly default-method bind]
 322 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 323 When we pass the default method binding to the type checker, it must
 324 look like    op2 = e
 325 not          $dmop2 = e
 326 otherwise the "$dm" stuff comes out error messages.  But we want the
 327 "$dm" to come out in the interface file.  So we typecheck the former,
 328 and wrap it in a let, thus
 329           $dmop2 = let op2 = e in op2
 330 This makes the error messages right.
 331
 332
 333 %************************************************************************
 334 %*                                                                      *
 335         Extracting generic instance declaration from class declarations
 336 %*                                                                      *
 337 %************************************************************************
 338
 339 @getGenericInstances@ extracts the generic instance declarations from a class
 340 declaration.  For exmaple
 341
 342         class C a where
 343           op :: a -> a
 344
 345           op{ x+y } (Inl v)   = ...
 346           op{ x+y } (Inr v)   = ...
 347           op{ x*y } (v :*: w) = ...
 348           op{ 1   } Unit      = ...
 349
 350 gives rise to the instance declarations
 351
 352         instance C (x+y) where
 353           op (Inl v)   = ...
 354           op (Inr v)   = ...
 355
 356         instance C (x*y) where
 357           op (v :*: w) = ...
 358
 359         instance C 1 where
 360           op Unit      = ...
 361
 362 \begin{code}
 363 mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name)
 364 mkGenericDefMethBind clas inst_tys sel_id
 365   =     -- A generic default method
 366         -- If the method is defined generically, we can only do the job if the
 367         -- instance declaration is for a single-parameter type class with
 368         -- a type constructor applied to type arguments in the instance decl
 369         --      (checkTc, so False provokes the error)
 370     do  { checkTc (isJust maybe_tycon)
 371                   (badGenericInstance sel_id (notSimple inst_tys))
 372         ; checkTc (tyConHasGenerics tycon)
 373                   (badGenericInstance sel_id (notGeneric tycon))
 374
 375         ; dflags <- getDOpts
 376         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 377                    (vcat [ppr clas <+> ppr inst_tys,
 378                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 379
 380                 -- Rename it before returning it
 381         ; (rn_rhs, _) <- rnLExpr rhs
 382         ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
 383                                     [mkSimpleMatch [] rn_rhs]) }
 384   where
 385     rhs = mkGenericRhs sel_id clas_tyvar tycon
 386
 387           -- The tycon is only used in the generic case, and in that
 388           -- case we require that the instance decl is for a single-parameter
 389           -- type class with type variable arguments:
 390           --    instance (...) => C (T a b)
 391     clas_tyvar  = ASSERT (not (null (classTyVars clas))) head (classTyVars clas)
 392     Just tycon  = maybe_tycon
 393     maybe_tycon = case inst_tys of
 394                         [ty] -> case tcSplitTyConApp_maybe ty of
 395                                   Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon
 396                                   _                                               -> Nothing
 397                         _ -> Nothing
 398
 399
 400 ---------------------------
 401 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
 402 getGenericInstances class_decls
 403   = do  { gen_inst_infos <- mapM (addLocM get_generics) class_decls
 404         ; let { gen_inst_info = concat gen_inst_infos }
 405
 406         -- Return right away if there is no generic stuff
 407         ; if null gen_inst_info then return []
 408           else do
 409
 410         -- Otherwise print it out
 411         { dflags <- getDOpts
 412         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
 413                  (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 badATErr :: Class -> Name -> SDoc
 568 badATErr clas at
 569   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 570           ptext (sLit "does not have an associated type"), quotes (ppr at)]
 571
 572 omittedATWarn :: Name -> SDoc
 573 omittedATWarn at
 574   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 575
 576 badGenericInstance :: Var -> SDoc -> SDoc
 577 badGenericInstance sel_id because
 578   = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id),
 579          because]
 580
 581 notSimple :: [Type] -> SDoc
 582 notSimple inst_tys
 583   = vcat [ptext (sLit "because the instance type(s)"),
 584           nest 2 (ppr inst_tys),
 585           ptext (sLit "is not a simple type of form (T a1 ... an)")]
 586
 587 notGeneric :: TyCon -> SDoc
 588 notGeneric tycon
 589   = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+>
 590           ptext (sLit "was not compiled with -XGenerics")]
 591
 592 badGenericInstanceType :: LHsBinds Name -> SDoc
 593 badGenericInstanceType binds
 594   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
 595           nest 2 (ppr binds)]
 596
 597 missingGenericInstances :: [Name] -> SDoc
 598 missingGenericInstances missing
 599   = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
 600
 601 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
 602 dupGenericInsts tc_inst_infos
 603   = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
 604           nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
 605           ptext (sLit "All the type patterns for a generic type constructor must be identical")
 606     ]
 607   where
 608     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 609
 610 mixedGenericErr :: Name -> SDoc
 611 mixedGenericErr op
 612   = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op)
 613 \end{code}