compiler/typecheck/TcDeriv.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 Handles @deriving@ clauses on @data@ declarations.
   7
   8 \begin{code}
   9 module TcDeriv ( tcDeriving ) where
  10
  11 #include "HsVersions.h"
  12
  13 import HsSyn
  14 import DynFlags
  15
  16 import Generics
  17 import TcRnMonad
  18 import TcEnv
  19 import TcClassDcl( tcAddDeclCtxt )      -- Small helper
  20 import TcGenDeriv                       -- Deriv stuff
  21 import InstEnv
  22 import Inst
  23 import TcHsType
  24 import TcMType
  25 import TcSimplify
  26
  27 import RnBinds
  28 import RnEnv
  29 import HscTypes
  30
  31 import Class
  32 import Type
  33 import Coercion
  34 import ErrUtils
  35 import MkId
  36 import DataCon
  37 import Maybes
  38 import RdrName
  39 import Name
  40 import NameSet
  41 import TyCon
  42 import TcType
  43 import Var
  44 import VarSet
  45 import PrelNames
  46 import SrcLoc
  47 import Util
  48 import ListSetOps
  49 import Outputable
  50 import FastString
  51 import Bag
  52
  53 import Control.Monad
  54 \end{code}
  55
  56 %************************************************************************
  57 %*                                                                      *
  58                 Overview
  59 %*                                                                      *
  60 %************************************************************************
  61
  62 Overall plan
  63 ~~~~~~~~~~~~
  64 1.  Convert the decls (i.e. data/newtype deriving clauses,
  65     plus standalone deriving) to [EarlyDerivSpec]
  66
  67 2.  Infer the missing contexts for the Left DerivSpecs
  68
  69 3.  Add the derived bindings, generating InstInfos
  70
  71
  72 \begin{code}
  73 -- DerivSpec is purely  local to this module
  74 data DerivSpec  = DS { ds_loc     :: SrcSpan
  75                      , ds_orig    :: CtOrigin
  76                      , ds_name    :: Name
  77                      , ds_tvs     :: [TyVar]
  78                      , ds_theta   :: ThetaType
  79                      , ds_cls     :: Class
  80                      , ds_tys     :: [Type]
  81                      , ds_tc      :: TyCon
  82                      , ds_tc_args :: [Type]
  83                      , ds_newtype :: Bool }
  84         -- This spec implies a dfun declaration of the form
  85         --       df :: forall tvs. theta => C tys
  86         -- The Name is the name for the DFun we'll build
  87         -- The tyvars bind all the variables in the theta
  88         -- For type families, the tycon in
  89         --       in ds_tys is the *family* tycon
  90         --       in ds_tc, ds_tc_args is the *representation* tycon
  91         -- For non-family tycons, both are the same
  92
  93         -- ds_newtype = True  <=> Newtype deriving
  94         --              False <=> Vanilla deriving
  95 \end{code}
  96
  97 Example:
  98
  99      newtype instance T [a] = MkT (Tree a) deriving( C s )
 100 ==>
 101      axiom T [a] = :RTList a
 102      axiom :RTList a = Tree a
 103
 104      DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]
 105         , ds_tc = :RTList, ds_tc_args = [a]
 106         , ds_newtype = True }
 107
 108 \begin{code}
 109 type DerivContext = Maybe ThetaType
 110    -- Nothing    <=> Vanilla deriving; infer the context of the instance decl
 111    -- Just theta <=> Standalone deriving: context supplied by programmer
 112
 113 type EarlyDerivSpec = Either DerivSpec DerivSpec
 114         -- Left  ds => the context for the instance should be inferred
 115         --             In this case ds_theta is the list of all the
 116         --                constraints needed, such as (Eq [a], Eq a)
 117         --                The inference process is to reduce this to a
 118         --                simpler form (e.g. Eq a)
 119         --
 120         -- Right ds => the exact context for the instance is supplied
 121         --             by the programmer; it is ds_theta
 122
 123 pprDerivSpec :: DerivSpec -> SDoc
 124 pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs,
 125                    ds_cls = c, ds_tys = tys, ds_theta = rhs })
 126   = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys]
 127             <+> equals <+> ppr rhs)
 128 \end{code}
 129
 130
 131 Inferring missing contexts
 132 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 133 Consider
 134
 135         data T a b = C1 (Foo a) (Bar b)
 136                    | C2 Int (T b a)
 137                    | C3 (T a a)
 138                    deriving (Eq)
 139
 140 [NOTE: See end of these comments for what to do with
 141         data (C a, D b) => T a b = ...
 142 ]
 143
 144 We want to come up with an instance declaration of the form
 145
 146         instance (Ping a, Pong b, ...) => Eq (T a b) where
 147                 x == y = ...
 148
 149 It is pretty easy, albeit tedious, to fill in the code "...".  The
 150 trick is to figure out what the context for the instance decl is,
 151 namely @Ping@, @Pong@ and friends.
 152
 153 Let's call the context reqd for the T instance of class C at types
 154 (a,b, ...)  C (T a b).  Thus:
 155
 156         Eq (T a b) = (Ping a, Pong b, ...)
 157
 158 Now we can get a (recursive) equation from the @data@ decl:
 159
 160         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 161                    u Eq (T b a) u Eq Int        -- From C2
 162                    u Eq (T a a)                 -- From C3
 163
 164 Foo and Bar may have explicit instances for @Eq@, in which case we can
 165 just substitute for them.  Alternatively, either or both may have
 166 their @Eq@ instances given by @deriving@ clauses, in which case they
 167 form part of the system of equations.
 168
 169 Now all we need do is simplify and solve the equations, iterating to
 170 find the least fixpoint.  Notice that the order of the arguments can
 171 switch around, as here in the recursive calls to T.
 172
 173 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 174
 175 We start with:
 176
 177         Eq (T a b) = {}         -- The empty set
 178
 179 Next iteration:
 180         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 181                    u Eq (T b a) u Eq Int        -- From C2
 182                    u Eq (T a a)                 -- From C3
 183
 184         After simplification:
 185                    = Eq a u Ping b u {} u {} u {}
 186                    = Eq a u Ping b
 187
 188 Next iteration:
 189
 190         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 191                    u Eq (T b a) u Eq Int        -- From C2
 192                    u Eq (T a a)                 -- From C3
 193
 194         After simplification:
 195                    = Eq a u Ping b
 196                    u (Eq b u Ping a)
 197                    u (Eq a u Ping a)
 198
 199                    = Eq a u Ping b u Eq b u Ping a
 200
 201 The next iteration gives the same result, so this is the fixpoint.  We
 202 need to make a canonical form of the RHS to ensure convergence.  We do
 203 this by simplifying the RHS to a form in which
 204
 205         - the classes constrain only tyvars
 206         - the list is sorted by tyvar (major key) and then class (minor key)
 207         - no duplicates, of course
 208
 209 So, here are the synonyms for the ``equation'' structures:
 210
 211
 212 Note [Data decl contexts]
 213 ~~~~~~~~~~~~~~~~~~~~~~~~~
 214 Consider
 215
 216         data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
 217
 218 We will need an instance decl like:
 219
 220         instance (Read a, RealFloat a) => Read (Complex a) where
 221           ...
 222
 223 The RealFloat in the context is because the read method for Complex is bound
 224 to construct a Complex, and doing that requires that the argument type is
 225 in RealFloat.
 226
 227 But this ain't true for Show, Eq, Ord, etc, since they don't construct
 228 a Complex; they only take them apart.
 229
 230 Our approach: identify the offending classes, and add the data type
 231 context to the instance decl.  The "offending classes" are
 232
 233         Read, Enum?
 234
 235 FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
 236 pattern matching against a constructor from a data type with a context
 237 gives rise to the constraints for that context -- or at least the thinned
 238 version.  So now all classes are "offending".
 239
 240 Note [Newtype deriving]
 241 ~~~~~~~~~~~~~~~~~~~~~~~
 242 Consider this:
 243     class C a b
 244     instance C [a] Char
 245     newtype T = T Char deriving( C [a] )
 246
 247 Notice the free 'a' in the deriving.  We have to fill this out to
 248     newtype T = T Char deriving( forall a. C [a] )
 249
 250 And then translate it to:
 251     instance C [a] Char => C [a] T where ...
 252
 253
 254 Note [Newtype deriving superclasses]
 255 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 256 (See also Trac #1220 for an interesting exchange on newtype
 257 deriving and superclasses.)
 258
 259 The 'tys' here come from the partial application in the deriving
 260 clause. The last arg is the new instance type.
 261
 262 We must pass the superclasses; the newtype might be an instance
 263 of them in a different way than the representation type
 264 E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )
 265 Then the Show instance is not done via isomorphism; it shows
 266         Foo 3 as "Foo 3"
 267 The Num instance is derived via isomorphism, but the Show superclass
 268 dictionary must the Show instance for Foo, *not* the Show dictionary
 269 gotten from the Num dictionary. So we must build a whole new dictionary
 270 not just use the Num one.  The instance we want is something like:
 271      instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
 272         (+) = ((+)@a)
 273         ...etc...
 274 There may be a coercion needed which we get from the tycon for the newtype
 275 when the dict is constructed in TcInstDcls.tcInstDecl2
 276
 277
 278 Note [Unused constructors and deriving clauses]
 279 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 280 See Trac #3221.  Consider
 281    data T = T1 | T2 deriving( Show )
 282 Are T1 and T2 unused?  Well, no: the deriving clause expands to mention
 283 both of them.  So we gather defs/uses from deriving just like anything else.
 284
 285 %************************************************************************
 286 %*                                                                      *
 287 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 288 %*                                                                      *
 289 %************************************************************************
 290
 291 \begin{code}
 292 tcDeriving  :: [LTyClDecl Name]  -- All type constructors
 293             -> [LInstDecl Name]  -- All instance declarations
 294             -> [LDerivDecl Name] -- All stand-alone deriving declarations
 295             -> TcM ([InstInfo Name],    -- The generated "instance decls"
 296                     HsValBinds Name,    -- Extra generated top-level bindings
 297                     DefUses)
 298
 299 tcDeriving tycl_decls inst_decls deriv_decls
 300   = recoverM (return ([], emptyValBindsOut, emptyDUs)) $
 301     do  {       -- Fish the "deriving"-related information out of the TcEnv
 302                 -- And make the necessary "equations".
 303           is_boot <- tcIsHsBoot
 304         ; traceTc "tcDeriving" (ppr is_boot)
 305         ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 306
 307         ; overlap_flag <- getOverlapFlag
 308         ; let (infer_specs, given_specs) = splitEithers early_specs
 309         ; insts1 <- mapM (genInst True overlap_flag) given_specs
 310
 311         ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $
 312                          inferInstanceContexts overlap_flag infer_specs
 313
 314         ; insts2 <- mapM (genInst False overlap_flag) final_specs
 315
 316                  -- Generate the generic to/from functions from each type declaration
 317         ; gen_binds <- mkGenericBinds is_boot tycl_decls
 318         ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
 319
 320         ; when (not (null inst_info)) $
 321           dumpDerivingInfo (ddump_deriving inst_info rn_binds)
 322
 323         ; return (inst_info, rn_binds, rn_dus) }
 324   where
 325     ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
 326     ddump_deriving inst_infos extra_binds
 327       = hang (ptext (sLit "Derived instances"))
 328            2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
 329               $$ ppr extra_binds)
 330
 331 renameDeriv :: Bool -> LHsBinds RdrName
 332             -> [(InstInfo RdrName, DerivAuxBinds)]
 333             -> TcM ([InstInfo Name], HsValBinds Name, DefUses)
 334 renameDeriv is_boot gen_binds insts
 335   | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings
 336                 -- The inst-info bindings will all be empty, but it's easier to
 337                 -- just use rn_inst_info to change the type appropriately
 338   = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos
 339         ; return (rn_inst_infos, emptyValBindsOut, usesOnly (plusFVs fvs)) }
 340
 341   | otherwise
 342   = discardWarnings $    -- Discard warnings about unused bindings etc
 343     do  { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $  -- Type signatures in patterns
 344                                                                   -- are used in the generic binds
 345                                rnTopBinds (ValBindsIn gen_binds [])
 346         ; keepAliveSetTc (duDefs dus_gen)       -- Mark these guys to be kept alive
 347
 348                 -- Generate and rename any extra not-one-inst-decl-specific binds,
 349                 -- notably "con2tag" and/or "tag2con" functions.
 350                 -- Bring those names into scope before renaming the instances themselves
 351         ; loc <- getSrcSpanM    -- Generic loc for shared bindings
 352         ; let (aux_binds, aux_sigs) = unzip $ map (genAuxBind loc) $
 353                                       rm_dups [] $ concat deriv_aux_binds
 354               aux_val_binds = ValBindsIn (listToBag aux_binds) aux_sigs
 355         ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds
 356         ; bindLocalNames (collectHsValBinders rn_aux_lhs) $
 357     do  { (rn_aux, dus_aux) <- rnTopBindsRHS rn_aux_lhs
 358         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
 359         ; return (rn_inst_infos, rn_aux `plusHsValBinds` rn_gen,
 360                   dus_gen `plusDU` dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }
 361
 362   where
 363     (inst_infos, deriv_aux_binds) = unzip insts
 364
 365         -- Remove duplicate requests for auxilliary bindings
 366     rm_dups acc [] = acc
 367     rm_dups acc (b:bs) | any (isDupAux b) acc = rm_dups acc bs
 368                        | otherwise            = rm_dups (b:acc) bs
 369
 370
 371     rn_inst_info :: InstInfo RdrName -> TcM (InstInfo Name, FreeVars)
 372     rn_inst_info info@(InstInfo { iBinds = NewTypeDerived coi tc })
 373         = return ( info { iBinds = NewTypeDerived coi tc }
 374                  , mkFVs (map dataConName (tyConDataCons tc)))
 375           -- See Note [Newtype deriving and unused constructors]
 376
 377     rn_inst_info inst_info@(InstInfo { iSpec = inst, iBinds = VanillaInst binds sigs standalone_deriv })
 378         =       -- Bring the right type variables into
 379                 -- scope (yuk), and rename the method binds
 380            ASSERT( null sigs )
 381            bindLocalNames (map Var.varName tyvars) $
 382            do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds
 383               ; let binds' = VanillaInst rn_binds [] standalone_deriv
 384               ; return (inst_info { iBinds = binds' }, fvs) }
 385         where
 386           (tyvars,_, clas,_) = instanceHead inst
 387           clas_nm            = className clas
 388
 389 -----------------------------------------
 390 mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName)
 391 mkGenericBinds is_boot tycl_decls
 392   | is_boot
 393   = return emptyBag
 394   | otherwise
 395   = do  { tcs <- mapM tcLookupTyCon [ tcdName d
 396                                     | L _ d <- tycl_decls, isDataDecl d ]
 397         ; return (unionManyBags [ mkTyConGenericBinds tc
 398                                 | tc <- tcs, tyConHasGenerics tc ]) }
 399                 -- We are only interested in the data type declarations,
 400                 -- and then only in the ones whose 'has-generics' flag is on
 401                 -- The predicate tyConHasGenerics finds both of these
 402 \end{code}
 403
 404 Note [Newtype deriving and unused constructors]
 405 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 406 Consider this (see Trac #1954):
 407
 408   module Bug(P) where
 409   newtype P a = MkP (IO a) deriving Monad
 410
 411 If you compile with -fwarn-unused-binds you do not expect the warning
 412 "Defined but not used: data consructor MkP". Yet the newtype deriving
 413 code does not explicitly mention MkP, but it should behave as if you
 414 had written
 415   instance Monad P where
 416      return x = MkP (return x)
 417      ...etc...
 418
 419 So we want to signal a user of the data constructor 'MkP'.  That's
 420 what we do in rn_inst_info, and it's the only reason we have the TyCon
 421 stored in NewTypeDerived.
 422
 423
 424 %************************************************************************
 425 %*                                                                      *
 426                 From HsSyn to DerivSpec
 427 %*                                                                      *
 428 %************************************************************************
 429
 430 @makeDerivSpecs@ fishes around to find the info about needed derived instances.
 431
 432 \begin{code}
 433 makeDerivSpecs :: Bool
 434                -> [LTyClDecl Name]
 435                -> [LInstDecl Name]
 436                -> [LDerivDecl Name]
 437                -> TcM [EarlyDerivSpec]
 438
 439 makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 440   | is_boot     -- No 'deriving' at all in hs-boot files
 441   = do  { mapM_ add_deriv_err deriv_locs
 442         ; return [] }
 443   | otherwise
 444   = do  { eqns1 <- mapAndRecoverM deriveTyData all_tydata
 445         ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls
 446         ; return (eqns1 ++ eqns2) }
 447   where
 448     extractTyDataPreds decls
 449       = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds]
 450
 451     all_tydata :: [(LHsType Name, LTyClDecl Name)]
 452         -- Derived predicate paired with its data type declaration
 453     all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
 454
 455     deriv_locs = map (getLoc . snd) all_tydata
 456                  ++ map getLoc deriv_decls
 457
 458     add_deriv_err loc = setSrcSpan loc $
 459                         addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file"))
 460                                    2 (ptext (sLit "Use an instance declaration instead")))
 461
 462 ------------------------------------------------------------------
 463 deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec
 464 -- Standalone deriving declarations
 465 --  e.g.   deriving instance Show a => Show (T a)
 466 -- Rather like tcLocalInstDecl
 467 deriveStandalone (L loc (DerivDecl deriv_ty))
 468   = setSrcSpan loc                   $
 469     addErrCtxt (standaloneCtxt deriv_ty)  $
 470     do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
 471        ; (tvs, theta, cls, inst_tys) <- tcHsInstHead deriv_ty
 472        ; traceTc "Standalone deriving;" $ vcat
 473               [ text "tvs:" <+> ppr tvs
 474               , text "theta:" <+> ppr theta
 475               , text "cls:" <+> ppr cls
 476               , text "tys:" <+> ppr inst_tys ]
 477        ; checkValidInstance deriv_ty tvs theta cls inst_tys
 478                 -- C.f. TcInstDcls.tcLocalInstDecl1
 479
 480        ; let cls_tys = take (length inst_tys - 1) inst_tys
 481              inst_ty = last inst_tys
 482        ; traceTc "Standalone deriving:" $ vcat
 483               [ text "class:" <+> ppr cls
 484               , text "class types:" <+> ppr cls_tys
 485               , text "type:" <+> ppr inst_ty ]
 486        ; mkEqnHelp StandAloneDerivOrigin tvs cls cls_tys inst_ty
 487                    (Just theta) }
 488
 489 ------------------------------------------------------------------
 490 deriveTyData :: (LHsType Name, LTyClDecl Name) -> TcM EarlyDerivSpec
 491 deriveTyData (L loc deriv_pred, L _ decl@(TyData { tcdLName = L _ tycon_name,
 492                                                    tcdTyVars = tv_names,
 493                                                    tcdTyPats = ty_pats }))
 494   = setSrcSpan loc     $        -- Use the location of the 'deriving' item
 495     tcAddDeclCtxt decl $
 496     do  { (tvs, tc, tc_args) <- get_lhs ty_pats
 497         ; tcExtendTyVarEnv tvs $        -- Deriving preds may (now) mention
 498                                         -- the type variables for the type constructor
 499
 500     do  { (deriv_tvs, cls, cls_tys) <- tcHsDeriv deriv_pred
 501                 -- The "deriv_pred" is a LHsType to take account of the fact that for
 502                 -- newtype deriving we allow deriving (forall a. C [a]).
 503
 504         -- Given data T a b c = ... deriving( C d ),
 505         -- we want to drop type variables from T so that (C d (T a)) is well-kinded
 506         ; let cls_tyvars = classTyVars cls
 507               kind = tyVarKind (last cls_tyvars)
 508               (arg_kinds, _) = splitKindFunTys kind
 509               n_args_to_drop = length arg_kinds
 510               n_args_to_keep = tyConArity tc - n_args_to_drop
 511               args_to_drop   = drop n_args_to_keep tc_args
 512               inst_ty        = mkTyConApp tc (take n_args_to_keep tc_args)
 513               inst_ty_kind   = typeKind inst_ty
 514               dropped_tvs    = mkVarSet (mapCatMaybes getTyVar_maybe args_to_drop)
 515               univ_tvs       = (mkVarSet tvs `extendVarSetList` deriv_tvs)
 516                                         `minusVarSet` dropped_tvs
 517
 518         -- Check that the result really is well-kinded
 519         ; checkTc (n_args_to_keep >= 0 && (inst_ty_kind `eqKind` kind))
 520                   (derivingKindErr tc cls cls_tys kind)
 521
 522         ; checkTc (sizeVarSet dropped_tvs == n_args_to_drop &&           -- (a)
 523                    tyVarsOfTypes (inst_ty:cls_tys) `subVarSet` univ_tvs) -- (b)
 524                   (derivingEtaErr cls cls_tys inst_ty)
 525                 -- Check that
 526                 --  (a) The data type can be eta-reduced; eg reject:
 527                 --              data instance T a a = ... deriving( Monad )
 528                 --  (b) The type class args do not mention any of the dropped type
 529                 --      variables
 530                 --              newtype T a s = ... deriving( ST s )
 531
 532         -- Type families can't be partially applied
 533         -- e.g.   newtype instance T Int a = MkT [a] deriving( Monad )
 534         -- Note [Deriving, type families, and partial applications]
 535         ; checkTc (not (isFamilyTyCon tc) || n_args_to_drop == 0)
 536                   (typeFamilyPapErr tc cls cls_tys inst_ty)
 537
 538         ; mkEqnHelp DerivOrigin (varSetElems univ_tvs) cls cls_tys inst_ty Nothing } }
 539   where
 540         -- Tiresomely we must figure out the "lhs", which is awkward for type families
 541         -- E.g.   data T a b = .. deriving( Eq )
 542         --          Here, the lhs is (T a b)
 543         --        data instance TF Int b = ... deriving( Eq )
 544         --          Here, the lhs is (TF Int b)
 545         -- But if we just look up the tycon_name, we get is the *family*
 546         -- tycon, but not pattern types -- they are in the *rep* tycon.
 547     get_lhs Nothing     = do { tc <- tcLookupTyCon tycon_name
 548                              ; let tvs = tyConTyVars tc
 549                              ; return (tvs, tc, mkTyVarTys tvs) }
 550     get_lhs (Just pats) = do { let hs_app = nlHsTyConApp tycon_name pats
 551                              ; (tvs, tc_app) <- tcHsQuantifiedType tv_names hs_app
 552                              ; let (tc, tc_args) = tcSplitTyConApp tc_app
 553                              ; return (tvs, tc, tc_args) }
 554
 555 deriveTyData _other
 556   = panic "derivTyData" -- Caller ensures that only TyData can happen
 557 \end{code}
 558
 559 Note [Deriving, type families, and partial applications]
 560 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 561 When there are no type families, it's quite easy:
 562
 563     newtype S a = MkS [a]
 564     -- :CoS :: S  ~ []  -- Eta-reduced
 565
 566     instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)
 567     instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S
 568
 569 When type familes are involved it's trickier:
 570
 571     data family T a b
 572     newtype instance T Int a = MkT [a] deriving( Eq, Monad )
 573     -- :RT is the representation type for (T Int a)
 574     --  :CoF:R1T a :: T Int a ~ :RT a   -- Not eta reduced
 575     --  :Co:R1T    :: :RT ~ []          -- Eta-reduced
 576
 577     instance Eq [a] => Eq (T Int a)     -- easy by coercion
 578     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
 579
 580 The "???" bit is that we don't build the :CoF thing in eta-reduced form
 581 Henc the current typeFamilyPapErr, even though the instance makes sense.
 582 After all, we can write it out
 583     instance Monad [] => Monad (T Int)  -- only if we can eta reduce???
 584       return x = MkT [x]
 585       ... etc ...
 586
 587 \begin{code}
 588 mkEqnHelp :: CtOrigin -> [TyVar] -> Class -> [Type] -> Type
 589           -> DerivContext       -- Just    => context supplied (standalone deriving)
 590                                 -- Nothing => context inferred (deriving on data decl)
 591           -> TcRn EarlyDerivSpec
 592 -- Make the EarlyDerivSpec for an instance
 593 --      forall tvs. theta => cls (tys ++ [ty])
 594 -- where the 'theta' is optional (that's the Maybe part)
 595 -- Assumes that this declaration is well-kinded
 596
 597 mkEqnHelp orig tvs cls cls_tys tc_app mtheta
 598   | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app
 599   , isAlgTyCon tycon    -- Check for functions, primitive types etc
 600   = mk_alg_eqn tycon tc_args
 601   | otherwise
 602   = failWithTc (derivingThingErr False cls cls_tys tc_app
 603                (ptext (sLit "The last argument of the instance must be a data or newtype application")))
 604
 605   where
 606      bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg)
 607
 608      mk_alg_eqn tycon tc_args
 609       | className cls `elem` typeableClassNames
 610       = do { dflags <- getDOpts
 611            ; case checkTypeableConditions (dflags, tycon) of
 612                Just err -> bale_out err
 613                Nothing  -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta }
 614
 615       | isDataFamilyTyCon tycon
 616       , length tc_args /= tyConArity tycon
 617       = bale_out (ptext (sLit "Unsaturated data family application"))
 618
 619       | otherwise
 620       = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args
 621                   -- Be careful to test rep_tc here: in the case of families,
 622                   -- we want to check the instance tycon, not the family tycon
 623
 624            -- For standalone deriving (mtheta /= Nothing),
 625            -- check that all the data constructors are in scope.
 626            ; rdr_env <- getGlobalRdrEnv
 627            ; let hidden_data_cons = isAbstractTyCon rep_tc ||
 628                                     any not_in_scope (tyConDataCons rep_tc)
 629                  not_in_scope dc  = null (lookupGRE_Name rdr_env (dataConName dc))
 630            ; unless (isNothing mtheta || not hidden_data_cons)
 631                     (bale_out (derivingHiddenErr tycon))
 632
 633            ; dflags <- getDOpts
 634            ; if isDataTyCon rep_tc then
 635                 mkDataTypeEqn orig dflags tvs cls cls_tys
 636                               tycon tc_args rep_tc rep_tc_args mtheta
 637              else
 638                 mkNewTypeEqn orig dflags tvs cls cls_tys
 639                              tycon tc_args rep_tc rep_tc_args mtheta }
 640 \end{code}
 641
 642
 643 %************************************************************************
 644 %*                                                                      *
 645                 Deriving data types
 646 %*                                                                      *
 647 %************************************************************************
 648
 649 \begin{code}
 650 mkDataTypeEqn :: CtOrigin
 651               -> DynFlags
 652               -> [Var]                  -- Universally quantified type variables in the instance
 653               -> Class                  -- Class for which we need to derive an instance
 654               -> [Type]                 -- Other parameters to the class except the last
 655               -> TyCon                  -- Type constructor for which the instance is requested
 656                                         --    (last parameter to the type class)
 657               -> [Type]                 -- Parameters to the type constructor
 658               -> TyCon                  -- rep of the above (for type families)
 659               -> [Type]                 -- rep of the above
 660               -> DerivContext        -- Context of the instance, for standalone deriving
 661               -> TcRn EarlyDerivSpec    -- Return 'Nothing' if error
 662
 663 mkDataTypeEqn orig dflags tvs cls cls_tys
 664               tycon tc_args rep_tc rep_tc_args mtheta
 665   = case checkSideConditions dflags mtheta cls cls_tys rep_tc of
 666         -- NB: pass the *representation* tycon to checkSideConditions
 667         CanDerive               -> go_for_it
 668         NonDerivableClass       -> bale_out (nonStdErr cls)
 669         DerivableClassError msg -> bale_out msg
 670   where
 671     go_for_it    = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 672     bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg)
 673
 674 mk_data_eqn :: CtOrigin -> [TyVar] -> Class
 675             -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext
 676             -> TcM EarlyDerivSpec
 677 mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta
 678   = do  { dfun_name <- new_dfun_name cls tycon
 679         ; loc <- getSrcSpanM
 680         ; let inst_tys = [mkTyConApp tycon tc_args]
 681               inferred_constraints = inferConstraints tvs cls inst_tys rep_tc rep_tc_args
 682               spec = DS { ds_loc = loc, ds_orig = orig
 683                         , ds_name = dfun_name, ds_tvs = tvs
 684                         , ds_cls = cls, ds_tys = inst_tys
 685                         , ds_tc = rep_tc, ds_tc_args = rep_tc_args
 686                         , ds_theta =  mtheta `orElse` inferred_constraints
 687                         , ds_newtype = False }
 688
 689         ; return (if isJust mtheta then Right spec      -- Specified context
 690                                    else Left spec) }    -- Infer context
 691
 692 ----------------------
 693 mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class
 694                 -> TyCon -> [TcType] -> DerivContext
 695                 -> TcM EarlyDerivSpec
 696 mk_typeable_eqn orig tvs cls tycon tc_args mtheta
 697         -- The Typeable class is special in several ways
 698         --        data T a b = ... deriving( Typeable )
 699         -- gives
 700         --        instance Typeable2 T where ...
 701         -- Notice that:
 702         -- 1. There are no constraints in the instance
 703         -- 2. There are no type variables either
 704         -- 3. The actual class we want to generate isn't necessarily
 705         --      Typeable; it depends on the arity of the type
 706   | isNothing mtheta    -- deriving on a data type decl
 707   = do  { checkTc (cls `hasKey` typeableClassKey)
 708                   (ptext (sLit "Use deriving( Typeable ) on a data type declaration"))
 709         ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon)
 710         ; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) }
 711
 712   | otherwise           -- standaone deriving
 713   = do  { checkTc (null tc_args)
 714                   (ptext (sLit "Derived typeable instance must be of form (Typeable")
 715                         <> int (tyConArity tycon) <+> ppr tycon <> rparen)
 716         ; dfun_name <- new_dfun_name cls tycon
 717         ; loc <- getSrcSpanM
 718         ; return (Right $
 719                   DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = []
 720                      , ds_cls = cls, ds_tys = [mkTyConApp tycon []]
 721                      , ds_tc = tycon, ds_tc_args = []
 722                      , ds_theta = mtheta `orElse` [], ds_newtype = False })  }
 723
 724 ----------------------
 725 inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType
 726 -- Generate a sufficiently large set of constraints that typechecking the
 727 -- generated method definitions should succeed.   This set will be simplified
 728 -- before being used in the instance declaration
 729 inferConstraints _ cls inst_tys rep_tc rep_tc_args
 730   = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc )
 731     stupid_constraints ++ extra_constraints
 732     ++ sc_constraints ++ con_arg_constraints
 733   where
 734        -- Constraints arising from the arguments of each constructor
 735     con_arg_constraints
 736       = [ mkClassPred cls [arg_ty]
 737         | data_con <- tyConDataCons rep_tc,
 738           arg_ty   <- ASSERT( isVanillaDataCon data_con )
 739                         get_constrained_tys $
 740                         dataConInstOrigArgTys data_con all_rep_tc_args,
 741           not (isUnLiftedType arg_ty) ]
 742                 -- No constraints for unlifted types
 743                 -- Where they are legal we generate specilised function calls
 744
 745                 -- For functor-like classes, two things are different
 746                 -- (a) We recurse over argument types to generate constraints
 747                 --     See Functor examples in TcGenDeriv
 748                 -- (b) The rep_tc_args will be one short
 749     is_functor_like = getUnique cls `elem` functorLikeClassKeys
 750
 751     get_constrained_tys :: [Type] -> [Type]
 752     get_constrained_tys tys
 753         | is_functor_like = concatMap (deepSubtypesContaining last_tv) tys
 754         | otherwise       = tys
 755
 756     rep_tc_tvs = tyConTyVars rep_tc
 757     last_tv = last rep_tc_tvs
 758     all_rep_tc_args | is_functor_like = rep_tc_args ++ [mkTyVarTy last_tv]
 759                     | otherwise       = rep_tc_args
 760
 761         -- Constraints arising from superclasses
 762         -- See Note [Superclasses of derived instance]
 763     sc_constraints = substTheta (zipOpenTvSubst (classTyVars cls) inst_tys)
 764                                 (classSCTheta cls)
 765
 766         -- Stupid constraints
 767     stupid_constraints = substTheta subst (tyConStupidTheta rep_tc)
 768     subst = zipTopTvSubst rep_tc_tvs all_rep_tc_args
 769
 770         -- Extra Data constraints
 771         -- The Data class (only) requires that for
 772         --    instance (...) => Data (T t1 t2)
 773         -- IF   t1:*, t2:*
 774         -- THEN (Data t1, Data t2) are among the (...) constraints
 775         -- Reason: when the IF holds, we generate a method
 776         --             dataCast2 f = gcast2 f
 777         --         and we need the Data constraints to typecheck the method
 778     extra_constraints
 779       | cls `hasKey` dataClassKey
 780       , all (isLiftedTypeKind . typeKind) rep_tc_args
 781       = [mkClassPred cls [ty] | ty <- rep_tc_args]
 782       | otherwise
 783       = []
 784
 785 ------------------------------------------------------------------
 786 -- Check side conditions that dis-allow derivability for particular classes
 787 -- This is *apart* from the newtype-deriving mechanism
 788 --
 789 -- Here we get the representation tycon in case of family instances as it has
 790 -- the data constructors - but we need to be careful to fall back to the
 791 -- family tycon (with indexes) in error messages.
 792
 793 data DerivStatus = CanDerive
 794                  | DerivableClassError SDoc     -- Standard class, but can't do it
 795                  | NonDerivableClass            -- Non-standard class
 796
 797 checkSideConditions :: DynFlags -> DerivContext -> Class -> [TcType] -> TyCon -> DerivStatus
 798 checkSideConditions dflags mtheta cls cls_tys rep_tc
 799   | Just cond <- sideConditions mtheta cls
 800   = case (cond (dflags, rep_tc)) of
 801         Just err -> DerivableClassError err     -- Class-specific error
 802         Nothing  | null cls_tys -> CanDerive    -- All derivable classes are unary, so
 803                                                 -- cls_tys (the type args other than last)
 804                                                 -- should be null
 805                  | otherwise    -> DerivableClassError ty_args_why      -- e.g. deriving( Eq s )
 806   | otherwise = NonDerivableClass       -- Not a standard class
 807   where
 808     ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class")
 809
 810 checkTypeableConditions :: Condition
 811 checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK
 812
 813 nonStdErr :: Class -> SDoc
 814 nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class")
 815
 816 sideConditions :: DerivContext -> Class -> Maybe Condition
 817 sideConditions mtheta cls
 818   | cls_key == eqClassKey          = Just cond_std
 819   | cls_key == ordClassKey         = Just cond_std
 820   | cls_key == showClassKey        = Just cond_std
 821   | cls_key == readClassKey        = Just (cond_std `andCond` cond_noUnliftedArgs)
 822   | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)
 823   | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct)
 824   | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct)
 825   | cls_key == dataClassKey        = Just (checkFlag Opt_DeriveDataTypeable `andCond`
 826                                            cond_std `andCond` cond_noUnliftedArgs)
 827   | cls_key == functorClassKey     = Just (checkFlag Opt_DeriveFunctor `andCond`
 828                                            cond_functorOK True)  -- NB: no cond_std!
 829   | cls_key == foldableClassKey    = Just (checkFlag Opt_DeriveFoldable `andCond`
 830                                            cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types
 831   | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond`
 832                                            cond_functorOK False)
 833   | otherwise = Nothing
 834   where
 835     cls_key = getUnique cls
 836     cond_std = cond_stdOK mtheta
 837
 838 type Condition = (DynFlags, TyCon) -> Maybe SDoc
 839         -- first Bool is whether or not we are allowed to derive Data and Typeable
 840         -- second Bool is whether or not we are allowed to derive Functor
 841         -- TyCon is the *representation* tycon if the
 842         --      data type is an indexed one
 843         -- Nothing => OK
 844
 845 orCond :: Condition -> Condition -> Condition
 846 orCond c1 c2 tc
 847   = case c1 tc of
 848         Nothing -> Nothing          -- c1 succeeds
 849         Just x  -> case c2 tc of    -- c1 fails
 850                      Nothing -> Nothing
 851                      Just y  -> Just (x $$ ptext (sLit "  and") $$ y)
 852                                     -- Both fail
 853
 854 andCond :: Condition -> Condition -> Condition
 855 andCond c1 c2 tc = case c1 tc of
 856                      Nothing -> c2 tc   -- c1 succeeds
 857                      Just x  -> Just x  -- c1 fails
 858
 859 cond_stdOK :: DerivContext -> Condition
 860 cond_stdOK (Just _) _
 861   = Nothing     -- Don't check these conservative conditions for
 862                 -- standalone deriving; just generate the code
 863                 -- and let the typechecker handle the result
 864 cond_stdOK Nothing (_, rep_tc)
 865   | null data_cons      = Just (no_cons_why rep_tc $$ suggestion)
 866   | not (null con_whys) = Just (vcat con_whys $$ suggestion)
 867   | otherwise           = Nothing
 868   where
 869     suggestion  = ptext (sLit "Possible fix: use a standalone deriving declaration instead")
 870     data_cons   = tyConDataCons rep_tc
 871     con_whys = mapCatMaybes check_con data_cons
 872
 873     check_con :: DataCon -> Maybe SDoc
 874     check_con con
 875       | isVanillaDataCon con
 876       , all isTauTy (dataConOrigArgTys con) = Nothing
 877       | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type")))
 878
 879 no_cons_why :: TyCon -> SDoc
 880 no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>
 881                      ptext (sLit "has no data constructors")
 882
 883 cond_enumOrProduct :: Condition
 884 cond_enumOrProduct = cond_isEnumeration `orCond`
 885                        (cond_isProduct `andCond` cond_noUnliftedArgs)
 886
 887 cond_noUnliftedArgs :: Condition
 888 -- For some classes (eg Eq, Ord) we allow unlifted arg types
 889 -- by generating specilaised code.  For others (eg Data) we don't.
 890 cond_noUnliftedArgs (_, tc)
 891   | null bad_cons = Nothing
 892   | otherwise     = Just why
 893   where
 894     bad_cons = [ con | con <- tyConDataCons tc
 895                      , any isUnLiftedType (dataConOrigArgTys con) ]
 896     why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type"))
 897
 898 cond_isEnumeration :: Condition
 899 cond_isEnumeration (_, rep_tc)
 900   | isEnumerationTyCon rep_tc   = Nothing
 901   | otherwise                   = Just why
 902   where
 903     why = sep [ quotes (pprSourceTyCon rep_tc) <+>
 904                   ptext (sLit "is not an enumeration type")
 905               , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
 906                   -- See Note [Enumeration types] in TyCon
 907
 908 cond_isProduct :: Condition
 909 cond_isProduct (_, rep_tc)
 910   | isProductTyCon rep_tc = Nothing
 911   | otherwise             = Just why
 912   where
 913     why = quotes (pprSourceTyCon rep_tc) <+>
 914           ptext (sLit "does not have precisely one constructor")
 915
 916 cond_typeableOK :: Condition
 917 -- OK for Typeable class
 918 -- Currently: (a) args all of kind *
 919 --            (b) 7 or fewer args
 920 cond_typeableOK (_, tc)
 921   | tyConArity tc > 7 = Just too_many
 922   | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc))
 923                       = Just bad_kind
 924   | otherwise         = Nothing
 925   where
 926     too_many = quotes (pprSourceTyCon tc) <+>
 927                ptext (sLit "has too many arguments")
 928     bad_kind = quotes (pprSourceTyCon tc) <+>
 929                ptext (sLit "has arguments of kind other than `*'")
 930
 931 functorLikeClassKeys :: [Unique]
 932 functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey]
 933
 934 cond_functorOK :: Bool -> Condition
 935 -- OK for Functor/Foldable/Traversable class
 936 -- Currently: (a) at least one argument
 937 --            (b) don't use argument contravariantly
 938 --            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)
 939 --            (d) optionally: don't use function types
 940 --            (e) no "stupid context" on data type
 941 cond_functorOK allowFunctions (_, rep_tc)
 942   | null tc_tvs
 943   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
 944           <+> ptext (sLit "has no parameters"))
 945
 946   | not (null bad_stupid_theta)
 947   = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc)
 948           <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta)
 949
 950   | otherwise
 951   = msum (map check_con data_cons)      -- msum picks the first 'Just', if any
 952   where
 953     tc_tvs            = tyConTyVars rep_tc
 954     Just (_, last_tv) = snocView tc_tvs
 955     bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)
 956     is_bad pred       = last_tv `elemVarSet` tyVarsOfPred pred
 957
 958     data_cons = tyConDataCons rep_tc
 959     check_con con = msum (check_vanilla con : foldDataConArgs (ft_check con) con)
 960
 961     check_vanilla :: DataCon -> Maybe SDoc
 962     check_vanilla con | isVanillaDataCon con = Nothing
 963                       | otherwise            = Just (badCon con existential)
 964
 965     ft_check :: DataCon -> FFoldType (Maybe SDoc)
 966     ft_check con = FT { ft_triv = Nothing, ft_var = Nothing
 967                       , ft_co_var = Just (badCon con covariant)
 968                       , ft_fun = \x y -> if allowFunctions then x `mplus` y
 969                                                            else Just (badCon con functions)
 970                       , ft_tup = \_ xs  -> msum xs
 971                       , ft_ty_app = \_ x   -> x
 972                       , ft_bad_app = Just (badCon con wrong_arg)
 973                       , ft_forall = \_ x   -> x }
 974
 975     existential = ptext (sLit "has existential arguments")
 976     covariant   = ptext (sLit "uses the type variable in a function argument")
 977     functions   = ptext (sLit "contains function types")
 978     wrong_arg   = ptext (sLit "uses the type variable in an argument other than the last")
 979
 980 checkFlag :: ExtensionFlag -> Condition
 981 checkFlag flag (dflags, _)
 982   | xopt flag dflags = Nothing
 983   | otherwise        = Just why
 984   where
 985     why = ptext (sLit "You need -X") <> text flag_str
 986           <+> ptext (sLit "to derive an instance for this class")
 987     flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of
 988                  [s]   -> s
 989                  other -> pprPanic "checkFlag" (ppr other)
 990
 991 std_class_via_iso :: Class -> Bool
 992 -- These standard classes can be derived for a newtype
 993 -- using the isomorphism trick *even if no -XGeneralizedNewtypeDeriving
 994 -- because giving so gives the same results as generating the boilerplate
 995 std_class_via_iso clas
 996   = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]
 997         -- Not Read/Show because they respect the type
 998         -- Not Enum, because newtypes are never in Enum
 999
