ghc/compiler/typecheck/TcDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
   3 %
   4 \section[TcDeriv]{Deriving}
   5
   6 Handles @deriving@ clauses on @data@ declarations.
   7
   8 \begin{code}
   9 #include "HsVersions.h"
  10
  11 module TcDeriv (
  12         tcDeriving
  13     ) where
  14
  15 import Ubiq
  16
  17 import HsSyn            ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
  18                           GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
  19                           ArithSeqInfo, Fake, MonoType )
  20 import HsPragmas        ( InstancePragmas(..) )
  21 import RnHsSyn          ( RenamedHsBinds(..), RenamedFixityDecl(..) )
  22 import TcHsSyn          ( TcIdOcc )
  23
  24 import TcMonad
  25 import Inst             ( InstOrigin(..), InstanceMapper(..) )
  26 import TcEnv            ( getEnv_TyCons )
  27 import TcGenDeriv       -- Deriv stuff
  28 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
  29 import TcSimplify       ( tcSimplifyThetas )
  30
  31 import RnMonad4
  32 import RnUtils          ( GlobalNameMappers(..), GlobalNameMapper(..) )
  33 import RnBinds4         ( rnMethodBinds, rnTopBinds )
  34
  35 import Bag              ( Bag, isEmptyBag, unionBags, listToBag )
  36 import Class            ( GenClass, getClassKey )
  37 import ErrUtils         ( pprBagOfErrors, addErrLoc, TcError(..) )
  38 import Id               ( getDataConSig, getDataConArity )
  39 import Maybes           ( assocMaybe, maybeToBool, Maybe(..) )
  40 import Name             ( Name(..) )
  41 import NameTypes        ( mkPreludeCoreName, Provenance(..) )
  42 import Outputable
  43 import PprType          ( GenType, GenTyVar, GenClass, TyCon )
  44 import PprStyle
  45 import Pretty
  46 import ProtoName        ( eqProtoName, ProtoName(..), Name )
  47 import SrcLoc           ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc )
  48 import TyCon            ( getTyConTyVars, getTyConDataCons, getTyConDerivings,
  49                           maybeTyConSingleCon, isEnumerationTyCon, TyCon )
  50 import Type             ( GenType(..), TauType(..), mkTyVarTy, applyTyCon,
  51                           mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
  52                           getAppTyCon, getAppDataTyCon )
  53 import TyVar            ( GenTyVar )
  54 import UniqFM           ( eltsUFM )
  55 import Unique           -- Keys stuff
  56 import Util             ( zipWithEqual, zipEqual, sortLt, removeDups,
  57                           thenCmp, cmpList, panic, pprPanic, pprPanic# )
  58 \end{code}
  59
  60 %************************************************************************
  61 %*                                                                      *
  62 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
  63 %*                                                                      *
  64 %************************************************************************
  65
  66 Consider
  67
  68         data T a b = C1 (Foo a) (Bar b)
  69                    | C2 Int (T b a)
  70                    | C3 (T a a)
  71                    deriving (Eq)
  72
  73 We want to come up with an instance declaration of the form
  74
  75         instance (Ping a, Pong b, ...) => Eq (T a b) where
  76                 x == y = ...
  77
  78 It is pretty easy, albeit tedious, to fill in the code "...".  The
  79 trick is to figure out what the context for the instance decl is,
  80 namely @Ping@, @Pong@ and friends.
  81
  82 Let's call the context reqd for the T instance of class C at types
  83 (a,b, ...)  C (T a b).  Thus:
  84
  85         Eq (T a b) = (Ping a, Pong b, ...)
  86
  87 Now we can get a (recursive) equation from the @data@ decl:
  88
  89         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
  90                    u Eq (T b a) u Eq Int        -- From C2
  91                    u Eq (T a a)                 -- From C3
  92
  93 Foo and Bar may have explicit instances for @Eq@, in which case we can
  94 just substitute for them.  Alternatively, either or both may have
  95 their @Eq@ instances given by @deriving@ clauses, in which case they
  96 form part of the system of equations.
  97
  98 Now all we need do is simplify and solve the equations, iterating to
  99 find the least fixpoint.  Notice that the order of the arguments can
 100 switch around, as here in the recursive calls to T.
 101
 102 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 103
 104 We start with:
 105
 106         Eq (T a b) = {}         -- The empty set
 107
 108 Next iteration:
 109         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 110                    u Eq (T b a) u Eq Int        -- From C2
 111                    u Eq (T a a)                 -- From C3
 112
 113         After simplification:
 114                    = Eq a u Ping b u {} u {} u {}
 115                    = Eq a u Ping b
 116
 117 Next iteration:
 118
 119         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 120                    u Eq (T b a) u Eq Int        -- From C2
 121                    u Eq (T a a)                 -- From C3
 122
 123         After simplification:
 124                    = Eq a u Ping b
 125                    u (Eq b u Ping a)
 126                    u (Eq a u Ping a)
 127
 128                    = Eq a u Ping b u Eq b u Ping a
 129
 130 The next iteration gives the same result, so this is the fixpoint.  We
 131 need to make a canonical form of the RHS to ensure convergence.  We do
 132 this by simplifying the RHS to a form in which
 133
 134         - the classes constrain only tyvars
 135         - the list is sorted by tyvar (major key) and then class (minor key)
 136         - no duplicates, of course
 137
 138 So, here are the synonyms for the ``equation'' structures:
 139
 140 \begin{code}
 141 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
 142                          -- The tyvars bind all the variables in the RHS
 143                          -- NEW: it's convenient to re-use InstInfo
 144                          -- We'll "panic" out some fields...
 145
 146 type DerivRhs = [(Class, TauType)]      -- Same as a ThetaType!
 147
 148 type DerivSoln = DerivRhs
 149 \end{code}
 150
 151 %************************************************************************
 152 %*                                                                      *
 153 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 154 %*                                                                      *
 155 %************************************************************************
 156
 157 \begin{code}
 158 tcDeriving  :: FAST_STRING              -- name of module under scrutiny
 159             -> GlobalNameMappers        -- for "renaming" bits of generated code
 160             -> Bag InstInfo             -- What we already know about instances
 161             -> [RenamedFixityDecl]      -- Fixity info; used by Read and Show
 162             -> TcM s (Bag InstInfo,     -- The generated "instance decls".
 163                       RenamedHsBinds,   -- Extra generated bindings
 164                       PprStyle -> Pretty)  -- Printable derived instance decls;
 165                                            -- for debugging via -ddump-derivings.
 166
 167 tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
 168   =     -- Fish the "deriving"-related information out of the TcEnv
 169         -- and make the necessary "equations".
 170     makeDerivEqns               `thenTc` \ eqns ->
 171
 172         -- Take the equation list and solve it, to deliver a list of
 173         -- solutions, a.k.a. the contexts for the instance decls
 174         -- required for the corresponding equations.
 175     solveDerivEqns modname inst_decl_infos_in eqns
 176                                 `thenTc` \ new_inst_infos ->
 177
 178         -- Now augment the InstInfos, adding in the rather boring
 179         -- actual-code-to-do-the-methods binds.  We may also need to
 180         -- generate extra not-one-inst-decl-specific binds, notably
 181         -- "con2tag" and/or "tag2con" functions.  We do these
 182         -- separately.
 183
 184     gen_taggery_Names eqns      `thenTc` \ nm_alist_etc ->
 185     let
 186         nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ]
 187
 188         -- We have the renamer's final "name funs" in our hands
 189         -- (they were passed in).  So we can handle ProtoNames
 190         -- that refer to anything "out there".  But our generated
 191         -- code may also mention "con2tag" (etc.).  So we need
 192         -- to augment to "name funs" to include those.
 193         (rn_val_gnf, rn_tc_gnf) = renamer_name_funs
 194
 195         deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of
 196                                 Just xx -> Just xx
 197                                 Nothing -> rn_val_gnf pname
 198
 199         deriver_name_funs = (deriv_val_gnf, rn_tc_gnf)
 200
 201         assoc_maybe [] _ = Nothing
 202         assoc_maybe ((k,v) : vs) key
 203           = if k `eqProtoName` key then Just v else assoc_maybe vs key
 204     in
 205     gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
 206
 207     mapTc (gen_inst_info modname fixities deriver_name_funs) new_inst_infos
 208                                                   `thenTc` \ really_new_inst_infos ->
 209
 210     returnTc (listToBag really_new_inst_infos,
 211               extra_binds,
 212               ddump_deriving really_new_inst_infos extra_binds)
 213   where
 214     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
 215
 216     ddump_deriving inst_infos extra_binds sty
 217       = ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
 218       where
 219         pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
 220           = ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
 221                     (ppr sty mbinds)
 222 \end{code}
 223
 224
 225 %************************************************************************
 226 %*                                                                      *
 227 \subsection[TcDeriv-eqns]{Forming the equations}
 228 %*                                                                      *
 229 %************************************************************************
 230
 231 @makeDerivEqns@ fishes around to find the info about needed derived
 232 instances.  Complicating factors:
 233 \begin{itemize}
 234 \item
 235 We can only derive @Enum@ if the data type is an enumeration
 236 type (all nullary data constructors).
 237
 238 \item
 239 We can only derive @Ix@ if the data type is an enumeration {\em
 240 or} has just one data constructor (e.g., tuples).
 241 \end{itemize}
 242
 243 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 244 all those.
 245
 246 \begin{code}
 247 makeDerivEqns :: TcM s [DerivEqn]
 248
 249 makeDerivEqns
 250   = tcGetEnv `thenNF_Tc` \ env ->
 251     let
 252         tycons = eltsUFM (getEnv_TyCons env)
 253         think_about_deriving = need_deriving tycons
 254     in
 255     mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_`
 256     let
 257         (derive_these, _) = removeDups cmp_deriv think_about_deriving
 258         eqns = map mk_eqn derive_these
 259     in
 260     returnTc eqns
 261   where
 262     ------------------------------------------------------------------
 263     need_deriving :: [TyCon] -> [(Class, TyCon)]
 264         -- find the tycons that have `deriving' clauses
 265
 266     need_deriving tycons_to_consider
 267       = foldr ( \ tycon acc ->
 268                    case (getTyConDerivings tycon) of
 269                      [] -> acc
 270                      cs -> [ (clas,tycon) | clas <- cs ] ++ acc
 271               )
 272               []
 273               tycons_to_consider
 274
 275     ------------------------------------------------------------------
 276     chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
 277     chk_out whole_deriving_list this_one@(clas, tycon)
 278       = let
 279             clas_key = getClassKey clas
 280         in
 281
 282             -- Are things OK for deriving Enum (if appropriate)?
 283         checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon))
 284                 (derivingEnumErr tycon)                 `thenTc_`
 285
 286             -- Are things OK for deriving Ix (if appropriate)?
 287         checkTc (clas_key == ixClassKey
 288                  && not (isEnumerationTyCon tycon
 289                          || maybeToBool (maybeTyConSingleCon tycon)))
 290                 (derivingIxErr tycon)
 291
 292     ------------------------------------------------------------------
 293     cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
 294     cmp_deriv (c1, t1) (c2, t2)
 295       = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
 296
 297     ------------------------------------------------------------------
 298     mk_eqn :: (Class, TyCon) -> DerivEqn
 299         -- we swizzle the tyvars and datacons out of the tycon
 300         -- to make the rest of the equation
 301
 302     mk_eqn (clas, tycon)
 303       = (clas, tycon, tyvars, constraints)
 304       where
 305         tyvars    = getTyConTyVars tycon        -- ToDo: Do we need new tyvars ???
 306         tyvar_tys = map mkTyVarTy tyvars
 307         data_cons = getTyConDataCons tycon
 308         constraints = concat (map mk_constraints data_cons)
 309
 310         mk_constraints data_con
 311            = [ (clas, instantiateTy inst_env arg_ty)
 312              | arg_ty <- arg_tys,
 313                not (isPrimType arg_ty)  -- No constraints for primitive types
 314              ]
 315            where
 316              (con_tyvars, _, arg_tys, _) = getDataConSig data_con
 317              inst_env = con_tyvars `zipEqual` tyvar_tys
 318                         -- same number of tyvars in data constr and type constr!
 319 \end{code}
 320
 321 %************************************************************************
 322 %*                                                                      *
 323 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
 324 %*                                                                      *
 325 %************************************************************************
 326
 327 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 328 terms, which is the final correct RHS for the corresponding original
 329 equation.
 330 \begin{itemize}
 331 \item
 332 Each (k,UniTyVarTemplate tv) in a solution constrains only a type
 333 variable, tv.
 334
 335 \item
 336 The (k,UniTyVarTemplate tv) pairs in a solution are canonically
 337 ordered by sorting on type varible, tv, (major key) and then class, k,
 338 (minor key)
 339 \end{itemize}
 340
 341 \begin{code}
 342 solveDerivEqns :: FAST_STRING
 343                -> Bag InstInfo
 344                -> [DerivEqn]
 345                -> TcM s [InstInfo]      -- Solns in same order as eqns.
 346                                         -- This bunch is Absolutely minimal...
 347
 348 solveDerivEqns modname inst_decl_infos_in orig_eqns
 349   = iterateDeriv initial_solutions
 350   where
 351         -- The initial solutions for the equations claim that each
 352         -- instance has an empty context; this solution is certainly
 353         -- in canonical form.
 354     initial_solutions :: [DerivSoln]
 355     initial_solutions = [ [] | _ <- orig_eqns ]
 356
 357         -- iterateDeriv calculates the next batch of solutions,
 358         -- compares it with the current one; finishes if they are the
 359         -- same, otherwise recurses with the new solutions.
 360
 361     iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
 362
 363     iterateDeriv current_solns
 364       =     -- Extend the inst info from the explicit instance decls
 365             -- with the current set of solutions, giving a
 366
 367         add_solns modname inst_decl_infos_in orig_eqns current_solns
 368                                 `thenTc` \ (new_inst_infos, inst_mapper) ->
 369
 370             -- Simplify each RHS, using a DerivingOrigin containing an
 371             -- inst_mapper reflecting the previous solution
 372         let
 373             mk_deriv_origin clas ty
 374               = DerivingOrigin inst_mapper clas tycon
 375               where
 376                 (tycon,_) = getAppTyCon ty
 377         in
 378         listTc [ tcSimplifyThetas mk_deriv_origin rhs
 379                | (_, _, _, rhs) <- orig_eqns
 380                ]                `thenTc` \ next_solns ->
 381
 382             -- Canonicalise the solutions, so they compare nicely
 383         let canonicalised_next_solns
 384               = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
 385
 386         if current_solns `eq_solns` canonicalised_next_solns then
 387             returnTc new_inst_infos
 388         else
 389             iterateDeriv canonicalised_next_solns
 390
 391       where
 392         ------------------------------------------------------------------
 393         lt_rhs    r1 r2 = case cmp_rhs   r1 r2 of { LT_ -> True; _ -> False }
 394         eq_solns  s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
 395         cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
 396         cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
 397           = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
 398 #ifdef DEBUG
 399         cmp_rhs other_1 other_2
 400           = pprPanic# "tcDeriv:cmp_rhs:" (ppCat [ppr PprDebug other_1, ppr PprDebug other_2])
 401 #endif
 402
 403 \end{code}
 404
 405 \begin{code}
 406 add_solns :: FAST_STRING
 407           -> Bag InstInfo                       -- The global, non-derived ones
 408           -> [DerivEqn] -> [DerivSoln]
 409           -> TcM s ([InstInfo],                 -- The new, derived ones
 410                     InstanceMapper)
 411     -- the eqns and solns move "in lockstep"; we have the eqns
 412     -- because we need the LHS info for addClassInstance.
 413
 414 add_solns modname inst_infos_in eqns solns
 415   = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
 416     returnTc (new_inst_infos, inst_mapper)
 417   where
 418     new_inst_infos = zipWithEqual mk_deriv_inst_info eqns solns
 419
 420     all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
 421
 422     mk_deriv_inst_info (clas, tycon, tyvars, _) theta
 423       = InstInfo clas tyvars (applyTyCon tycon (map mkTyVarTy tyvars))
 424                  theta
 425                  theta                  -- Blarg.  This is the dfun_theta slot,
 426                                         -- which is needed by buildInstanceEnv;
 427                                         -- This works ok for solving the eqns, and
 428                                         -- gen_eqns sets it to its final value
 429                                         -- (incl super class dicts) before we
 430                                         -- finally return it.
 431 #ifdef DEBUG
 432                  (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids")
 433                  (panic "add_soln:binds")   (panic "add_soln:from_here")
 434                  (panic "add_soln:modname") mkGeneratedSrcLoc
 435                  (panic "add_soln:upragmas")
 436 #else
 437                 bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom
 438       where
 439         bottom = panic "add_soln"
 440 #endif
 441 \end{code}
 442
 443 %************************************************************************
 444 %*                                                                      *
 445 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 446 %*                                                                      *
 447 %************************************************************************
 448
 449 After all the trouble to figure out the required context for the
 450 derived instance declarations, all that's left is to chug along to
 451 produce them.  They will then be shoved into @tcInstDecls2@, which
 452 will do all its usual business.
 453
 454 There are lots of possibilities for code to generate.  Here are
 455 various general remarks.
 456
 457 PRINCIPLES:
 458 \begin{itemize}
 459 \item
 460 We want derived instances of @Eq@ and @Ord@ (both v common) to be
 461 ``you-couldn't-do-better-by-hand'' efficient.
 462
 463 \item
 464 Deriving @Text@---also pretty common, usually just for
 465 @show@---should also be reasonable good code.
 466
 467 \item
 468 Deriving for the other classes isn't that common or that big a deal.
 469 \end{itemize}
 470
 471 PRAGMATICS:
 472
 473 \begin{itemize}
 474 \item
 475 Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method.
 476
 477 \item
 478 Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too.
 479
 480 \item
 481 We {\em normally} generated code only for the non-defaulted methods;
 482 there are some exceptions for @Eq@ and (especially) @Ord@...
 483
 484 \item
 485 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
 486 constructor's numeric (@Int#@) tag.  These are generated by
 487 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
 488 these is around is given by @hasCon2TagFun@.
 489
 490
 491 The examples under the different sections below will make this
 492 clearer.
 493
 494 \item
 495 Much less often (really just for deriving @Ix@), we use a
 496 @_tag2con_<tycon>@ function.  See the examples.
 497
 498 \item
 499 We use Pass~4 of the renamer!!!  Reason: we're supposed to be
 500 producing @RenamedMonoBinds@ for the methods, but that means
 501 producing correctly-uniquified code on the fly.  This is entirely
 502 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
 503 So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through
 504 the renamer.  What a great hack!
 505 \end{itemize}
 506
 507 \begin{code}
 508 gen_inst_info :: FAST_STRING            -- Module name
 509               -> [RenamedFixityDecl]    -- all known fixities;
 510                                         -- may be needed for Text
 511               -> GlobalNameMappers              -- lookup stuff for names we may use
 512               -> InstInfo               -- the main stuff to work on
 513               -> TcM s InstInfo         -- the gen'd (filled-in) "instance decl"
 514
 515 gen_inst_info modname fixities deriver_name_funs
 516     info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
 517   =
 518         -- Generate the various instance-related Ids
 519     mkInstanceRelatedIds
 520                 True {-from_here-} modname
 521                 NoInstancePragmas
 522                 clas tyvars ty
 523                 inst_decl_theta
 524                 [{-no user pragmas-}]
 525                         `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
 526
 527         -- Generate the bindings for the new instance declaration,
 528         -- rename it, and check for errors
 529     let
 530         (tycon,_,_)  = getAppDataTyCon ty
 531
 532         proto_mbinds
 533           | clas_key == eqClassKey     = gen_Eq_binds tycon
 534           | clas_key == showClassKey   = gen_Show_binds fixities tycon
 535           | clas_key == ordClassKey    = gen_Ord_binds tycon
 536           | clas_key == enumClassKey   = gen_Enum_binds tycon
 537           | clas_key == ixClassKey     = gen_Ix_binds tycon
 538           | clas_key == readClassKey   = gen_Read_binds fixities tycon
 539           | clas_key == binaryClassKey = gen_Binary_binds tycon
 540           | otherwise = panic "gen_inst_info:bad derived class"
 541     in
 542     rn4MtoTcM deriver_name_funs (
 543         rnMethodBinds clas_Name proto_mbinds
 544     )                   `thenNF_Tc` \ (mbinds, errs) ->
 545
 546     if not (isEmptyBag errs) then
 547         pprPanic "gen_inst_info:renamer errs!\n"
 548                  (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
 549     else
 550     --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
 551
 552         -- All done
 553     let
 554         from_here = isLocallyDefined tycon      -- If so, then from here
 555     in
 556     returnTc (InstInfo clas tyvars ty inst_decl_theta
 557                        dfun_theta dfun_id const_meth_ids
 558                        (if from_here then mbinds else EmptyMonoBinds)
 559                        from_here modname locn [])
 560   where
 561     clas_key = getClassKey clas
 562     clas_Name
 563       = let  (mod, nm) = getOrigName clas  in
 564         ClassName clas_key (mkPreludeCoreName mod nm) []
 565 \end{code}
 566
 567 %************************************************************************
 568 %*                                                                      *
 569 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 data Foo ... = ...
 574
 575 con2tag_Foo :: Foo ... -> Int#
 576 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 577 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 578
 579 \begin{code}
 580 gen_tag_n_con_binds :: GlobalNameMappers
 581                     -> [(ProtoName, Name, TyCon, TagThingWanted)]
 582                     -> TcM s RenamedHsBinds
 583
 584 gen_tag_n_con_binds deriver_name_funs nm_alist_etc
 585   = let
 586       proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
 587       proto_mbinds     = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
 588     in
 589
 590     rn4MtoTcM deriver_name_funs (
 591         rnTopBinds (SingleBind (RecBind proto_mbinds))
 592     )                   `thenNF_Tc` \ (binds, errs) ->
 593
 594     if not (isEmptyBag errs) then
 595         panic "gen_inst_info:renamer errs (2)!"
 596     else
 597         returnTc binds
 598 \end{code}
 599
 600 %************************************************************************
 601 %*                                                                      *
 602 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
 603 %*                                                                      *
 604 %************************************************************************
 605
 606 We have a @con2tag@ function for a tycon if:
 607 \begin{itemize}
 608 \item
 609 We're deriving @Eq@ and the tycon has nullary data constructors.
 610
 611 \item
 612 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
 613 (enum type only????)
 614 \end{itemize}
 615
 616 We have a @tag2con@ function for a tycon if:
 617 \begin{itemize}
 618 \item
 619 We're deriving @Enum@, or @Ix@ (enum type only???)
 620 \end{itemize}
 621
 622 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
 623
 624 \begin{code}
 625 gen_taggery_Names :: [DerivEqn]
 626                   -> TcM s [(ProtoName, Name,   -- for an assoc list
 627                              TyCon,             -- related tycon
 628                              TagThingWanted)]
 629
 630 gen_taggery_Names eqns
 631   = let
 632         all_tycons = [ tc | (_, tc, _, _) <- eqns ]
 633         (tycons_of_interest, _) = removeDups cmp all_tycons
 634     in
 635         foldlTc do_con2tag []           tycons_of_interest `thenTc` \ names_so_far ->
 636         foldlTc do_tag2con names_so_far tycons_of_interest
 637   where
 638     do_con2tag acc_Names tycon
 639       = if (we_are_deriving eqClassKey tycon
 640             && any ( (== 0).getDataConArity ) (getTyConDataCons tycon))
 641         || (we_are_deriving ordClassKey  tycon
 642             && not (maybeToBool (maybeTyConSingleCon tycon)))
 643         || (we_are_deriving enumClassKey tycon)
 644         || (we_are_deriving ixClassKey   tycon)
 645         then
 646           tcGetUnique   `thenNF_Tc` ( \ u ->
 647           returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag)
 648                    : acc_Names) )
 649         else
 650           returnTc acc_Names
 651
 652     do_tag2con acc_Names tycon
 653       = if (we_are_deriving enumClassKey tycon)
 654         || (we_are_deriving ixClassKey   tycon)
 655         then
 656           tcGetUnique   `thenNF_Tc` \ u1 ->
 657           tcGetUnique   `thenNF_Tc` \ u2 ->
 658           returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con)
 659                    : (maxtag_PN  tycon, ValName u2 (maxtag_FN  tycon), tycon, GenMaxTag)
 660                    : acc_Names)
 661         else
 662           returnTc acc_Names
 663
 664     we_are_deriving clas_key tycon
 665       = is_in_eqns clas_key tycon eqns
 666       where
 667         is_in_eqns clas_key tycon [] = False
 668         is_in_eqns clas_key tycon ((c,t,_,_):eqns)
 669           =  (clas_key == getClassKey c && tycon == t)
 670           || is_in_eqns clas_key tycon eqns
 671
 672 \end{code}
 673
 674 \begin{code}
 675 derivingEnumErr :: TyCon -> TcError
 676 derivingEnumErr tycon
 677   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty ->
 678     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 679
 680 derivingIxErr :: TyCon -> TcError
 681 derivingIxErr tycon
 682   = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty ->
 683     ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] )
 684 \end{code}