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