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 Inst
  20 import InstEnv
  21 import TcEnv
  22 import TcPat( addInlinePrags )
  23 import TcBinds
  24 import TcUnify
  25 import TcHsType
  26 import TcMType
  27 import TcType
  28 import TcRnMonad
  29 import BuildTyCl( TcMethInfo )
  30 import Generics
  31 import Class
  32 import TyCon
  33 import MkId
  34 import Id
  35 import Name
  36 import Var
  37 import NameSet
  38 import Outputable
  39 import PrelNames
  40 import DynFlags
  41 import ErrUtils
  42 import Util
  43 import ListSetOps
  44 import SrcLoc
  45 import Maybes
  46 import BasicTypes
  47 import Bag
  48 import FastString
  49
  50 import Control.Monad
  51 import Data.List
  52 \end{code}
  53
  54
  55 Dictionary handling
  56 ~~~~~~~~~~~~~~~~~~~
  57 Every class implicitly declares a new data type, corresponding to dictionaries
  58 of that class. So, for example:
  59
  60         class (D a) => C a where
  61           op1 :: a -> a
  62           op2 :: forall b. Ord b => a -> b -> b
  63
  64 would implicitly declare
  65
  66         data CDict a = CDict (D a)
  67                              (a -> a)
  68                              (forall b. Ord b => a -> b -> b)
  69
  70 (We could use a record decl, but that means changing more of the existing apparatus.
  71 One step at at time!)
  72
  73 For classes with just one superclass+method, we use a newtype decl instead:
  74
  75         class C a where
  76           op :: forallb. a -> b -> b
  77
  78 generates
  79
  80         newtype CDict a = CDict (forall b. a -> b -> b)
  81
  82 Now DictTy in Type is just a form of type synomym:
  83         DictTy c t = TyConTy CDict `AppTy` t
  84
  85 Death to "ExpandingDicts".
  86
  87
  88 %************************************************************************
  89 %*                                                                      *
  90                 Type-checking the class op signatures
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 \begin{code}
  95 tcClassSigs :: Name                     -- Name of the class
  96             -> [LSig Name]
  97             -> LHsBinds Name
  98             -> TcM [TcMethInfo]    -- One for each method
  99
 100 tcClassSigs clas sigs def_methods
 101   = do { -- Check that all def_methods are in the class
 102        ; op_info <- mapM (addLocM tc_sig) [sig | sig@(L _ (TypeSig _ _)) <- sigs]
 103        ; let op_names = [ n | (n,_,_) <- op_info ]
 104
 105        ; sequence_ [ failWithTc (badMethodErr clas n)
 106                    | n <- dm_bind_names, not (n `elem` op_names) ]
 107                    -- Value binding for non class-method (ie no TypeSig)
 108
 109        ; sequence_ [ failWithTc (badGenericMethod clas n)
 110                    | n <- genop_names, not (n `elem` dm_bind_names) ]
 111                    -- Generic signature without value binding
 112
 113        ; return op_info }
 114   where
 115     dm_bind_names :: [Name]     -- These ones have a value binding in the class decl
 116     dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]
 117
 118     genop_names :: [Name]   -- These ones have a generic signature
 119     genop_names = [n | L _ (GenericSig (L _ n) _) <- sigs]
 120
 121     tc_sig (TypeSig (L _ op_name) op_hs_ty)
 122       = do { op_ty <- tcHsKindedType op_hs_ty   -- Class tyvars already in scope
 123            ; let dm | op_name `elem` genop_names   = GenericDM
 124                     | op_name `elem` dm_bind_names = VanillaDM
 125                     | otherwise                    = NoDM
 126            ; return (op_name, dm, op_ty) }
 127     tc_sig sig = pprPanic "tc_cls_sig" (ppr sig)
 128 \end{code}
 129
 130
 131 %************************************************************************
 132 %*                                                                      *
 133                 Class Declarations
 134 %*                                                                      *
 135 %************************************************************************
 136
 137 \begin{code}
 138 tcClassDecl2 :: LTyClDecl Name          -- The class declaration
 139              -> TcM (LHsBinds Id)
 140
 141 tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs,
 142                                 tcdMeths = default_binds}))
 143   = recoverM (return emptyLHsBinds)     $
 144     setSrcSpan loc                      $
 145     do  { clas <- tcLookupLocatedClass class_name
 146
 147         -- We make a separate binding for each default method.
 148         -- At one time I used a single AbsBinds for all of them, thus
 149         -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }
 150         -- But that desugars into
 151         --      ds = \d -> (..., ..., ...)
 152         --      dm1 = \d -> case ds d of (a,b,c) -> a
 153         -- And since ds is big, it doesn't get inlined, so we don't get good
 154         -- default methods.  Better to make separate AbsBinds for each
 155         ; let
 156               (tyvars, _, _, op_items) = classBigSig clas
 157               prag_fn     = mkPragFun sigs default_binds
 158               sig_fn      = mkSigFun sigs
 159               clas_tyvars = tcSuperSkolTyVars tyvars
 160               pred        = mkClassPred clas (mkTyVarTys clas_tyvars)
 161         ; this_dict <- newEvVar pred
 162
 163         ; traceTc "TIM2" (ppr sigs)
 164         ; let tc_dm = tcDefMeth clas clas_tyvars
 165                                 this_dict default_binds sigs
 166                                 sig_fn prag_fn
 167
 168         ; dm_binds <- tcExtendTyVarEnv clas_tyvars $
 169                       mapM tc_dm op_items
 170
 171         ; return (unionManyBags dm_binds) }
 172
 173 tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)
 174
 175 tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> [LSig Name]
 176           -> SigFun -> PragFun -> ClassOpItem
 177           -> TcM (LHsBinds TcId)
 178 -- Generate code for polymorphic default methods only (hence DefMeth)
 179 -- (Generic default methods have turned into instance decls by now.)
 180 -- This is incompatible with Hugs, which expects a polymorphic
 181 -- default method for every class op, regardless of whether or not
 182 -- the programmer supplied an explicit default decl for the class.
 183 -- (If necessary we can fix that, but we don't have a convenient Id to hand.)
 184 tcDefMeth clas tyvars this_dict binds_in sigs sig_fn prag_fn (sel_id, dm_info)
 185   = case dm_info of
 186       NoDefMeth          -> do { mapM_ (addLocM (badDmPrag sel_id)) prags
 187                                ; return emptyBag }
 188       DefMeth dm_name    -> tc_dm dm_name (instantiateMethod clas sel_id (mkTyVarTys tyvars))
 189       GenDefMeth dm_name -> do { tau <- tc_genop_ty (findGenericSig sigs sel_name)
 190                                ; tc_dm dm_name tau }
 191            -- In the case of a generic default, we have to get the type from the signature
 192            -- Otherwise we can get it by instantiating the method selector
 193   where
 194     sel_name      = idName sel_id
 195     prags         = prag_fn sel_name
 196     dm_sig_fn  _  = sig_fn sel_name
 197     dm_bind       = findMethodBind sel_name binds_in
 198                     `orElse` pprPanic "tcDefMeth" (ppr sel_id)
 199
 200     -- Eg.   class C a where
 201     --          op :: forall b. Eq b => a -> [b] -> a
 202     --          gen_op :: a -> a
 203     --          generic gen_op :: D a => a -> a
 204     -- The "local_dm_ty" is precisely the type in the above
 205     -- type signatures, ie with no "forall a. C a =>" prefix
 206
 207     tc_dm dm_name local_dm_ty
 208       = do { local_dm_name <- newLocalName sel_name
 209              -- Base the local_dm_name on the selector name, because
 210              -- type errors from tcInstanceMethodBody come from here
 211
 212            ; let dm_ty = mkSigmaTy tyvars [mkClassPred clas (mkTyVarTys tyvars)] local_dm_ty
 213                  dm_id = mkExportedLocalId dm_name dm_ty
 214                  local_dm_id = mkLocalId local_dm_name local_dm_ty
 215
 216            ; dm_id_w_inline <- addInlinePrags dm_id prags
 217            ; spec_prags     <- tcSpecPrags dm_id prags
 218
 219            ; warnTc (not (null spec_prags))
 220                     (ptext (sLit "Ignoring SPECIALISE pragmas on default method")
 221                      <+> quotes (ppr sel_name))
 222
 223            ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict]
 224                                              dm_id_w_inline local_dm_id dm_sig_fn
 225                                              IsDefaultMethod dm_bind
 226
 227            ; return (unitBag tc_bind) }
 228
 229     tc_genop_ty :: LHsType Name -> TcM Type
 230     tc_genop_ty hs_ty
 231        = setSrcSpan (getLoc hs_ty) $
 232          do { tau <- tcHsKindedType hs_ty
 233             ; checkValidType (FunSigCtxt sel_name) tau
 234             ; return tau }
 235
 236 findGenericSig :: [LSig Name] -> Name -> LHsType Name
 237 -- Find the 'generic op :: ty' signature among the sigs
 238 -- If dm_info is GenDefMeth, the corresponding signature
 239 -- should jolly well exist!  Hence the panic
 240 findGenericSig sigs sel_name
 241   = case [lty | L _ (GenericSig (L _ n) lty) <- sigs
 242          , n == sel_name ] of
 243       [lty] -> lty
 244       _     -> pprPanic "tcDefMeth" (ppr sel_name $$ ppr sigs)
 245
 246 ---------------
 247 tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar]
 248                      -> Id -> Id
 249                      -> SigFun -> TcSpecPrags -> LHsBind Name
 250                      -> TcM (LHsBind Id)
 251 tcInstanceMethodBody skol_info tyvars dfun_ev_vars
 252                      meth_id local_meth_id
 253                      meth_sig_fn specs
 254                      (L loc bind)
 255   = do  {       -- Typecheck the binding, first extending the envt
 256                 -- so that when tcInstSig looks up the local_meth_id to find
 257                 -- its signature, we'll find it in the environment
 258           let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) })
 259                              -- Substitute the local_meth_name for the binder
 260                              -- NB: the binding is always a FunBind
 261         ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id)))
 262         ; (ev_binds, (tc_bind, _))
 263                <- checkConstraints skol_info tyvars dfun_ev_vars $
 264                   tcExtendIdEnv [local_meth_id] $
 265                   tcPolyBinds TopLevel meth_sig_fn no_prag_fn
 266                              NonRecursive NonRecursive
 267                              [lm_bind]
 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 -> Name -> TcM (LHsBind Name)
 375 mkGenericDefMethBind clas inst_tys sel_id dm_name
 376   =     -- A generic default method
 377         -- If the method is defined generically, we only have to call the
 378         -- dm_name.
 379     do  { dflags <- getDOpts
 380         ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
 381                    (vcat [ppr clas <+> ppr inst_tys,
 382                           nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
 383
 384         ; return (noLoc $ mkFunBind (noLoc (idName sel_id))
 385                                     [mkSimpleMatch [] rhs]) }
 386   where
 387     rhs = nlHsVar dm_name
 388
 389 ---------------------------
 390 getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name]
 391 getGenericInstances class_decls
 392   = do  { gen_inst_infos <- mapM (addLocM get_generics) class_decls
 393         ; let { gen_inst_info = concat gen_inst_infos }
 394
 395         -- Return right away if there is no generic stuff
 396         ; if null gen_inst_info then return []
 397           else do
 398
 399         -- Otherwise print it out
 400         { dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
 401                                 2 (vcat (map pprInstInfoDetails gen_inst_info))
 402         ; return gen_inst_info }}
 403
 404 get_generics :: TyClDecl Name -> TcM [InstInfo Name]
 405 get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods})
 406   | null generic_binds
 407   = return [] -- The comon case: no generic default methods
 408
 409   | otherwise   -- A source class decl with generic default methods
 410   = recoverM (return [])                                $
 411     tcAddDeclCtxt decl                                  $ do
 412     clas <- tcLookupLocatedClass class_name
 413
 414         -- Group by type, and
 415         -- make an InstInfo out of each group
 416     let
 417         groups = groupWith listToBag generic_binds
 418
 419     inst_infos <- mapM (mkGenericInstance clas) groups
 420
 421         -- Check that there is only one InstInfo for each type constructor
 422         -- The main way this can fail is if you write
 423         --      f {| a+b |} ... = ...
 424         --      f {| x+y |} ... = ...
 425         -- Then at this point we'll have an InstInfo for each
 426         --
 427         -- The class should be unary, which is why simpleInstInfoTyCon should be ok
 428     let
 429         tc_inst_infos :: [(TyCon, InstInfo Name)]
 430         tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
 431
 432         bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
 433                               group `lengthExceeds` 1]
 434         get_uniq (tc,_) = getUnique tc
 435
 436     mapM_ (addErrTc . dupGenericInsts) bad_groups
 437
 438         -- Check that there is an InstInfo for each generic type constructor
 439     let
 440         missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos]
 441
 442     checkTc (null missing) (missingGenericInstances missing)
 443
 444     return inst_infos
 445   where
 446     generic_binds :: [(HsType Name, LHsBind Name)]
 447     generic_binds = getGenericBinds def_methods
 448 get_generics decl = pprPanic "get_generics" (ppr decl)
 449
 450
 451 ---------------------------------
 452 getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)]
 453   -- Takes a group of method bindings, finds the generic ones, and returns
 454   -- them in finite map indexed by the type parameter in the definition.
 455 getGenericBinds binds = concat (map getGenericBind (bagToList binds))
 456
 457 getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)]
 458 getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty }))
 459   = groupWith wrap (mapCatMaybes maybeGenericMatch matches)
 460   where
 461     wrap ms = L loc (bind { fun_matches = MatchGroup ms ty })
 462 getGenericBind _
 463   = []
 464
 465 groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)]
 466 groupWith _  []          = []
 467 groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest
 468     where
 469       vs              = map snd this
 470       (this,rest)     = partition same_t prs
 471       same_t (t', _v) = t `eqPatType` t'
 472
 473 eqPatLType :: LHsType Name -> LHsType Name -> Bool
 474 eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2
 475
 476 eqPatType :: HsType Name -> HsType Name -> Bool
 477 -- A very simple equality function, only for
 478 -- type patterns in generic function definitions.
 479 eqPatType (HsTyVar v1)       (HsTyVar v2)       = v1==v2
 480 eqPatType (HsAppTy s1 t1)    (HsAppTy s2 t2)    = s1 `eqPatLType` s2 && t1 `eqPatLType` t2
 481 eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2
 482 eqPatType (HsNumTy n1)       (HsNumTy n2)       = n1 == n2
 483 eqPatType (HsParTy t1)       t2                 = unLoc t1 `eqPatType` t2
 484 eqPatType t1                 (HsParTy t2)       = t1 `eqPatType` unLoc t2
 485 eqPatType _ _ = False
 486
 487 ---------------------------------
 488 mkGenericInstance :: Class
 489                   -> (HsType Name, LHsBinds Name)
 490                   -> TcM (InstInfo Name)
 491
 492 mkGenericInstance clas (hs_ty, binds) = do
 493   -- Make a generic instance declaration
 494   -- For example:       instance (C a, C b) => C (a+b) where { binds }
 495
 496         -- Extract the universally quantified type variables
 497         -- and wrap them as forall'd tyvars, so that kind inference
 498         -- works in the standard way
 499     let
 500         sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $
 501                   extractHsTyVars (noLoc hs_ty)
 502         hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty)
 503
 504         -- Type-check the instance type, and check its form
 505     forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty
 506     let
 507         (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty
 508
 509     checkTc (validGenericInstanceType inst_ty)
 510             (badGenericInstanceType binds)
 511
 512         -- Make the dictionary function.
 513     span <- getSrcSpanM
 514     overlap_flag <- getOverlapFlag
 515     dfun_name <- newDFunName clas [inst_ty] span
 516     let
 517         inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 518         dfun_id    = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty]
 519         ispec      = mkLocalInstance dfun_id overlap_flag
 520
 521     return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False })
 522 \end{code}
 523
 524
 525 %************************************************************************
 526 %*                                                                      *
 527                 Error messages
 528 %*                                                                      *
 529 %************************************************************************
 530
 531 \begin{code}
 532 tcAddDeclCtxt :: TyClDecl Name -> TcM a -> TcM a
 533 tcAddDeclCtxt decl thing_inside
 534   = addErrCtxt ctxt thing_inside
 535   where
 536      thing | isClassDecl decl  = "class"
 537            | isTypeDecl decl   = "type synonym" ++ maybeInst
 538            | isDataDecl decl   = if tcdND decl == NewType
 539                                  then "newtype" ++ maybeInst
 540                                  else "data type" ++ maybeInst
 541            | isFamilyDecl decl = "family"
 542            | otherwise         = panic "tcAddDeclCtxt/thing"
 543
 544      maybeInst | isFamInstDecl decl = " instance"
 545                | otherwise          = ""
 546
 547      ctxt = hsep [ptext (sLit "In the"), text thing,
 548                   ptext (sLit "declaration for"), quotes (ppr (tcdName decl))]
 549
 550 badMethodErr :: Outputable a => a -> Name -> SDoc
 551 badMethodErr clas op
 552   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 553           ptext (sLit "does not have a method"), quotes (ppr op)]
 554
 555 badGenericMethod :: Outputable a => a -> Name -> SDoc
 556 badGenericMethod clas op
 557   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 558           ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)]
 559
 560 badATErr :: Class -> Name -> SDoc
 561 badATErr clas at
 562   = hsep [ptext (sLit "Class"), quotes (ppr clas),
 563           ptext (sLit "does not have an associated type"), quotes (ppr at)]
 564
 565 omittedATWarn :: Name -> SDoc
 566 omittedATWarn at
 567   = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at)
 568
 569 badGenericInstanceType :: LHsBinds Name -> SDoc
 570 badGenericInstanceType binds
 571   = vcat [ptext (sLit "Illegal type pattern in the generic bindings"),
 572           nest 2 (ppr binds)]
 573
 574 missingGenericInstances :: [Name] -> SDoc
 575 missingGenericInstances missing
 576   = ptext (sLit "Missing type patterns for") <+> pprQuotedList missing
 577
 578 dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc
 579 dupGenericInsts tc_inst_infos
 580   = vcat [ptext (sLit "More than one type pattern for a single generic type constructor:"),
 581           nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),
 582           ptext (sLit "All the type patterns for a generic type constructor must be identical")
 583     ]
 584   where
 585     ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)
 586
 587 badDmPrag :: Id -> Sig Name -> TcM ()
 588 badDmPrag sel_id prag
 589   = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method")
 590               <+> quotes (ppr sel_id)
 591               <+> ptext (sLit "lacks an accompanying binding"))
 592 \end{code}