ghc/compiler/typecheck/TcDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcDeriv]{Deriving}
   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            ( HsBinds(..), TyClDecl(..),
  14                           andMonoBindList, collectMonoBinders )
  15 import RdrHsSyn         ( RdrNameMonoBinds )
  16 import RnHsSyn          ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred )
  17 import CmdLineOpts      ( DynFlag(..) )
  18
  19 import TcRnMonad
  20 import TcEnv            ( tcExtendTempInstEnv, newDFunName,
  21                           InstInfo(..), pprInstInfo, InstBindings(..),
  22                           pprInstInfoDetails, tcLookupTyCon, tcExtendTyVarEnv
  23                         )
  24 import TcGenDeriv       -- Deriv stuff
  25 import InstEnv          ( simpleDFunClassTyCon )
  26 import TcMonoType       ( tcHsPred )
  27 import TcSimplify       ( tcSimplifyDeriv )
  28
  29 import RnBinds          ( rnMethodBinds, rnTopMonoBinds )
  30 import RnEnv            ( bindLocalsFV, extendTyVarEnvFVRn )
  31 import TcRnMonad        ( thenM, returnM, mapAndUnzipM )
  32 import HscTypes         ( DFunId )
  33
  34 import BasicTypes       ( NewOrData(..) )
  35 import Class            ( className, classArity, classKey, classTyVars, classSCTheta, Class )
  36 import Subst            ( mkTyVarSubst, substTheta )
  37 import ErrUtils         ( dumpIfSet_dyn )
  38 import MkId             ( mkDictFunId )
  39 import DataCon          ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon )
  40 import Maybes           ( maybeToBool, catMaybes )
  41 import Name             ( Name, getSrcLoc )
  42 import Unique           ( Unique, getUnique )
  43 import NameSet
  44 import RdrName          ( RdrName )
  45
  46 import TyCon            ( tyConTyVars, tyConDataCons, tyConArity,
  47                           tyConTheta, isProductTyCon, isDataTyCon,
  48                           isEnumerationTyCon, isRecursiveTyCon, TyCon
  49                         )
  50 import TcType           ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp,
  51                           getClassPredTys_maybe,
  52                           isUnLiftedType, mkClassPred, tyVarsOfTypes, tcSplitFunTys, isTypeKind,
  53                           tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy )
  54 import Var              ( TyVar, tyVarKind, idType, varName )
  55 import VarSet           ( mkVarSet, subVarSet )
  56 import PrelNames
  57 import Util             ( zipWithEqual, sortLt, notNull )
  58 import ListSetOps       ( removeDups,  assoc )
  59 import Outputable
  60 \end{code}
  61
  62 %************************************************************************
  63 %*                                                                      *
  64 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
  65 %*                                                                      *
  66 %************************************************************************
  67
  68 Consider
  69
  70         data T a b = C1 (Foo a) (Bar b)
  71                    | C2 Int (T b a)
  72                    | C3 (T a a)
  73                    deriving (Eq)
  74
  75 [NOTE: See end of these comments for what to do with
  76         data (C a, D b) => T a b = ...
  77 ]
  78
  79 We want to come up with an instance declaration of the form
  80
  81         instance (Ping a, Pong b, ...) => Eq (T a b) where
  82                 x == y = ...
  83
  84 It is pretty easy, albeit tedious, to fill in the code "...".  The
  85 trick is to figure out what the context for the instance decl is,
  86 namely @Ping@, @Pong@ and friends.
  87
  88 Let's call the context reqd for the T instance of class C at types
  89 (a,b, ...)  C (T a b).  Thus:
  90
  91         Eq (T a b) = (Ping a, Pong b, ...)
  92
  93 Now we can get a (recursive) equation from the @data@ decl:
  94
  95         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
  96                    u Eq (T b a) u Eq Int        -- From C2
  97                    u Eq (T a a)                 -- From C3
  98
  99 Foo and Bar may have explicit instances for @Eq@, in which case we can
 100 just substitute for them.  Alternatively, either or both may have
 101 their @Eq@ instances given by @deriving@ clauses, in which case they
 102 form part of the system of equations.
 103
 104 Now all we need do is simplify and solve the equations, iterating to
 105 find the least fixpoint.  Notice that the order of the arguments can
 106 switch around, as here in the recursive calls to T.
 107
 108 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 109
 110 We start with:
 111
 112         Eq (T a b) = {}         -- The empty set
 113
 114 Next iteration:
 115         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 116                    u Eq (T b a) u Eq Int        -- From C2
 117                    u Eq (T a a)                 -- From C3
 118
 119         After simplification:
 120                    = Eq a u Ping b u {} u {} u {}
 121                    = Eq a u Ping b
 122
 123 Next iteration:
 124
 125         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 126                    u Eq (T b a) u Eq Int        -- From C2
 127                    u Eq (T a a)                 -- From C3
 128
 129         After simplification:
 130                    = Eq a u Ping b
 131                    u (Eq b u Ping a)
 132                    u (Eq a u Ping a)
 133
 134                    = Eq a u Ping b u Eq b u Ping a
 135
 136 The next iteration gives the same result, so this is the fixpoint.  We
 137 need to make a canonical form of the RHS to ensure convergence.  We do
 138 this by simplifying the RHS to a form in which
 139
 140         - the classes constrain only tyvars
 141         - the list is sorted by tyvar (major key) and then class (minor key)
 142         - no duplicates, of course
 143
 144 So, here are the synonyms for the ``equation'' structures:
 145
 146 \begin{code}
 147 type DerivEqn = (Name, Class, TyCon, [TyVar], DerivRhs)
 148                 -- The Name is the name for the DFun we'll build
 149                 -- The tyvars bind all the variables in the RHS
 150
 151 pprDerivEqn (n,c,tc,tvs,rhs)
 152   = parens (hsep [ppr n, ppr c, ppr tc, ppr tvs] <+> equals <+> ppr rhs)
 153
 154 type DerivRhs  = ThetaType
 155 type DerivSoln = DerivRhs
 156 \end{code}
 157
 158
 159 [Data decl contexts] A note about contexts on data decls
 160 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 161 Consider
 162
 163         data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
 164
 165 We will need an instance decl like:
 166
 167         instance (Read a, RealFloat a) => Read (Complex a) where
 168           ...
 169
 170 The RealFloat in the context is because the read method for Complex is bound
 171 to construct a Complex, and doing that requires that the argument type is
 172 in RealFloat.
 173
 174 But this ain't true for Show, Eq, Ord, etc, since they don't construct
 175 a Complex; they only take them apart.
 176
 177 Our approach: identify the offending classes, and add the data type
 178 context to the instance decl.  The "offending classes" are
 179
 180         Read, Enum?
 181
 182 FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that
 183 pattern matching against a constructor from a data type with a context
 184 gives rise to the constraints for that context -- or at least the thinned
 185 version.  So now all classes are "offending".
 186
 187
 188
 189 %************************************************************************
 190 %*                                                                      *
 191 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 192 %*                                                                      *
 193 %************************************************************************
 194
 195 \begin{code}
 196 tcDeriving  :: [RenamedTyClDecl]        -- All type constructors
 197             -> TcM ([InstInfo],         -- The generated "instance decls".
 198                     RenamedHsBinds,     -- Extra generated bindings
 199                     FreeVars)           -- These are free in the generated bindings
 200
 201 tcDeriving tycl_decls
 202   = recoverM (returnM ([], EmptyBinds, emptyFVs)) $
 203     getDOpts                    `thenM` \ dflags ->
 204
 205         -- Fish the "deriving"-related information out of the TcEnv
 206         -- and make the necessary "equations".
 207     makeDerivEqns tycl_decls                            `thenM` \ (ordinary_eqns, newtype_inst_info) ->
 208     tcExtendTempInstEnv (map iDFunId newtype_inst_info) $
 209         -- Add the newtype-derived instances to the inst env
 210         -- before tacking the "ordinary" ones
 211
 212     deriveOrdinaryStuff ordinary_eqns                   `thenM` \ (ordinary_inst_info, binds, fvs) ->
 213     let
 214         inst_info  = newtype_inst_info ++ ordinary_inst_info
 215     in
 216
 217     ioToTcRn (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
 218              (ddump_deriving inst_info binds))          `thenM_`
 219
 220     returnM (inst_info, binds, fvs)
 221
 222   where
 223     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc
 224     ddump_deriving inst_infos extra_binds
 225       = vcat (map ppr_info inst_infos) $$ ppr extra_binds
 226
 227     ppr_info inst_info = pprInstInfo inst_info $$
 228                          nest 4 (pprInstInfoDetails inst_info)
 229         -- pprInstInfo doesn't print much: only the type
 230
 231 -----------------------------------------
 232 deriveOrdinaryStuff []  -- Short cut
 233   = returnM ([], EmptyBinds, emptyFVs)
 234
 235 deriveOrdinaryStuff eqns
 236   =     -- Take the equation list and solve it, to deliver a list of
 237         -- solutions, a.k.a. the contexts for the instance decls
 238         -- required for the corresponding equations.
 239     solveDerivEqns eqns                 `thenM` \ new_dfuns ->
 240
 241         -- Now augment the InstInfos, adding in the rather boring
 242         -- actual-code-to-do-the-methods binds.  We may also need to
 243         -- generate extra not-one-inst-decl-specific binds, notably
 244         -- "con2tag" and/or "tag2con" functions.  We do these
 245         -- separately.
 246     gen_taggery_Names new_dfuns         `thenM` \ nm_alist_etc ->
 247
 248     let
 249         extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
 250         extra_mbinds     = andMonoBindList extra_mbind_list
 251         mbinders         = collectMonoBinders extra_mbinds
 252     in
 253     mappM gen_bind new_dfuns            `thenM` \ rdr_name_inst_infos ->
 254
 255     traceTc (text "tcDeriv" <+> vcat (map ppr rdr_name_inst_infos))     `thenM_`
 256     getModule                           `thenM` \ this_mod ->
 257     initRn (InterfaceMode this_mod) (
 258         -- Rename to get RenamedBinds.
 259         -- The only tricky bit is that the extra_binds must scope
 260         -- over the method bindings for the instances.
 261         bindLocalsFV (ptext (SLIT("deriving"))) mbinders        $ \ _ ->
 262         rnTopMonoBinds extra_mbinds []                  `thenM` \ (rn_extra_binds, dus) ->
 263         mapAndUnzipM rn_inst_info rdr_name_inst_infos   `thenM` \ (rn_inst_infos, fvs_s) ->
 264         returnM ((rn_inst_infos, rn_extra_binds),
 265                   duUses dus `plusFV` plusFVs fvs_s)
 266     )                           `thenM` \ ((rn_inst_infos, rn_extra_binds), fvs) ->
 267    returnM (rn_inst_infos, rn_extra_binds, fvs)
 268
 269   where
 270     rn_inst_info (dfun, binds)
 271         = extendTyVarEnvFVRn (map varName tyvars)       $
 272                 -- Bring the right type variables into scope
 273           rnMethodBinds (className cls) [] binds        `thenM` \ (rn_binds, fvs) ->
 274           return (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_binds [] }, fvs)
 275         where
 276           (tyvars, _, cls, _) = tcSplitDFunTy (idType dfun)
 277 \end{code}
 278
 279
 280 %************************************************************************
 281 %*                                                                      *
 282 \subsection[TcDeriv-eqns]{Forming the equations}
 283 %*                                                                      *
 284 %************************************************************************
 285
 286 @makeDerivEqns@ fishes around to find the info about needed derived
 287 instances.  Complicating factors:
 288 \begin{itemize}
 289 \item
 290 We can only derive @Enum@ if the data type is an enumeration
 291 type (all nullary data constructors).
 292
 293 \item
 294 We can only derive @Ix@ if the data type is an enumeration {\em
 295 or} has just one data constructor (e.g., tuples).
 296 \end{itemize}
 297
 298 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 299 all those.
 300
 301 \begin{code}
 302 makeDerivEqns :: [RenamedTyClDecl]
 303               -> TcM ([DerivEqn],       -- Ordinary derivings
 304                       [InstInfo])       -- Special newtype derivings
 305
 306 makeDerivEqns tycl_decls
 307   = mapAndUnzipM mk_eqn derive_these            `thenM` \ (maybe_ordinaries, maybe_newtypes) ->
 308     returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes)
 309   where
 310     ------------------------------------------------------------------
 311     derive_these :: [(NewOrData, Name, RenamedHsPred)]
 312         -- Find the (nd, TyCon, Pred) pairs that must be `derived'
 313         -- NB: only source-language decls have deriving, no imported ones do
 314     derive_these = [ (nd, tycon, pred)
 315                    | TyData {tcdND = nd, tcdName = tycon, tcdDerivs = Just preds} <- tycl_decls,
 316                      pred <- preds ]
 317
 318     ------------------------------------------------------------------
 319     mk_eqn :: (NewOrData, Name, RenamedHsPred) -> TcM (Maybe DerivEqn, Maybe InstInfo)
 320         -- We swizzle the tyvars and datacons out of the tycon
 321         -- to make the rest of the equation
 322
 323     mk_eqn (new_or_data, tycon_name, pred)
 324       = tcLookupTyCon tycon_name                `thenM` \ tycon ->
 325         addSrcLoc (getSrcLoc tycon)             $
 326         addErrCtxt (derivCtxt Nothing tycon)    $
 327         tcExtendTyVarEnv (tyConTyVars tycon)    $       -- Deriving preds may (now) mention
 328                                                         -- the type variables for the type constructor
 329         tcHsPred pred                           `thenM` \ pred' ->
 330         case getClassPredTys_maybe pred' of
 331            Nothing          -> bale_out (malformedPredErr tycon pred)
 332            Just (clas, tys) -> doptM Opt_GlasgowExts                    `thenM` \ gla_exts ->
 333                                mk_eqn_help gla_exts new_or_data tycon clas tys
 334
 335     ------------------------------------------------------------------
 336     mk_eqn_help gla_exts DataType tycon clas tys
 337       | Just err <- checkSideConditions gla_exts clas tycon tys
 338       = bale_out (derivingThingErr clas tys tycon tyvars err)
 339       | otherwise
 340       = new_dfun_name clas tycon         `thenM` \ dfun_name ->
 341         returnM (Just (dfun_name, clas, tycon, tyvars, constraints), Nothing)
 342       where
 343         tyvars    = tyConTyVars tycon
 344         data_cons = tyConDataCons tycon
 345         constraints = extra_constraints ++ ordinary_constraints
 346                  -- "extra_constraints": see note [Data decl contexts] above
 347         extra_constraints = tyConTheta tycon
 348
 349         ordinary_constraints
 350           | clas `hasKey` typeableClassKey      -- For the Typeable class, the constraints
 351                                                 -- don't involve the constructor ags, only
 352                                                 -- the tycon tyvars
 353                                                 -- e.g.   data T a b = ...
 354                                                 -- we want
 355                                                 --      instance (Typeable a, Typable b)
 356                                                 --               => Typeable (T a b) where
 357           = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars]
 358           | otherwise
 359           = [ mkClassPred clas [arg_ty]
 360             | data_con <- tyConDataCons tycon,
 361               arg_ty   <- dataConOrigArgTys data_con,
 362                         -- Use the same type variables
 363                         -- as the type constructor,
 364                         -- hence no need to instantiate
 365               not (isUnLiftedType arg_ty)       -- No constraints for unlifted types?
 366             ]
 367
 368     mk_eqn_help gla_exts NewType tycon clas tys
 369       | can_derive_via_isomorphism && (gla_exts || standard_class gla_exts clas)
 370       =         -- Go ahead and use the isomorphism
 371            traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys)     `thenM_`
 372            new_dfun_name clas tycon             `thenM` \ dfun_name ->
 373            returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name,
 374                                               iBinds = NewTypeDerived rep_tys }))
 375       | standard_class gla_exts clas
 376       = mk_eqn_help gla_exts DataType tycon clas tys    -- Go via bale-out route
 377
 378       | otherwise                               -- Non-standard instance
 379       = bale_out (if gla_exts then
 380                         cant_derive_err -- Too hard
 381                   else
 382                         non_std_err)    -- Just complain about being a non-std instance
 383       where
 384         -- Here is the plan for newtype derivings.  We see
 385         --        newtype T a1...an = T (t ak...an) deriving (.., C s1 .. sm, ...)
 386         -- where aj...an do not occur free in t, and the (C s1 ... sm) is a
 387         -- *partial applications* of class C with the last parameter missing
 388         --
 389         -- We generate the instances
 390         --       instance C s1 .. sm (t ak...aj) => C s1 .. sm (T a1...aj)
 391         -- where T a1...aj is the partial application of the LHS of the correct kind
 392         --
 393         -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )
 394         --      instance Monad (ST s) => Monad (T s) where
 395         --        fail = coerce ... (fail @ ST s)
 396
 397         clas_tyvars = classTyVars clas
 398         kind = tyVarKind (last clas_tyvars)
 399                 -- Kind of the thing we want to instance
 400                 --   e.g. argument kind of Monad, *->*
 401
 402         (arg_kinds, _) = tcSplitFunTys kind
 403         n_args_to_drop = length arg_kinds
 404                 -- Want to drop 1 arg from (T s a) and (ST s a)
 405                 -- to get       instance Monad (ST s) => Monad (T s)
 406
 407         -- Note [newtype representation]
 408         -- We must not use newTyConRep to get the representation
 409         -- type, because that looks through all intermediate newtypes
 410         -- To get the RHS of *this* newtype, just look at the data
 411         -- constructor.  For example
 412         --      newtype B = MkB Int
 413         --      newtype A = MkA B deriving( Num )
 414         -- We want the Num instance of B, *not* the Num instance of Int,
 415         -- when making the Num instance of A!
 416         tyvars                = tyConTyVars tycon
 417         rep_ty                = head (dataConOrigArgTys (head (tyConDataCons tycon)))
 418         (rep_fn, rep_ty_args) = tcSplitAppTys rep_ty
 419
 420         n_tyvars_to_keep = tyConArity tycon  - n_args_to_drop
 421         tyvars_to_drop   = drop n_tyvars_to_keep tyvars
 422         tyvars_to_keep   = take n_tyvars_to_keep tyvars
 423
 424         n_args_to_keep = length rep_ty_args - n_args_to_drop
 425         args_to_drop   = drop n_args_to_keep rep_ty_args
 426         args_to_keep   = take n_args_to_keep rep_ty_args
 427
 428         rep_tys  = tys ++ [mkAppTys rep_fn args_to_keep]
 429         rep_pred = mkClassPred clas rep_tys
 430                 -- rep_pred is the representation dictionary, from where
 431                 -- we are gong to get all the methods for the newtype dictionary
 432
 433         inst_tys = (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars_to_keep)])
 434                 -- The 'tys' here come from the partial application
 435                 -- in the deriving clause. The last arg is the new
 436                 -- instance type.
 437
 438                 -- We must pass the superclasses; the newtype might be an instance
 439                 -- of them in a different way than the representation type
 440                 -- E.g.         newtype Foo a = Foo a deriving( Show, Num, Eq )
 441                 -- Then the Show instance is not done via isomprphism; it shows
 442                 --      Foo 3 as "Foo 3"
 443                 -- The Num instance is derived via isomorphism, but the Show superclass
 444                 -- dictionary must the Show instance for Foo, *not* the Show dictionary
 445                 -- gotten from the Num dictionary. So we must build a whole new dictionary
 446                 -- not just use the Num one.  The instance we want is something like:
 447                 --      instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where
 448                 --              (+) = ((+)@a)
 449                 --              ...etc...
 450                 -- There's no 'corece' needed because after the type checker newtypes
 451                 -- are transparent.
 452
 453         sc_theta = substTheta (mkTyVarSubst clas_tyvars inst_tys)
 454                               (classSCTheta clas)
 455
 456                 -- If there are no tyvars, there's no need
 457                 -- to abstract over the dictionaries we need
 458         dict_args | null tyvars = []
 459                   | otherwise   = rep_pred : sc_theta
 460
 461                 -- Finally! Here's where we build the dictionary Id
 462         mk_dfun dfun_name = mkDictFunId dfun_name tyvars dict_args clas inst_tys
 463
 464         -------------------------------------------------------------------
 465         --  Figuring out whether we can only do this newtype-deriving thing
 466
 467         right_arity = length tys + 1 == classArity clas
 468
 469                 -- Never derive Read,Show,Typeable,Data this way
 470         non_iso_classes = [readClassKey, showClassKey, typeableClassKey, dataClassKey]
 471         can_derive_via_isomorphism
 472            =  not (getUnique clas `elem` non_iso_classes)
 473            && right_arity                       -- Well kinded;
 474                                                 -- eg not: newtype T ... deriving( ST )
 475                                                 --      because ST needs *2* type params
 476            && n_tyvars_to_keep >= 0             -- Type constructor has right kind:
 477                                                 -- eg not: newtype T = T Int deriving( Monad )
 478            && n_args_to_keep   >= 0             -- Rep type has right kind:
 479                                                 -- eg not: newtype T a = T Int deriving( Monad )
 480            && eta_ok                            -- Eta reduction works
 481            && not (isRecursiveTyCon tycon)      -- Does not work for recursive tycons:
 482                                                 --      newtype A = MkA [A]
 483                                                 -- Don't want
 484                                                 --      instance Eq [A] => Eq A !!
 485
 486         -- Check that eta reduction is OK
 487         --      (a) the dropped-off args are identical
 488         --      (b) the remaining type args mention
 489         --          only the remaining type variables
 490         eta_ok = (args_to_drop `tcEqTypes` mkTyVarTys tyvars_to_drop)
 491               && (tyVarsOfTypes args_to_keep `subVarSet` mkVarSet tyvars_to_keep)
 492
 493         cant_derive_err = derivingThingErr clas tys tycon tyvars_to_keep
 494                                 (vcat [ptext SLIT("even with cunning newtype deriving:"),
 495                                         if isRecursiveTyCon tycon then
 496                                           ptext SLIT("the newtype is recursive")
 497                                         else empty,
 498                                         if not right_arity then
 499                                           quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("does not have arity 1")
 500                                         else empty,
 501                                         if not (n_tyvars_to_keep >= 0) then
 502                                           ptext SLIT("the type constructor has wrong kind")
 503                                         else if not (n_args_to_keep >= 0) then
 504                                           ptext SLIT("the representation type has wrong kind")
 505                                         else if not eta_ok then
 506                                           ptext SLIT("the eta-reduction property does not hold")
 507                                         else empty
 508                                       ])
 509
 510         non_std_err = derivingThingErr clas tys tycon tyvars_to_keep
 511                                 (vcat [non_std_why clas,
 512                                        ptext SLIT("Try -fglasgow-exts for GHC's newtype-deriving extension")])
 513
 514     bale_out err = addErrTc err `thenM_` returnM (Nothing, Nothing)
 515     standard_class gla_exts clas =  key `elem` derivableClassKeys
 516                                  || (gla_exts && (key == typeableClassKey || key == dataClassKey))
 517         where
 518           key = classKey clas
 519
 520
 521
 522
 523 new_dfun_name clas tycon        -- Just a simple wrapper
 524   = newDFunName clas [mkTyConApp tycon []] (getSrcLoc tycon)
 525         -- The type passed to newDFunName is only used to generate
 526         -- a suitable string; hence the empty type arg list
 527
 528
 529 ------------------------------------------------------------------
 530 -- Check side conditions that dis-allow derivability for particular classes
 531 -- This is *apart* from the newtype-deriving mechanism
 532
 533 checkSideConditions :: Bool -> Class -> TyCon -> [TcType] -> Maybe SDoc
 534 checkSideConditions gla_exts clas tycon tys
 535   | notNull tys
 536   = Just ty_args_why    -- e.g. deriving( Foo s )
 537   | otherwise
 538   = case [cond | (key,cond) <- sideConditions, key == getUnique clas] of
 539         []     -> Just (non_std_why clas)
 540         [cond] -> cond (gla_exts, tycon)
 541         other  -> pprPanic "checkSideConditions" (ppr clas)
 542   where
 543     ty_args_why      = quotes (ppr (mkClassPred clas tys)) <+> ptext SLIT("is not a class")
 544
 545 non_std_why clas = quotes (ppr clas) <+> ptext SLIT("is not a derivable class")
 546
 547 sideConditions :: [(Unique, Condition)]
 548 sideConditions
 549   = [   (eqClassKey,       cond_std),
 550         (ordClassKey,      cond_std),
 551         (readClassKey,     cond_std),
 552         (showClassKey,     cond_std),
 553         (enumClassKey,     cond_std `andCond` cond_isEnumeration),
 554         (ixClassKey,       cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
 555         (boundedClassKey,  cond_std `andCond` (cond_isEnumeration `orCond` cond_isProduct)),
 556         (typeableClassKey, cond_glaExts `andCond` cond_allTypeKind),
 557         (dataClassKey,     cond_glaExts `andCond` cond_std)
 558     ]
 559
 560 type Condition = (Bool, TyCon) -> Maybe SDoc    -- Nothing => OK
 561
 562 orCond :: Condition -> Condition -> Condition
 563 orCond c1 c2 tc
 564   = case c1 tc of
 565         Nothing -> Nothing              -- c1 succeeds
 566         Just x  -> case c2 tc of        -- c1 fails
 567                      Nothing -> Nothing
 568                      Just y  -> Just (x $$ ptext SLIT("  and") $$ y)
 569                                         -- Both fail
 570
 571 andCond c1 c2 tc = case c1 tc of
 572                      Nothing -> c2 tc   -- c1 succeeds
 573                      Just x  -> Just x  -- c1 fails
 574
 575 cond_std :: Condition
 576 cond_std (gla_exts, tycon)
 577   | any isExistentialDataCon data_cons  = Just existential_why
 578   | null data_cons                      = Just no_cons_why
 579   | otherwise                           = Nothing
 580   where
 581     data_cons       = tyConDataCons tycon
 582     no_cons_why     = quotes (ppr tycon) <+> ptext SLIT("has no data constructors")
 583     existential_why = quotes (ppr tycon) <+> ptext SLIT("has existentially-quantified constructor(s)")
 584
 585 cond_isEnumeration :: Condition
 586 cond_isEnumeration (gla_exts, tycon)
 587   | isEnumerationTyCon tycon = Nothing
 588   | otherwise                = Just why
 589   where
 590     why = quotes (ppr tycon) <+> ptext SLIT("has non-nullary constructors")
 591
 592 cond_isProduct :: Condition
 593 cond_isProduct (gla_exts, tycon)
 594   | isProductTyCon tycon = Nothing
 595   | otherwise            = Just why
 596   where
 597     why = quotes (ppr tycon) <+> ptext SLIT("has more than one constructor")
 598
 599 cond_allTypeKind :: Condition
 600 cond_allTypeKind (gla_exts, tycon)
 601   | all (isTypeKind . tyVarKind) (tyConTyVars tycon) = Nothing
 602   | otherwise                                        = Just why
 603   where
 604     why  = quotes (ppr tycon) <+> ptext SLIT("is parameterised over arguments of kind other than `*'")
 605
 606 cond_glaExts :: Condition
 607 cond_glaExts (gla_exts, tycon) | gla_exts  = Nothing
 608                                | otherwise = Just why
 609   where
 610     why  = ptext SLIT("You need -fglasgow-exts to derive an instance for this class")
 611 \end{code}
 612
 613 %************************************************************************
 614 %*                                                                      *
 615 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
 616 %*                                                                      *
 617 %************************************************************************
 618
 619 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 620 terms, which is the final correct RHS for the corresponding original
 621 equation.
 622 \begin{itemize}
 623 \item
 624 Each (k,TyVarTy tv) in a solution constrains only a type
 625 variable, tv.
 626
 627 \item
 628 The (k,TyVarTy tv) pairs in a solution are canonically
 629 ordered by sorting on type varible, tv, (major key) and then class, k,
 630 (minor key)
 631 \end{itemize}
 632
 633 \begin{code}
 634 solveDerivEqns :: [DerivEqn]
 635                -> TcM [DFunId]  -- Solns in same order as eqns.
 636                                 -- This bunch is Absolutely minimal...
 637
 638 solveDerivEqns orig_eqns
 639   = iterateDeriv 1 initial_solutions
 640   where
 641         -- The initial solutions for the equations claim that each
 642         -- instance has an empty context; this solution is certainly
 643         -- in canonical form.
 644     initial_solutions :: [DerivSoln]
 645     initial_solutions = [ [] | _ <- orig_eqns ]
 646
 647     ------------------------------------------------------------------
 648         -- iterateDeriv calculates the next batch of solutions,
 649         -- compares it with the current one; finishes if they are the
 650         -- same, otherwise recurses with the new solutions.
 651         -- It fails if any iteration fails
 652     iterateDeriv :: Int -> [DerivSoln] ->TcM [DFunId]
 653     iterateDeriv n current_solns
 654       | n > 20  -- Looks as if we are in an infinite loop
 655                 -- This can happen if we have -fallow-undecidable-instances
 656                 -- (See TcSimplify.tcSimplifyDeriv.)
 657       = pprPanic "solveDerivEqns: probable loop"
 658                  (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns)
 659       | otherwise
 660       = let
 661             dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns
 662         in
 663         checkNoErrs (
 664                   -- Extend the inst info from the explicit instance decls
 665                   -- with the current set of solutions, and simplify each RHS
 666             tcExtendTempInstEnv dfuns $
 667             mappM gen_soln orig_eqns
 668         )                               `thenM` \ new_solns ->
 669         if (current_solns == new_solns) then
 670             returnM dfuns
 671         else
 672             iterateDeriv (n+1) new_solns
 673
 674     ------------------------------------------------------------------
 675
 676     gen_soln (_, clas, tc,tyvars,deriv_rhs)
 677       = addSrcLoc (getSrcLoc tc)                $
 678         addErrCtxt (derivCtxt (Just clas) tc)   $
 679         tcSimplifyDeriv tyvars deriv_rhs        `thenM` \ theta ->
 680         returnM (sortLt (<) theta)      -- Canonicalise before returning the soluction
 681
 682 mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta
 683   = mkDictFunId dfun_name tyvars theta
 684                 clas [mkTyConApp tycon (mkTyVarTys tyvars)]
 685 \end{code}
 686
 687 %************************************************************************
 688 %*                                                                      *
 689 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 690 %*                                                                      *
 691 %************************************************************************
 692
 693 After all the trouble to figure out the required context for the
 694 derived instance declarations, all that's left is to chug along to
 695 produce them.  They will then be shoved into @tcInstDecls2@, which
 696 will do all its usual business.
 697
 698 There are lots of possibilities for code to generate.  Here are
 699 various general remarks.
 700
 701 PRINCIPLES:
 702 \begin{itemize}
 703 \item
 704 We want derived instances of @Eq@ and @Ord@ (both v common) to be
 705 ``you-couldn't-do-better-by-hand'' efficient.
 706
 707 \item
 708 Deriving @Show@---also pretty common--- should also be reasonable good code.
 709
 710 \item
 711 Deriving for the other classes isn't that common or that big a deal.
 712 \end{itemize}
 713
 714 PRAGMATICS:
 715
 716 \begin{itemize}
 717 \item
 718 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
 719
 720 \item
 721 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
 722
 723 \item
 724 We {\em normally} generate code only for the non-defaulted methods;
 725 there are some exceptions for @Eq@ and (especially) @Ord@...
 726
 727 \item
 728 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
 729 constructor's numeric (@Int#@) tag.  These are generated by
 730 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
 731 these is around is given by @hasCon2TagFun@.
 732
 733 The examples under the different sections below will make this
 734 clearer.
 735
 736 \item
 737 Much less often (really just for deriving @Ix@), we use a
 738 @_tag2con_<tycon>@ function.  See the examples.
 739
 740 \item
 741 We use the renamer!!!  Reason: we're supposed to be
 742 producing @RenamedMonoBinds@ for the methods, but that means
 743 producing correctly-uniquified code on the fly.  This is entirely
 744 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
 745 So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
 746 the renamer.  What a great hack!
 747 \end{itemize}
 748
 749 \begin{code}
 750 -- Generate the method bindings for the required instance
 751 -- (paired with DFunId, as we need that when renaming
 752 --  the method binds)
 753 gen_bind :: DFunId -> TcM (DFunId, RdrNameMonoBinds)
 754 gen_bind dfun
 755   = getFixityEnv                `thenM` \ fix_env ->
 756     let
 757         (clas, tycon) = simpleDFunClassTyCon dfun
 758         gen_binds_fn  = assoc "gen_bind:bad derived class"
 759                               gen_list (getUnique clas)
 760
 761         gen_list = [(eqClassKey,      gen_Eq_binds)
 762                    ,(ordClassKey,     gen_Ord_binds)
 763                    ,(enumClassKey,    gen_Enum_binds)
 764                    ,(boundedClassKey, gen_Bounded_binds)
 765                    ,(ixClassKey,      gen_Ix_binds)
 766                    ,(showClassKey,    gen_Show_binds fix_env)
 767                    ,(readClassKey,    gen_Read_binds fix_env)
 768                    ,(typeableClassKey,gen_Typeable_binds)
 769                    ,(dataClassKey,    gen_Data_binds)
 770                    ]
 771     in
 772     returnM (dfun, gen_binds_fn tycon)
 773 \end{code}
 774
 775
 776 %************************************************************************
 777 %*                                                                      *
 778 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
 779 %*                                                                      *
 780 %************************************************************************
 781
 782
 783 data Foo ... = ...
 784
 785 con2tag_Foo :: Foo ... -> Int#
 786 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 787 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
 788
 789
 790 We have a @con2tag@ function for a tycon if:
 791 \begin{itemize}
 792 \item
 793 We're deriving @Eq@ and the tycon has nullary data constructors.
 794
 795 \item
 796 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
 797 (enum type only????)
 798 \end{itemize}
 799
 800 We have a @tag2con@ function for a tycon if:
 801 \begin{itemize}
 802 \item
 803 We're deriving @Enum@, or @Ix@ (enum type only???)
 804 \end{itemize}
 805
 806 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
 807
 808 \begin{code}
 809 gen_taggery_Names :: [DFunId]
 810                   -> TcM [(RdrName,     -- for an assoc list
 811                            TyCon,       -- related tycon
 812                            TagThingWanted)]
 813
 814 gen_taggery_Names dfuns
 815   = foldlM do_con2tag []           tycons_of_interest `thenM` \ names_so_far ->
 816     foldlM do_tag2con names_so_far tycons_of_interest
 817   where
 818     all_CTs = map simpleDFunClassTyCon dfuns
 819     all_tycons              = map snd all_CTs
 820     (tycons_of_interest, _) = removeDups compare all_tycons
 821
 822     do_con2tag acc_Names tycon
 823       | isDataTyCon tycon &&
 824         ((we_are_deriving eqClassKey tycon
 825             && any isNullaryDataCon (tyConDataCons tycon))
 826          || (we_are_deriving ordClassKey  tycon
 827             && not (isProductTyCon tycon))
 828          || (we_are_deriving enumClassKey tycon)
 829          || (we_are_deriving ixClassKey   tycon))
 830
 831       = returnM ((con2tag_RDR tycon, tycon, GenCon2Tag)
 832                    : acc_Names)
 833       | otherwise
 834       = returnM acc_Names
 835
 836     do_tag2con acc_Names tycon
 837       | isDataTyCon tycon &&
 838          (we_are_deriving enumClassKey tycon ||
 839           we_are_deriving ixClassKey   tycon
 840           && isEnumerationTyCon tycon)
 841       = returnM ( (tag2con_RDR tycon, tycon, GenTag2Con)
 842                  : (maxtag_RDR  tycon, tycon, GenMaxTag)
 843                  : acc_Names)
 844       | otherwise
 845       = returnM acc_Names
 846
 847     we_are_deriving clas_key tycon
 848       = is_in_eqns clas_key tycon all_CTs
 849       where
 850         is_in_eqns clas_key tycon [] = False
 851         is_in_eqns clas_key tycon ((c,t):cts)
 852           =  (clas_key == classKey c && tycon == t)
 853           || is_in_eqns clas_key tycon cts
 854 \end{code}
 855
 856 \begin{code}
 857 derivingThingErr clas tys tycon tyvars why
 858   = sep [hsep [ptext SLIT("Can't make a derived instance of"), quotes (ppr pred)],
 859          parens why]
 860   where
 861     pred = mkClassPred clas (tys ++ [mkTyConApp tycon (mkTyVarTys tyvars)])
 862
 863 malformedPredErr tycon pred = ptext SLIT("Illegal deriving item") <+> ppr pred
 864
 865 derivCtxt :: Maybe Class -> TyCon -> SDoc
 866 derivCtxt maybe_cls tycon
 867   = ptext SLIT("When deriving") <+> cls <+> ptext SLIT("for type") <+> quotes (ppr tycon)
 868   where
 869     cls = case maybe_cls of
 870             Nothing -> ptext SLIT("instances")
 871             Just c  -> ptext SLIT("the") <+> quotes (ppr c) <+> ptext SLIT("instance")
 872 \end{code}
 873