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