1000
1001 non_iso_class :: Class -> Bool
1002 -- *Never* derive Read,Show,Typeable,Data by isomorphism,
1003 -- even with -XGeneralizedNewtypeDeriving
1004 non_iso_class cls
1005   = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++
1006                          typeableClassKeys)
1007
1008 typeableClassKeys :: [Unique]
1009 typeableClassKeys = map getUnique typeableClassNames
1010
1011 new_dfun_name :: Class -> TyCon -> TcM Name
1012 new_dfun_name clas tycon        -- Just a simple wrapper
1013   = do { loc <- getSrcSpanM     -- The location of the instance decl, not of the tycon
1014         ; newDFunName clas [mkTyConApp tycon []] loc }
1015         -- The type passed to newDFunName is only used to generate
1016         -- a suitable string; hence the empty type arg list
1017
1018 badCon :: DataCon -> SDoc -> SDoc
1019 badCon con msg = ptext (sLit "Constructor") <+> quotes (ppr con) <+> msg
1020 \end{code}
1021
1022 Note [Superclasses of derived instance]
1023 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1024 In general, a derived instance decl needs the superclasses of the derived
1025 class too.  So if we have
1026         data T a = ...deriving( Ord )
1027 then the initial context for Ord (T a) should include Eq (T a).  Often this is
1028 redundant; we'll also generate an Ord constraint for each constructor argument,
1029 and that will probably generate enough constraints to make the Eq (T a) constraint
1030 be satisfied too.  But not always; consider:
1031
1032  data S a = S
1033  instance Eq (S a)
1034  instance Ord (S a)
1035
1036  data T a = MkT (S a) deriving( Ord )
1037  instance Num a => Eq (T a)
1038
1039 The derived instance for (Ord (T a)) must have a (Num a) constraint!
1040 Similarly consider:
1041         data T a = MkT deriving( Data, Typeable )
1042 Here there *is* no argument field, but we must nevertheless generate
1043 a context for the Data instances:
1044         instance Typable a => Data (T a) where ...
1045
1046
1047 %************************************************************************
1048 %*                                                                      *
1049                 Deriving newtypes
1050 %*                                                                      *
1051 %************************************************************************
1052
1053 \begin{code}
1054 mkNewTypeEqn :: CtOrigin -> DynFlags -> [Var] -> Class
1055              -> [Type] -> TyCon -> [Type] -> TyCon -> [Type]
1056              -> DerivContext
1057              -> TcRn EarlyDerivSpec
1058 mkNewTypeEqn orig dflags tvs
1059              cls cls_tys tycon tc_args rep_tycon rep_tc_args mtheta
1060 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
1061   | can_derive_via_isomorphism && (newtype_deriving || std_class_via_iso cls)
1062   = do  { traceTc "newtype deriving:" (ppr tycon <+> ppr rep_tys <+> ppr all_preds)
1063         ; dfun_name <- new_dfun_name cls tycon
1064         ; loc <- getSrcSpanM
1065         ; let spec = DS { ds_loc = loc, ds_orig = orig
1066                         , ds_name = dfun_name, ds_tvs = varSetElems dfun_tvs
1067                         , ds_cls = cls, ds_tys = inst_tys
1068                         , ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1069                         , ds_theta =  mtheta `orElse` all_preds
1070                         , ds_newtype = True }
1071         ; return (if isJust mtheta then Right spec
1072                                    else Left spec) }
1073
1074   | otherwise
1075   = case checkSideConditions dflags mtheta cls cls_tys rep_tycon of
1076       CanDerive -> go_for_it    -- Use the standard H98 method
1077       DerivableClassError msg   -- Error with standard class
1078         | can_derive_via_isomorphism -> bale_out (msg $$ suggest_nd)
1079         | otherwise                  -> bale_out msg
1080       NonDerivableClass         -- Must use newtype deriving
1081         | newtype_deriving           -> bale_out cant_derive_err  -- Too hard, even with newtype deriving
1082         | can_derive_via_isomorphism -> bale_out (non_std $$ suggest_nd) -- Try newtype deriving!
1083         | otherwise                  -> bale_out non_std
1084   where
1085         newtype_deriving = xopt Opt_GeneralizedNewtypeDeriving dflags
1086         go_for_it        = mk_data_eqn orig tvs cls tycon tc_args rep_tycon rep_tc_args mtheta
1087         bale_out msg     = failWithTc (derivingThingErr newtype_deriving cls cls_tys inst_ty msg)
1088
1089         non_std    = nonStdErr cls
1090         suggest_nd = ptext (sLit "Try -XGeneralizedNewtypeDeriving for GHC's newtype-deriving extension")
1091
1092         -- Here is the plan for newtype derivings.  We see
1093         --        newtype T a1...an = MkT (t ak+1...an) deriving (.., C s1 .. sm, ...)
1094         -- where t is a type,
1095         --       ak+1...an is a suffix of a1..an, and are all tyars
1096         --       ak+1...an do not occur free in t, nor in the s1..sm
1097         --       (C s1 ... sm) is a  *partial applications* of class C
1098         --                      with the last parameter missing
1099         --       (T a1 .. ak) matches the kind of C's last argument
1100         --              (and hence so does t)
1101         -- The latter kind-check has been done by deriveTyData already,
1102         -- and tc_args are already trimmed
1103         --
1104         -- We generate the instance
1105         --       instance forall ({a1..ak} u fvs(s1..sm)).
1106         --                C s1 .. sm t => C s1 .. sm (T a1...ak)
1107         -- where T a1...ap is the partial application of
1108         --       the LHS of the correct kind and p >= k
1109         --
1110         --      NB: the variables below are:
1111         --              tc_tvs = [a1, ..., an]
1112         --              tyvars_to_keep = [a1, ..., ak]
1113         --              rep_ty = t ak .. an
1114         --              deriv_tvs = fvs(s1..sm) \ tc_tvs
1115         --              tys = [s1, ..., sm]
1116         --              rep_fn' = t
1117         --
1118         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
1119         -- We generate the instance
1120         --      instance Monad (ST s) => Monad (T s) where
1121
1122         nt_eta_arity = length (fst (newTyConEtadRhs rep_tycon))
1123                 -- For newtype T a b = MkT (S a a b), the TyCon machinery already
1124                 -- eta-reduces the representation type, so we know that
1125                 --      T a ~ S a a
1126                 -- That's convenient here, because we may have to apply
1127                 -- it to fewer than its original complement of arguments
1128
1129         -- Note [Newtype representation]
1130         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1131         -- Need newTyConRhs (*not* a recursive representation finder)
1132         -- to get the representation type. For example
1133         --      newtype B = MkB Int
1134         --      newtype A = MkA B deriving( Num )
1135         -- We want the Num instance of B, *not* the Num instance of Int,
1136         -- when making the Num instance of A!
1137         rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args
1138         rep_tys     = cls_tys ++ [rep_inst_ty]
1139         rep_pred    = mkClassPred cls rep_tys
1140                 -- rep_pred is the representation dictionary, from where
1141                 -- we are gong to get all the methods for the newtype
1142                 -- dictionary
1143
1144
1145     -- Next we figure out what superclass dictionaries to use
1146     -- See Note [Newtype deriving superclasses] above
1147
1148         cls_tyvars = classTyVars cls
1149         dfun_tvs = tyVarsOfTypes inst_tys
1150         inst_ty = mkTyConApp tycon tc_args
1151         inst_tys = cls_tys ++ [inst_ty]
1152         sc_theta = substTheta (zipOpenTvSubst cls_tyvars inst_tys)
1153                               (classSCTheta cls)
1154
1155                 -- If there are no tyvars, there's no need
1156                 -- to abstract over the dictionaries we need
1157                 -- Example:     newtype T = MkT Int deriving( C )
1158                 -- We get the derived instance
1159                 --              instance C T
1160                 -- rather than
1161                 --              instance C Int => C T
1162         all_preds = rep_pred : sc_theta         -- NB: rep_pred comes first
1163
1164         -------------------------------------------------------------------
1165         --  Figuring out whether we can only do this newtype-deriving thing
1166
1167         can_derive_via_isomorphism
1168            =  not (non_iso_class cls)
1169            && arity_ok
1170            && eta_ok
1171            && ats_ok
1172 --         && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]
1173
1174         arity_ok = length cls_tys + 1 == classArity cls
1175                 -- Well kinded; eg not: newtype T ... deriving( ST )
1176                 --                      because ST needs *2* type params
1177
1178         -- Check that eta reduction is OK
1179         eta_ok = nt_eta_arity <= length rep_tc_args
1180                 -- The newtype can be eta-reduced to match the number
1181                 --     of type argument actually supplied
1182                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
1183                 --     Here the 'b' must be the same in the rep type (S [a] b)
1184                 --     And the [a] must not mention 'b'.  That's all handled
1185                 --     by nt_eta_rity.
1186
1187         ats_ok = null (classATs cls)
1188                -- No associated types for the class, because we don't
1189                -- currently generate type 'instance' decls; and cannot do
1190                -- so for 'data' instance decls
1191
1192         cant_derive_err
1193            = vcat [ ppUnless arity_ok arity_msg
1194                   , ppUnless eta_ok eta_msg
1195                   , ppUnless ats_ok ats_msg ]
1196         arity_msg = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "does not have arity 1")
1197         eta_msg   = ptext (sLit "cannot eta-reduce the representation type enough")
1198         ats_msg   = ptext (sLit "the class has associated types")
1199 \end{code}
1200
1201 Note [Recursive newtypes]
1202 ~~~~~~~~~~~~~~~~~~~~~~~~~
1203 Newtype deriving works fine, even if the newtype is recursive.
1204 e.g.    newtype S1 = S1 [T1 ()]
1205         newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )
1206 Remember, too, that type families are curretly (conservatively) given
1207 a recursive flag, so this also allows newtype deriving to work
1208 for type famillies.
1209
1210 We used to exclude recursive types, because we had a rather simple
1211 minded way of generating the instance decl:
1212    newtype A = MkA [A]
1213    instance Eq [A] => Eq A      -- Makes typechecker loop!
1214 But now we require a simple context, so it's ok.
1215
1216
1217 %************************************************************************
1218 %*                                                                      *
1219 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
1220 %*                                                                      *
1221 %************************************************************************
1222
1223 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
1224 terms, which is the final correct RHS for the corresponding original
1225 equation.
1226 \begin{itemize}
1227 \item
1228 Each (k,TyVarTy tv) in a solution constrains only a type
1229 variable, tv.
1230
1231 \item
1232 The (k,TyVarTy tv) pairs in a solution are canonically
1233 ordered by sorting on type varible, tv, (major key) and then class, k,
1234 (minor key)
1235 \end{itemize}
1236
1237 \begin{code}
1238 inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec]
1239
1240 inferInstanceContexts _ [] = return []
1241
1242 inferInstanceContexts oflag infer_specs
1243   = do  { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs)
1244         ; iterate_deriv 1 initial_solutions }
1245   where
1246     ------------------------------------------------------------------
1247         -- The initial solutions for the equations claim that each
1248         -- instance has an empty context; this solution is certainly
1249         -- in canonical form.
1250     initial_solutions :: [ThetaType]
1251     initial_solutions = [ [] | _ <- infer_specs ]
1252
1253     ------------------------------------------------------------------
1254         -- iterate_deriv calculates the next batch of solutions,
1255         -- compares it with the current one; finishes if they are the
1256         -- same, otherwise recurses with the new solutions.
1257         -- It fails if any iteration fails
1258     iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec]
1259     iterate_deriv n current_solns
1260       | n > 20  -- Looks as if we are in an infinite loop
1261                 -- This can happen if we have -XUndecidableInstances
1262                 -- (See TcSimplify.tcSimplifyDeriv.)
1263       = pprPanic "solveDerivEqns: probable loop"
1264                  (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)
1265       | otherwise
1266       = do {      -- Extend the inst info from the explicit instance decls
1267                   -- with the current set of solutions, and simplify each RHS
1268              let inst_specs = zipWithEqual "add_solns" (mkInstance oflag)
1269                                            current_solns infer_specs
1270            ; new_solns <- checkNoErrs $
1271                           extendLocalInstEnv inst_specs $
1272                           mapM gen_soln infer_specs
1273
1274            ; if (current_solns == new_solns) then
1275                 return [ spec { ds_theta = soln }
1276                        | (spec, soln) <- zip infer_specs current_solns ]
1277              else
1278                 iterate_deriv (n+1) new_solns }
1279
1280     ------------------------------------------------------------------
1281     gen_soln :: DerivSpec  -> TcM [PredType]
1282     gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars
1283                  , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })
1284       = setSrcSpan loc  $
1285         addErrCtxt (derivInstCtxt the_pred) $
1286         do {      -- Check for a bizarre corner case, when the derived instance decl should
1287                   -- have form  instance C a b => D (T a) where ...
1288                   -- Note that 'b' isn't a parameter of T.  This gives rise to all sorts
1289                   -- of problems; in particular, it's hard to compare solutions for
1290                   -- equality when finding the fixpoint.  Moreover, simplifyDeriv
1291                   -- has an assert failure because it finds a TyVar when it expects
1292                   -- only TcTyVars.  So I just rule it out for now.  I'm not
1293                   -- even sure how it can arise.
1294
1295            ; let tv_set = mkVarSet tyvars
1296                  weird_preds = [pred | pred <- deriv_rhs
1297                                      , not (tyVarsOfPred pred `subVarSet` tv_set)]
1298            ; mapM_ (addErrTc . badDerivedPred) weird_preds
1299
1300            ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs
1301                 -- checkValidInstance tyvars theta clas inst_tys
1302                 -- Not necessary; see Note [Exotic derived instance contexts]
1303                 --                in TcSimplify
1304
1305            ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)
1306                 -- Claim: the result instance declaration is guaranteed valid
1307                 -- Hence no need to call:
1308                 --   checkValidInstance tyvars theta clas inst_tys
1309            ; return (sortLe (<=) theta) }       -- Canonicalise before returning the solution
1310       where
1311         the_pred = mkClassPred clas inst_tys
1312
1313 ------------------------------------------------------------------
1314 mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance
1315 mkInstance overlap_flag theta
1316             (DS { ds_name = dfun_name
1317                 , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys })
1318   = mkLocalInstance dfun overlap_flag
1319   where
1320     dfun = mkDictFunId dfun_name tyvars theta clas tys
1321
1322
1323 extendLocalInstEnv :: [Instance] -> TcM a -> TcM a
1324 -- Add new locally-defined instances; don't bother to check
1325 -- for functional dependency errors -- that'll happen in TcInstDcls
1326 extendLocalInstEnv dfuns thing_inside
1327  = do { env <- getGblEnv
1328       ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns
1329              env'      = env { tcg_inst_env = inst_env' }
1330       ; setGblEnv env' thing_inside }
1331 \end{code}
1332
1333
1334 %************************************************************************
1335 %*                                                                      *
1336 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
1337 %*                                                                      *
1338 %************************************************************************
1339
1340 After all the trouble to figure out the required context for the
1341 derived instance declarations, all that's left is to chug along to
1342 produce them.  They will then be shoved into @tcInstDecls2@, which
1343 will do all its usual business.
1344
1345 There are lots of possibilities for code to generate.  Here are
1346 various general remarks.
1347
1348 PRINCIPLES:
1349 \begin{itemize}
1350 \item
1351 We want derived instances of @Eq@ and @Ord@ (both v common) to be
1352 ``you-couldn't-do-better-by-hand'' efficient.
1353
1354 \item
1355 Deriving @Show@---also pretty common--- should also be reasonable good code.
1356
1357 \item
1358 Deriving for the other classes isn't that common or that big a deal.
1359 \end{itemize}
1360
1361 PRAGMATICS:
1362
1363 \begin{itemize}
1364 \item
1365 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
1366
1367 \item
1368 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
1369
1370 \item
1371 We {\em normally} generate code only for the non-defaulted methods;
1372 there are some exceptions for @Eq@ and (especially) @Ord@...
1373
1374 \item
1375 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
1376 constructor's numeric (@Int#@) tag.  These are generated by
1377 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
1378 these is around is given by @hasCon2TagFun@.
1379
1380 The examples under the different sections below will make this
1381 clearer.
1382
1383 \item
1384 Much less often (really just for deriving @Ix@), we use a
1385 @_tag2con_<tycon>@ function.  See the examples.
1386
1387 \item
1388 We use the renamer!!!  Reason: we're supposed to be
1389 producing @LHsBinds Name@ for the methods, but that means
1390 producing correctly-uniquified code on the fly.  This is entirely
1391 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
1392 So, instead, we produce @MonoBinds RdrName@ then heave 'em through
1393 the renamer.  What a great hack!
1394 \end{itemize}
1395
1396 \begin{code}
1397 -- Generate the InstInfo for the required instance paired with the
1398 --   *representation* tycon for that instance,
1399 -- plus any auxiliary bindings required
1400 --
1401 -- Representation tycons differ from the tycon in the instance signature in
1402 -- case of instances for indexed families.
1403 --
1404 genInst :: Bool         -- True <=> standalone deriving
1405         -> OverlapFlag
1406         -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds)
1407 genInst standalone_deriv oflag
1408         spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args
1409                  , ds_theta = theta, ds_newtype = is_newtype
1410                  , ds_name = name, ds_cls = clas })
1411   | is_newtype
1412   = return (InstInfo { iSpec   = inst_spec
1413                      , iBinds  = NewTypeDerived co rep_tycon }, [])
1414
1415   | otherwise
1416   = do  { fix_env <- getFixityEnv
1417         ; let loc   = getSrcSpan name
1418               (meth_binds, aux_binds) = genDerivBinds loc fix_env clas rep_tycon
1419                    -- In case of a family instance, we need to use the representation
1420                    -- tycon (after all, it has the data constructors)
1421
1422         ; return (InstInfo { iSpec   = inst_spec
1423                            , iBinds  = VanillaInst meth_binds [] standalone_deriv }
1424                  , aux_binds) }
1425   where
1426     inst_spec = mkInstance oflag theta spec
1427     co1 = case tyConFamilyCoercion_maybe rep_tycon of
1428               Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1429               Nothing     -> id_co
1430               -- Not a family => rep_tycon = main tycon
1431     co2 = case newTyConCo_maybe rep_tycon of
1432               Just co_con -> ACo (mkTyConApp co_con rep_tc_args)
1433               Nothing     -> id_co  -- The newtype is transparent; no need for a cast
1434     co = co1 `mkTransCoI` co2
1435     id_co = IdCo (mkTyConApp rep_tycon rep_tc_args)
1436
1437 -- Example: newtype instance N [a] = N1 (Tree a)
1438 --          deriving instance Eq b => Eq (N [(b,b)])
1439 -- From the instance, we get an implicit newtype R1:N a = N1 (Tree a)
1440 -- When dealing with the deriving clause
1441 --    co1 : N [(b,b)] ~ R1:N (b,b)
1442 --    co2 : R1:N (b,b) ~ Tree (b,b)
1443 --    co  : N [(b,b)] ~ Tree (b,b)
1444
1445 genDerivBinds :: SrcSpan -> FixityEnv -> Class -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1446 genDerivBinds loc fix_env clas tycon
1447   | className clas `elem` typeableClassNames
1448   = (gen_Typeable_binds loc tycon, [])
1449
1450   | otherwise
1451   = case assocMaybe gen_list (getUnique clas) of
1452         Just gen_fn -> gen_fn loc tycon
1453         Nothing     -> pprPanic "genDerivBinds: bad derived class" (ppr clas)
1454   where
1455     gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))]
1456     gen_list = [(eqClassKey,       gen_Eq_binds)
1457                ,(ordClassKey,      gen_Ord_binds)
1458                ,(enumClassKey,     gen_Enum_binds)
1459                ,(boundedClassKey,  gen_Bounded_binds)
1460                ,(ixClassKey,       gen_Ix_binds)
1461                ,(showClassKey,     gen_Show_binds fix_env)
1462                ,(readClassKey,     gen_Read_binds fix_env)
1463                ,(dataClassKey,     gen_Data_binds)
1464                ,(functorClassKey,  gen_Functor_binds)
1465                ,(foldableClassKey, gen_Foldable_binds)
1466                ,(traversableClassKey, gen_Traversable_binds)
1467                ]
1468 \end{code}
1469
1470
1471 %************************************************************************
1472 %*                                                                      *
1473 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
1474 %*                                                                      *
1475 %************************************************************************
1476
1477 \begin{code}
1478 derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Message
1479 derivingKindErr tc cls cls_tys cls_kind
1480   = hang (ptext (sLit "Cannot derive well-kinded instance of form")
1481                 <+> quotes (pprClassPred cls cls_tys <+> parens (ppr tc <+> ptext (sLit "..."))))
1482        2 (ptext (sLit "Class") <+> quotes (ppr cls)
1483             <+> ptext (sLit "expects an argument of kind") <+> quotes (pprKind cls_kind))
1484
1485 derivingEtaErr :: Class -> [Type] -> Type -> Message
1486 derivingEtaErr cls cls_tys inst_ty
1487   = sep [ptext (sLit "Cannot eta-reduce to an instance of form"),
1488          nest 2 (ptext (sLit "instance (...) =>")
1489                 <+> pprClassPred cls (cls_tys ++ [inst_ty]))]
1490
1491 typeFamilyPapErr :: TyCon -> Class -> [Type] -> Type -> Message
1492 typeFamilyPapErr tc cls cls_tys inst_ty
1493   = hang (ptext (sLit "Derived instance") <+> quotes (pprClassPred cls (cls_tys ++ [inst_ty])))
1494        2 (ptext (sLit "requires illegal partial application of data type family") <+> ppr tc)
1495
1496 derivingThingErr :: Bool -> Class -> [Type] -> Type -> Message -> Message
1497 derivingThingErr newtype_deriving clas tys ty why
1498   = sep [(hang (ptext (sLit "Can't make a derived instance of"))
1499              2 (quotes (ppr pred))
1500           $$ nest 2 extra) <> colon,
1501          nest 2 why]
1502   where
1503     extra | newtype_deriving = ptext (sLit "(even with cunning newtype deriving)")
1504           | otherwise        = empty
1505     pred = mkClassPred clas (tys ++ [ty])
1506
1507 derivingHiddenErr :: TyCon -> SDoc
1508 derivingHiddenErr tc
1509   = hang (ptext (sLit "The data constructors of") <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))
1510        2 (ptext (sLit "so you cannot derive an instance for it"))
1511
1512 standaloneCtxt :: LHsType Name -> SDoc
1513 standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for"))
1514                        2 (quotes (ppr ty))
1515
1516 derivInstCtxt :: PredType -> Message
1517 derivInstCtxt pred
1518   = ptext (sLit "When deriving the instance for") <+> parens (ppr pred)
1519
1520 badDerivedPred :: PredType -> Message
1521 badDerivedPred pred
1522   = vcat [ptext (sLit "Can't derive instances where the instance context mentions"),
1523           ptext (sLit "type variables that are not data type parameters"),
1524           nest 2 (ptext (sLit "Offending constraint:") <+> ppr pred)]
1525 \end{code}