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