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