ghc/compiler/typecheck/TcDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   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 ( tcDeriving ) where
  12
  13 IMP_Ubiq()
  14
  15 import HsSyn            ( HsDecl, FixityDecl, Fixity, InstDecl,
  16                           Sig, HsBinds(..), MonoBinds(..),
  17                           GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
  18                           ArithSeqInfo, Fake, HsType,
  19                           collectMonoBinders
  20                         )
  21 import HsPragmas        ( InstancePragmas(..) )
  22 import RdrHsSyn         ( RdrName, SYN_IE(RdrNameMonoBinds) )
  23 import RnHsSyn          ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedFixityDecl) )
  24 import TcHsSyn          ( TcIdOcc )
  25
  26 import TcMonad
  27 import Inst             ( SYN_IE(InstanceMapper) )
  28 import TcEnv            ( getEnv_TyCons, tcLookupClassByKey )
  29 import SpecEnv          ( SpecEnv )
  30 import TcKind           ( TcKind )
  31 import TcGenDeriv       -- Deriv stuff
  32 import TcInstUtil       ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
  33 import TcSimplify       ( tcSimplifyThetas )
  34
  35 import RnBinds          ( rnMethodBinds, rnTopMonoBinds )
  36 import RnEnv            ( newDfunName, bindLocatedLocalsRn )
  37 import RnMonad          ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..),
  38                           setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn )
  39
  40 import Bag              ( Bag, isEmptyBag, unionBags, listToBag )
  41 import Class            ( classKey, GenClass, SYN_IE(Class) )
  42 import ErrUtils         ( pprBagOfErrors, addErrLoc, SYN_IE(Error) )
  43 import Id               ( dataConArgTys, isNullaryDataCon, mkDictFunId )
  44 import PrelInfo         ( needsDataDeclCtxtClassKeys )
  45 import Maybes           ( maybeToBool )
  46 import Name             ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance,
  47                           Name{--O only-}, SYN_IE(Module)
  48                         )
  49 import Outputable       ( PprStyle(..), Outputable(..){-instances e.g., (,)-} )
  50 import PprType          ( GenType, GenTyVar, GenClass, TyCon )
  51 import Pretty           ( ($$), vcat, hsep, hcat,
  52                           ptext, text, char, hang, Doc )
  53 import SrcLoc           ( mkGeneratedSrcLoc, SrcLoc )
  54 import TyCon            ( tyConTyVars, tyConDataCons, tyConDerivings,
  55                           tyConTheta, maybeTyConSingleCon, isDataTyCon,
  56                           isEnumerationTyCon, isAlgTyCon, TyCon
  57                         )
  58 import Type             ( GenType(..), SYN_IE(TauType), mkTyVarTys, applyTyCon,
  59                           mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
  60                           getAppDataTyCon, getAppTyCon
  61                         )
  62 import TysPrim          ( voidTy )
  63 import TyVar            ( GenTyVar, SYN_IE(TyVar) )
  64 import UniqFM           ( emptyUFM )
  65 import Unique           -- Keys stuff
  66 import Bag              ( bagToList )
  67 import Util             ( zipWithEqual, zipEqual, sortLt, removeDups,  assoc,
  68                           thenCmp, cmpList, panic, panic#, pprPanic, pprPanic#,
  69                           Ord3(..), assertPanic-- , pprTrace{-ToDo:rm-}
  70
  71                         )
  72 \end{code}
  73
  74 %************************************************************************
  75 %*                                                                      *
  76 \subsection[TcDeriv-intro]{Introduction to how we do deriving}
  77 %*                                                                      *
  78 %************************************************************************
  79
  80 Consider
  81
  82         data T a b = C1 (Foo a) (Bar b)
  83                    | C2 Int (T b a)
  84                    | C3 (T a a)
  85                    deriving (Eq)
  86
  87 [NOTE: See end of these comments for what to do with
  88         data (C a, D b) => T a b = ...
  89 ]
  90
  91 We want to come up with an instance declaration of the form
  92
  93         instance (Ping a, Pong b, ...) => Eq (T a b) where
  94                 x == y = ...
  95
  96 It is pretty easy, albeit tedious, to fill in the code "...".  The
  97 trick is to figure out what the context for the instance decl is,
  98 namely @Ping@, @Pong@ and friends.
  99
 100 Let's call the context reqd for the T instance of class C at types
 101 (a,b, ...)  C (T a b).  Thus:
 102
 103         Eq (T a b) = (Ping a, Pong b, ...)
 104
 105 Now we can get a (recursive) equation from the @data@ decl:
 106
 107         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 108                    u Eq (T b a) u Eq Int        -- From C2
 109                    u Eq (T a a)                 -- From C3
 110
 111 Foo and Bar may have explicit instances for @Eq@, in which case we can
 112 just substitute for them.  Alternatively, either or both may have
 113 their @Eq@ instances given by @deriving@ clauses, in which case they
 114 form part of the system of equations.
 115
 116 Now all we need do is simplify and solve the equations, iterating to
 117 find the least fixpoint.  Notice that the order of the arguments can
 118 switch around, as here in the recursive calls to T.
 119
 120 Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.
 121
 122 We start with:
 123
 124         Eq (T a b) = {}         -- The empty set
 125
 126 Next iteration:
 127         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 128                    u Eq (T b a) u Eq Int        -- From C2
 129                    u Eq (T a a)                 -- From C3
 130
 131         After simplification:
 132                    = Eq a u Ping b u {} u {} u {}
 133                    = Eq a u Ping b
 134
 135 Next iteration:
 136
 137         Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1
 138                    u Eq (T b a) u Eq Int        -- From C2
 139                    u Eq (T a a)                 -- From C3
 140
 141         After simplification:
 142                    = Eq a u Ping b
 143                    u (Eq b u Ping a)
 144                    u (Eq a u Ping a)
 145
 146                    = Eq a u Ping b u Eq b u Ping a
 147
 148 The next iteration gives the same result, so this is the fixpoint.  We
 149 need to make a canonical form of the RHS to ensure convergence.  We do
 150 this by simplifying the RHS to a form in which
 151
 152         - the classes constrain only tyvars
 153         - the list is sorted by tyvar (major key) and then class (minor key)
 154         - no duplicates, of course
 155
 156 So, here are the synonyms for the ``equation'' structures:
 157
 158 \begin{code}
 159 type DerivEqn = (Class, TyCon, [TyVar], DerivRhs)
 160                          -- The tyvars bind all the variables in the RHS
 161                          -- NEW: it's convenient to re-use InstInfo
 162                          -- We'll "panic" out some fields...
 163
 164 type DerivRhs = [(Class, TauType)]      -- Same as a ThetaType!
 165
 166 type DerivSoln = DerivRhs
 167 \end{code}
 168
 169
 170 A note about contexts on data decls
 171 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 172 Consider
 173
 174         data (RealFloat a) => Complex a = !a :+ !a deriving( Read )
 175
 176 We will need an instance decl like:
 177
 178         instance (Read a, RealFloat a) => Read (Complex a) where
 179           ...
 180
 181 The RealFloat in the context is because the read method for Complex is bound
 182 to construct a Complex, and doing that requires that the argument type is
 183 in RealFloat.
 184
 185 But this ain't true for Show, Eq, Ord, etc, since they don't construct
 186 a Complex; they only take them apart.
 187
 188 Our approach: identify the offending classes, and add the data type
 189 context to the instance decl.  The "offending classes" are
 190
 191         Read, Enum?
 192
 193
 194 %************************************************************************
 195 %*                                                                      *
 196 \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}
 197 %*                                                                      *
 198 %************************************************************************
 199
 200 \begin{code}
 201 tcDeriving  :: Module                   -- name of module under scrutiny
 202             -> RnNameSupply             -- for "renaming" bits of generated code
 203             -> Bag InstInfo             -- What we already know about instances
 204             -> TcM s (Bag InstInfo,     -- The generated "instance decls".
 205                       RenamedHsBinds,   -- Extra generated bindings
 206                       PprStyle -> Doc)  -- Printable derived instance decls;
 207                                            -- for debugging via -ddump-derivings.
 208
 209 tcDeriving modname rn_name_supply inst_decl_infos_in
 210   =     -- Fish the "deriving"-related information out of the TcEnv
 211         -- and make the necessary "equations".
 212     makeDerivEqns                               `thenTc` \ eqns ->
 213
 214         -- Take the equation list and solve it, to deliver a list of
 215         -- solutions, a.k.a. the contexts for the instance decls
 216         -- required for the corresponding equations.
 217     solveDerivEqns inst_decl_infos_in eqns      `thenTc` \ new_inst_infos ->
 218
 219         -- Now augment the InstInfos, adding in the rather boring
 220         -- actual-code-to-do-the-methods binds.  We may also need to
 221         -- generate extra not-one-inst-decl-specific binds, notably
 222         -- "con2tag" and/or "tag2con" functions.  We do these
 223         -- separately.
 224
 225     gen_taggery_Names new_inst_infos            `thenTc` \ nm_alist_etc ->
 226
 227
 228     let
 229         extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
 230         extra_mbinds     = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
 231         method_binds_s   = map gen_bind new_inst_infos
 232         mbinders         = bagToList (collectMonoBinders extra_mbinds)
 233
 234         -- Rename to get RenamedBinds.
 235         -- The only tricky bit is that the extra_binds must scope over the
 236         -- method bindings for the instances.
 237         (dfun_names_w_method_binds, rn_extra_binds)
 238                 = renameSourceCode modname rn_name_supply (
 239                         bindLocatedLocalsRn (\_ -> text "deriving") mbinders    $ \ _ ->
 240                         rnTopMonoBinds extra_mbinds []          `thenRn` \ rn_extra_binds ->
 241                         mapRn rn_one method_binds_s             `thenRn` \ dfun_names_w_method_binds ->
 242                         returnRn (dfun_names_w_method_binds, rn_extra_binds)
 243                   )
 244         rn_one meth_binds = newDfunName Nothing mkGeneratedSrcLoc       `thenRn` \ dfun_name ->
 245                             rnMethodBinds meth_binds                    `thenRn` \ rn_meth_binds ->
 246                             returnRn (dfun_name, rn_meth_binds)
 247     in
 248
 249     mapTc (gen_inst_info modname)
 250           (new_inst_infos `zip` dfun_names_w_method_binds)      `thenTc` \ really_new_inst_infos ->
 251     let
 252         ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
 253     in
 254     --pprTrace "derived:\n" (ddump_deriv PprDebug) $
 255
 256     returnTc (listToBag really_new_inst_infos,
 257               rn_extra_binds,
 258               ddump_deriv)
 259   where
 260     ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Doc)
 261
 262     ddump_deriving inst_infos extra_binds sty
 263       = vcat ((map pp_info inst_infos) ++ [ppr sty extra_binds])
 264       where
 265         pp_info (InstInfo clas tvs ty inst_decl_theta _ _ mbinds _ _)
 266           = ($$) (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
 267                     (ppr sty mbinds)
 268 \end{code}
 269
 270
 271 %************************************************************************
 272 %*                                                                      *
 273 \subsection[TcDeriv-eqns]{Forming the equations}
 274 %*                                                                      *
 275 %************************************************************************
 276
 277 @makeDerivEqns@ fishes around to find the info about needed derived
 278 instances.  Complicating factors:
 279 \begin{itemize}
 280 \item
 281 We can only derive @Enum@ if the data type is an enumeration
 282 type (all nullary data constructors).
 283
 284 \item
 285 We can only derive @Ix@ if the data type is an enumeration {\em
 286 or} has just one data constructor (e.g., tuples).
 287 \end{itemize}
 288
 289 [See Appendix~E in the Haskell~1.2 report.] This code here deals w/
 290 all those.
 291
 292 \begin{code}
 293 makeDerivEqns :: TcM s [DerivEqn]
 294
 295 makeDerivEqns
 296   = tcGetEnv                        `thenNF_Tc` \ env ->
 297     let
 298         local_data_tycons = filter (\tc -> isLocallyDefined tc && isAlgTyCon tc)
 299                                    (getEnv_TyCons env)
 300     in
 301     if null local_data_tycons then
 302         -- Bale out now; evalClass may not be loaded if there aren't any
 303         returnTc []
 304     else
 305     tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
 306     let
 307         think_about_deriving = need_deriving eval_clas local_data_tycons
 308         (derive_these, _)    = removeDups cmp_deriv think_about_deriving
 309         eqns                 = map mk_eqn derive_these
 310     in
 311     mapTc chk_out think_about_deriving `thenTc_`
 312     returnTc eqns
 313   where
 314     ------------------------------------------------------------------
 315     need_deriving :: Class -> [TyCon] -> [(Class, TyCon)]
 316         -- find the tycons that have `deriving' clauses;
 317         -- we handle the "every datatype in Eval" by
 318         -- doing a dummy "deriving" for it.
 319
 320     need_deriving eval_clas tycons_to_consider
 321       = foldr ( \ tycon acc ->
 322                    let
 323                         acc_plus = if isLocallyDefined tycon
 324                                    then (eval_clas, tycon) : acc
 325                                    else acc
 326                    in
 327                    case (tyConDerivings tycon) of
 328                      [] -> acc_plus
 329                      cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus
 330               )
 331               []
 332               tycons_to_consider
 333
 334     ------------------------------------------------------------------
 335     chk_out :: (Class, TyCon) -> TcM s ()
 336     chk_out this_one@(clas, tycon)
 337       = let
 338             clas_key = classKey clas
 339
 340             is_enumeration = isEnumerationTyCon tycon
 341             is_single_con  = maybeToBool (maybeTyConSingleCon tycon)
 342
 343             chk_clas clas_uniq clas_str cond
 344               = if (clas_uniq == clas_key)
 345                 then checkTc cond (derivingThingErr clas_str tycon)
 346                 else returnTc ()
 347         in
 348             -- Are things OK for deriving Enum (if appropriate)?
 349         chk_clas enumClassKey "Enum" is_enumeration `thenTc_`
 350
 351             -- Are things OK for deriving Bounded (if appropriate)?
 352         chk_clas boundedClassKey "Bounded"
 353                 (is_enumeration || is_single_con) `thenTc_`
 354
 355             -- Are things OK for deriving Ix (if appropriate)?
 356         chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con)
 357
 358     ------------------------------------------------------------------
 359     cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_
 360     cmp_deriv (c1, t1) (c2, t2)
 361       = (c1 `cmp` c2) `thenCmp` (t1 `cmp` t2)
 362
 363     ------------------------------------------------------------------
 364     mk_eqn :: (Class, TyCon) -> DerivEqn
 365         -- we swizzle the tyvars and datacons out of the tycon
 366         -- to make the rest of the equation
 367
 368     mk_eqn (clas, tycon)
 369       = (clas, tycon, tyvars, if_not_Eval constraints)
 370       where
 371         clas_key  = classKey clas
 372         tyvars    = tyConTyVars tycon   -- ToDo: Do we need new tyvars ???
 373         tyvar_tys = mkTyVarTys tyvars
 374         data_cons = tyConDataCons tycon
 375
 376         if_not_Eval cs = if clas_key == evalClassKey then [] else cs
 377
 378         constraints = extra_constraints ++ concat (map mk_constraints data_cons)
 379
 380         -- "extra_constraints": see notes above about contexts on data decls
 381         extra_constraints
 382           | offensive_class = tyConTheta tycon
 383           | otherwise       = []
 384            where
 385             offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys
 386
 387         mk_constraints data_con
 388            = [ (clas, arg_ty)
 389              | arg_ty <- instd_arg_tys,
 390                not (isPrimType arg_ty)  -- No constraints for primitive types
 391              ]
 392            where
 393              instd_arg_tys  = dataConArgTys data_con tyvar_tys
 394 \end{code}
 395
 396 %************************************************************************
 397 %*                                                                      *
 398 \subsection[TcDeriv-fixpoint]{Finding the fixed point of \tr{deriving} equations}
 399 %*                                                                      *
 400 %************************************************************************
 401
 402 A ``solution'' (to one of the equations) is a list of (k,TyVarTy tv)
 403 terms, which is the final correct RHS for the corresponding original
 404 equation.
 405 \begin{itemize}
 406 \item
 407 Each (k,TyVarTy tv) in a solution constrains only a type
 408 variable, tv.
 409
 410 \item
 411 The (k,TyVarTy tv) pairs in a solution are canonically
 412 ordered by sorting on type varible, tv, (major key) and then class, k,
 413 (minor key)
 414 \end{itemize}
 415
 416 \begin{code}
 417 solveDerivEqns :: Bag InstInfo
 418                -> [DerivEqn]
 419                -> TcM s [InstInfo]      -- Solns in same order as eqns.
 420                                         -- This bunch is Absolutely minimal...
 421
 422 solveDerivEqns inst_decl_infos_in orig_eqns
 423   = iterateDeriv initial_solutions
 424   where
 425         -- The initial solutions for the equations claim that each
 426         -- instance has an empty context; this solution is certainly
 427         -- in canonical form.
 428     initial_solutions :: [DerivSoln]
 429     initial_solutions = [ [] | _ <- orig_eqns ]
 430
 431         -- iterateDeriv calculates the next batch of solutions,
 432         -- compares it with the current one; finishes if they are the
 433         -- same, otherwise recurses with the new solutions.
 434
 435     iterateDeriv :: [DerivSoln] ->TcM s [InstInfo]
 436
 437     iterateDeriv current_solns
 438       =     -- Extend the inst info from the explicit instance decls
 439             -- with the current set of solutions, giving a
 440
 441         add_solns inst_decl_infos_in orig_eqns current_solns
 442                                 `thenTc` \ (new_inst_infos, inst_mapper) ->
 443         let
 444            class_to_inst_env cls = fst (inst_mapper cls)
 445         in
 446             -- Simplify each RHS
 447
 448         listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs
 449                | (_,_,_,deriv_rhs) <- orig_eqns ]  `thenTc` \ next_solns ->
 450
 451             -- Canonicalise the solutions, so they compare nicely
 452         let canonicalised_next_solns
 453               = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in
 454
 455         if (current_solns `eq_solns` canonicalised_next_solns) then
 456             returnTc new_inst_infos
 457         else
 458             iterateDeriv canonicalised_next_solns
 459
 460       where
 461         ------------------------------------------------------------------
 462         lt_rhs    r1 r2 = case cmp_rhs   r1 r2 of { LT_ -> True; _ -> False }
 463         eq_solns  s1 s2 = case cmp_solns s1 s2 of { EQ_ -> True; _ -> False }
 464         cmp_solns s1 s2 = cmpList (cmpList cmp_rhs) s1 s2
 465         cmp_rhs (c1, TyVarTy tv1) (c2, TyVarTy tv2)
 466           = (tv1 `cmp` tv2) `thenCmp` (c1 `cmp` c2)
 467 #ifdef DEBUG
 468         cmp_rhs other_1 other_2
 469           = panic# "tcDeriv:cmp_rhs:" --(hsep [ppr PprDebug other_1, ppr PprDebug other_2])
 470 #endif
 471
 472 \end{code}
 473
 474 \begin{code}
 475 add_solns :: Bag InstInfo                       -- The global, non-derived ones
 476           -> [DerivEqn] -> [DerivSoln]
 477           -> TcM s ([InstInfo],                 -- The new, derived ones
 478                     InstanceMapper)
 479     -- the eqns and solns move "in lockstep"; we have the eqns
 480     -- because we need the LHS info for addClassInstance.
 481
 482 add_solns inst_infos_in eqns solns
 483   = buildInstanceEnvs all_inst_infos `thenTc` \ inst_mapper ->
 484     returnTc (new_inst_infos, inst_mapper)
 485   where
 486     new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
 487
 488     all_inst_infos = inst_infos_in `unionBags` listToBag new_inst_infos
 489
 490     mk_deriv_inst_info (clas, tycon, tyvars, _) theta
 491       = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars))
 492                  theta
 493                  (my_panic "dfun_theta")
 494
 495                  dummy_dfun_id
 496
 497                  (my_panic "binds") (getSrcLoc tycon)
 498                  (my_panic "upragmas")
 499       where
 500         dummy_dfun_id
 501           = mkDictFunId bottom dummy_dfun_ty bottom bottom
 502           where
 503             bottom = panic "dummy_dfun_id"
 504
 505         dummy_dfun_ty = mkSigmaTy tyvars theta voidTy
 506                 -- All we need from the dfun is its "theta" part, used during
 507                 -- equation simplification (tcSimplifyThetas).  The final
 508                 -- dfun_id will have the superclass dictionaries as arguments too,
 509                 -- but that'll be added after the equations are solved.  For now,
 510                 -- it's enough just to make a dummy dfun with the simple theta part.
 511                 --
 512                 -- The part after the theta is dummied here as voidTy; actually it's
 513                 --      (C (T a b)), but it doesn't seem worth constructing it.
 514                 -- We can't leave it as a panic because to get the theta part we
 515                 -- have to run down the type!
 516
 517         my_panic str = panic "add_soln" -- pprPanic ("add_soln:"++str) (hsep [char ':', ppr PprDebug clas, ppr PprDebug tycon])
 518 \end{code}
 519
 520 %************************************************************************
 521 %*                                                                      *
 522 \subsection[TcDeriv-normal-binds]{Bindings for the various classes}
 523 %*                                                                      *
 524 %************************************************************************
 525
 526 After all the trouble to figure out the required context for the
 527 derived instance declarations, all that's left is to chug along to
 528 produce them.  They will then be shoved into @tcInstDecls2@, which
 529 will do all its usual business.
 530
 531 There are lots of possibilities for code to generate.  Here are
 532 various general remarks.
 533
 534 PRINCIPLES:
 535 \begin{itemize}
 536 \item
 537 We want derived instances of @Eq@ and @Ord@ (both v common) to be
 538 ``you-couldn't-do-better-by-hand'' efficient.
 539
 540 \item
 541 Deriving @Show@---also pretty common--- should also be reasonable good code.
 542
 543 \item
 544 Deriving for the other classes isn't that common or that big a deal.
 545 \end{itemize}
 546
 547 PRAGMATICS:
 548
 549 \begin{itemize}
 550 \item
 551 Deriving @Ord@ is done mostly with the 1.3 @compare@ method.
 552
 553 \item
 554 Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.
 555
 556 \item
 557 We {\em normally} generate code only for the non-defaulted methods;
 558 there are some exceptions for @Eq@ and (especially) @Ord@...
 559
 560 \item
 561 Sometimes we use a @_con2tag_<tycon>@ function, which returns a data
 562 constructor's numeric (@Int#@) tag.  These are generated by
 563 @gen_tag_n_con_binds@, and the heuristic for deciding if one of
 564 these is around is given by @hasCon2TagFun@.
 565
 566 The examples under the different sections below will make this
 567 clearer.
 568
 569 \item
 570 Much less often (really just for deriving @Ix@), we use a
 571 @_tag2con_<tycon>@ function.  See the examples.
 572
 573 \item
 574 We use the renamer!!!  Reason: we're supposed to be
 575 producing @RenamedMonoBinds@ for the methods, but that means
 576 producing correctly-uniquified code on the fly.  This is entirely
 577 possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.
 578 So, instead, we produce @RdrNameMonoBinds@ then heave 'em through
 579 the renamer.  What a great hack!
 580 \end{itemize}
 581
 582 \begin{code}
 583 -- Generate the method bindings for the required instance
 584 gen_bind :: InstInfo -> RdrNameMonoBinds
 585 gen_bind (InstInfo clas _ ty _ _ _ _ _ _)
 586   | not from_here
 587   = EmptyMonoBinds
 588   | otherwise
 589   = assoc "gen_inst_info:bad derived class"
 590           [(eqClassKey,      gen_Eq_binds)
 591           ,(ordClassKey,     gen_Ord_binds)
 592           ,(enumClassKey,    gen_Enum_binds)
 593           ,(evalClassKey,    gen_Eval_binds)
 594           ,(boundedClassKey, gen_Bounded_binds)
 595           ,(showClassKey,    gen_Show_binds)
 596           ,(readClassKey,    gen_Read_binds)
 597           ,(ixClassKey,      gen_Ix_binds)
 598           ]
 599           (classKey clas)
 600           tycon
 601   where
 602       from_here   = isLocallyDefined tycon
 603       (tycon,_,_) = getAppDataTyCon ty
 604
 605
 606 gen_inst_info :: Module                                 -- Module name
 607               -> (InstInfo, (Name, RenamedMonoBinds))           -- the main stuff to work on
 608               -> TcM s InstInfo                         -- the gen'd (filled-in) "instance decl"
 609
 610 gen_inst_info modname
 611     (InstInfo clas tyvars ty inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds))
 612   =
 613         -- Generate the various instance-related Ids
 614     mkInstanceRelatedIds
 615                 dfun_name
 616                 clas tyvars ty
 617                 inst_decl_theta
 618                                         `thenNF_Tc` \ (dfun_id, dfun_theta) ->
 619
 620     returnTc (InstInfo clas tyvars ty inst_decl_theta
 621                        dfun_theta dfun_id
 622                        meth_binds
 623                        locn [])
 624   where
 625     from_here = isLocallyDefined tycon
 626     (tycon,_,_) = getAppDataTyCon ty
 627 \end{code}
 628
 629
 630 %************************************************************************
 631 %*                                                                      *
 632 \subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
 633 %*                                                                      *
 634 %************************************************************************
 635
 636
 637 data Foo ... = ...
 638
 639 con2tag_Foo :: Foo ... -> Int#
 640 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
 641 maxtag_Foo  :: Int              -- ditto (NB: not unboxed)
 642
 643
 644 We have a @con2tag@ function for a tycon if:
 645 \begin{itemize}
 646 \item
 647 We're deriving @Eq@ and the tycon has nullary data constructors.
 648
 649 \item
 650 Or: we're deriving @Ord@ (unless single-constructor), @Enum@, @Ix@
 651 (enum type only????)
 652 \end{itemize}
 653
 654 We have a @tag2con@ function for a tycon if:
 655 \begin{itemize}
 656 \item
 657 We're deriving @Enum@, or @Ix@ (enum type only???)
 658 \end{itemize}
 659
 660 If we have a @tag2con@ function, we also generate a @maxtag@ constant.
 661
 662 \begin{code}
 663 gen_taggery_Names :: [InstInfo]
 664                   -> TcM s [(RdrName,   -- for an assoc list
 665                              TyCon,     -- related tycon
 666                              TagThingWanted)]
 667
 668 gen_taggery_Names inst_infos
 669   = --pprTrace "gen_taggery:\n" (vcat [hsep [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $
 670     foldlTc do_con2tag []           tycons_of_interest `thenTc` \ names_so_far ->
 671     foldlTc do_tag2con names_so_far tycons_of_interest
 672   where
 673     all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _) <- inst_infos ]
 674
 675     mk_CT c ty = (c, fst (getAppTyCon ty))
 676
 677     all_tycons = map snd all_CTs
 678     (tycons_of_interest, _) = removeDups cmp all_tycons
 679
 680     do_con2tag acc_Names tycon
 681       | isDataTyCon tycon &&
 682         (we_are_deriving eqClassKey tycon
 683             && any isNullaryDataCon (tyConDataCons tycon))
 684          || (we_are_deriving ordClassKey  tycon
 685             && not (maybeToBool (maybeTyConSingleCon tycon)))
 686          || (we_are_deriving enumClassKey tycon)
 687          || (we_are_deriving ixClassKey   tycon)
 688
 689       = returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
 690                    : acc_Names)
 691       | otherwise
 692       = returnTc acc_Names
 693
 694     do_tag2con acc_Names tycon
 695       = if (we_are_deriving enumClassKey tycon)
 696         || (we_are_deriving ixClassKey   tycon)
 697         then
 698           returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
 699                    : (maxtag_RDR  tycon, tycon, GenMaxTag)
 700                    : acc_Names)
 701         else
 702           returnTc acc_Names
 703
 704     we_are_deriving clas_key tycon
 705       = is_in_eqns clas_key tycon all_CTs
 706       where
 707         is_in_eqns clas_key tycon [] = False
 708         is_in_eqns clas_key tycon ((c,t):cts)
 709           =  (clas_key == classKey c && tycon == t)
 710           || is_in_eqns clas_key tycon cts
 711
 712 \end{code}
 713
 714 \begin{code}
 715 derivingThingErr :: String -> TyCon -> Error
 716
 717 derivingThingErr thing tycon sty
 718   = hang (hsep [ptext SLIT("Can't make a derived instance of"), text thing])
 719          4 (hsep [ptext SLIT("for the type"), ppr sty tycon])
 720 \end{code}