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