compiler/typecheck/TcGenDeriv.lhs

   1 %
   2 % (c) The University of Glasgow 2006
   3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   4 %
   5
   6 TcGenDeriv: Generating derived instance declarations
   7
   8 This module is nominally ``subordinate'' to @TcDeriv@, which is the
   9 ``official'' interface to deriving-related things.
  10
  11 This is where we do all the grimy bindings' generation.
  12
  13 \begin{code}
  14 module TcGenDeriv (
  15         gen_Bounded_binds,
  16         gen_Enum_binds,
  17         gen_Eq_binds,
  18         gen_Ix_binds,
  19         gen_Ord_binds,
  20         gen_Read_binds,
  21         gen_Show_binds,
  22         gen_Data_binds,
  23         gen_Typeable_binds,
  24         gen_tag_n_con_monobind,
  25
  26         con2tag_RDR, tag2con_RDR, maxtag_RDR,
  27
  28         TagThingWanted(..)
  29     ) where
  30
  31 #include "HsVersions.h"
  32
  33 import HsSyn
  34 import RdrName
  35 import BasicTypes
  36 import DataCon
  37 import Name
  38
  39 import HscTypes
  40 import PrelInfo
  41 import PrelNames
  42 import MkId
  43 import PrimOp
  44 import SrcLoc
  45 import TyCon
  46 import TcType
  47 import TysPrim
  48 import TysWiredIn
  49 import Util
  50 import Constants
  51 import Outputable
  52 import FastString
  53 import OccName
  54 import Bag
  55
  56 import Data.List        ( partition, intersperse )
  57 \end{code}
  58
  59 %************************************************************************
  60 %*                                                                      *
  61 \subsection{Generating code, by derivable class}
  62 %*                                                                      *
  63 %************************************************************************
  64
  65 %************************************************************************
  66 %*                                                                      *
  67 \subsubsection{Generating @Eq@ instance declarations}
  68 %*                                                                      *
  69 %************************************************************************
  70
  71 Here are the heuristics for the code we generate for @Eq@:
  72 \begin{itemize}
  73 \item
  74   Let's assume we have a data type with some (possibly zero) nullary
  75   data constructors and some ordinary, non-nullary ones (the rest,
  76   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  77   and \tr{O}rdinary data cons.
  78 \begin{verbatim}
  79 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  80 \end{verbatim}
  81
  82 \item
  83   For the ordinary constructors (if any), we emit clauses to do The
  84   Usual Thing, e.g.,:
  85
  86 \begin{verbatim}
  87 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
  88 (==) (O2 a1)       (O2 a2)       = a1 == a2
  89 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
  90 \end{verbatim}
  91
  92   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
  93   \tr{a2} are \tr{Float#}s, then we have to generate
  94 \begin{verbatim}
  95 case (a1 `eqFloat#` a2) of
  96   r -> r
  97 \end{verbatim}
  98   for that particular test.
  99
 100 \item
 101   If there are any nullary constructors, we emit a catch-all clause of
 102   the form:
 103
 104 \begin{verbatim}
 105 (==) a b  = case (con2tag_Foo a) of { a# ->
 106             case (con2tag_Foo b) of { b# ->
 107             case (a# ==# b#)     of {
 108               r -> r
 109             }}}
 110 \end{verbatim}
 111
 112   If there aren't any nullary constructors, we emit a simpler
 113   catch-all:
 114 \begin{verbatim}
 115 (==) a b  = False
 116 \end{verbatim}
 117
 118 \item
 119   For the @(/=)@ method, we normally just use the default method.
 120
 121   If the type is an enumeration type, we could/may/should? generate
 122   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 123   above.
 124
 125 \item
 126   We thought about doing this: If we're also deriving @Ord@ for this
 127   tycon, we generate:
 128 \begin{verbatim}
 129 instance ... Eq (Foo ...) where
 130   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 131   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 132 \begin{verbatim}
 133   However, that requires that \tr{Ord <whatever>} was put in the context
 134   for the instance decl, which it probably wasn't, so the decls
 135   produced don't get through the typechecker.
 136 \end{itemize}
 137
 138
 139 \begin{code}
 140 gen_Eq_binds :: TyCon -> LHsBinds RdrName
 141
 142 gen_Eq_binds tycon
 143   = let
 144         tycon_loc = getSrcSpan tycon
 145
 146         (nullary_cons, nonnullary_cons)
 147            | isNewTyCon tycon = ([], tyConDataCons tycon)
 148            | otherwise        = partition isNullarySrcDataCon (tyConDataCons tycon)
 149
 150         rest
 151           = if (null nullary_cons) then
 152                 case maybeTyConSingleCon tycon of
 153                   Just _ -> []
 154                   Nothing -> -- if cons don't match, then False
 155                      [([nlWildPat, nlWildPat], false_Expr)]
 156             else -- calc. and compare the tags
 157                  [([a_Pat, b_Pat],
 158                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 159                                (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
 160     in
 161     listToBag [
 162       mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
 163       mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
 164         nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
 165     ]
 166   where
 167     ------------------------------------------------------------------
 168     pats_etc data_con
 169       = let
 170             con1_pat = nlConVarPat data_con_RDR as_needed
 171             con2_pat = nlConVarPat data_con_RDR bs_needed
 172
 173             data_con_RDR = getRdrName data_con
 174             con_arity   = length tys_needed
 175             as_needed   = take con_arity as_RDRs
 176             bs_needed   = take con_arity bs_RDRs
 177             tys_needed  = dataConOrigArgTys data_con
 178         in
 179         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 180       where
 181         nested_eq_expr []  [] [] = true_Expr
 182         nested_eq_expr tys as bs
 183           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 184           where
 185             nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
 186 \end{code}
 187
 188 %************************************************************************
 189 %*                                                                      *
 190 \subsubsection{Generating @Ord@ instance declarations}
 191 %*                                                                      *
 192 %************************************************************************
 193
 194 For a derived @Ord@, we concentrate our attentions on @compare@
 195 \begin{verbatim}
 196 compare :: a -> a -> Ordering
 197 data Ordering = LT | EQ | GT deriving ()
 198 \end{verbatim}
 199
 200 We will use the same example data type as above:
 201 \begin{verbatim}
 202 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 203 \end{verbatim}
 204
 205 \begin{itemize}
 206 \item
 207   We do all the other @Ord@ methods with calls to @compare@:
 208 \begin{verbatim}
 209 instance ... (Ord <wurble> <wurble>) where
 210     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 211     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 212     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 213     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 214
 215     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 216     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 217
 218     -- compare to come...
 219 \end{verbatim}
 220
 221 \item
 222   @compare@ always has two parts.  First, we use the compared
 223   data-constructors' tags to deal with the case of different
 224   constructors:
 225 \begin{verbatim}
 226 compare a b = case (con2tag_Foo a) of { a# ->
 227               case (con2tag_Foo b) of { b# ->
 228               case (a# ==# b#)     of {
 229                True  -> cmp_eq a b
 230                False -> case (a# <# b#) of
 231                          True  -> _LT
 232                          False -> _GT
 233               }}}
 234   where
 235     cmp_eq = ... to come ...
 236 \end{verbatim}
 237
 238 \item
 239   We are only left with the ``help'' function @cmp_eq@, to deal with
 240   comparing data constructors with the same tag.
 241
 242   For the ordinary constructors (if any), we emit the sorta-obvious
 243   compare-style stuff; for our example:
 244 \begin{verbatim}
 245 cmp_eq (O1 a1 b1) (O1 a2 b2)
 246   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 247
 248 cmp_eq (O2 a1) (O2 a2)
 249   = compare a1 a2
 250
 251 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 252   = case (compare a1 a2) of {
 253       LT -> LT;
 254       GT -> GT;
 255       EQ -> case compare b1 b2 of {
 256               LT -> LT;
 257               GT -> GT;
 258               EQ -> compare c1 c2
 259             }
 260     }
 261 \end{verbatim}
 262
 263   Again, we must be careful about unlifted comparisons.  For example,
 264   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 265   generate:
 266
 267 \begin{verbatim}
 268 cmp_eq lt eq gt (O2 a1) (O2 a2)
 269   = compareInt# a1 a2
 270   -- or maybe the unfolded equivalent
 271 \end{verbatim}
 272
 273 \item
 274   For the remaining nullary constructors, we already know that the
 275   tags are equal so:
 276 \begin{verbatim}
 277 cmp_eq _ _ = EQ
 278 \end{verbatim}
 279 \end{itemize}
 280
 281 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
 282 JJQC-30-Nov-1997
 283
 284 \begin{code}
 285 gen_Ord_binds :: TyCon -> LHsBinds RdrName
 286
 287 gen_Ord_binds tycon
 288   = unitBag compare     -- `AndMonoBinds` compare
 289                 -- The default declaration in PrelBase handles this
 290   where
 291     tycon_loc = getSrcSpan tycon
 292     --------------------------------------------------------------------
 293
 294     compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
 295     compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
 296     cmp_eq_binds    = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
 297
 298     compare_rhs
 299         | single_con_type = cmp_eq_Expr a_Expr b_Expr
 300         | otherwise
 301         = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 302                   (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
 303                         (cmp_eq_Expr a_Expr b_Expr)     -- True case
 304                         -- False case; they aren't equal
 305                         -- So we need to do a less-than comparison on the tags
 306                         (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
 307
 308     tycon_data_cons = tyConDataCons tycon
 309     single_con_type = isSingleton tycon_data_cons
 310     (nullary_cons, nonnullary_cons)
 311        | isNewTyCon tycon = ([], tyConDataCons tycon)
 312        | otherwise        = partition isNullarySrcDataCon tycon_data_cons
 313
 314     cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
 315     cmp_eq_match
 316       | isEnumerationTyCon tycon
 317                            -- We know the tags are equal, so if it's an enumeration TyCon,
 318                            -- then there is nothing left to do
 319                            -- Catch this specially to avoid warnings
 320                            -- about overlapping patterns from the desugarer,
 321                            -- and to avoid unnecessary pattern-matching
 322       = [([nlWildPat,nlWildPat], eqTag_Expr)]
 323       | otherwise
 324       = map pats_etc nonnullary_cons ++
 325         (if single_con_type then        -- Omit wildcards when there's just one
 326               []                        -- constructor, to silence desugarer
 327         else
 328               [([nlWildPat, nlWildPat], default_rhs)])
 329
 330       where
 331         pats_etc data_con
 332           = ([con1_pat, con2_pat],
 333              nested_compare_expr tys_needed as_needed bs_needed)
 334           where
 335             con1_pat = nlConVarPat data_con_RDR as_needed
 336             con2_pat = nlConVarPat data_con_RDR bs_needed
 337
 338             data_con_RDR = getRdrName data_con
 339             con_arity   = length tys_needed
 340             as_needed   = take con_arity as_RDRs
 341             bs_needed   = take con_arity bs_RDRs
 342             tys_needed  = dataConOrigArgTys data_con
 343
 344             nested_compare_expr [ty] [a] [b]
 345               = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
 346
 347             nested_compare_expr (ty:tys) (a:as) (b:bs)
 348               = let eq_expr = nested_compare_expr tys as bs
 349                 in  careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
 350
 351             nested_compare_expr _ _ _ = panic "nested_compare_expr"     -- Args always equal length
 352
 353         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
 354                                                                 -- inexhaustive patterns
 355                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
 356                                                                 -- Tags are equal, no args => return EQ
 357 \end{code}
 358
 359 %************************************************************************
 360 %*                                                                      *
 361 \subsubsection{Generating @Enum@ instance declarations}
 362 %*                                                                      *
 363 %************************************************************************
 364
 365 @Enum@ can only be derived for enumeration types.  For a type
 366 \begin{verbatim}
 367 data Foo ... = N1 | N2 | ... | Nn
 368 \end{verbatim}
 369
 370 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 371 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 372
 373 \begin{verbatim}
 374 instance ... Enum (Foo ...) where
 375     succ x   = toEnum (1 + fromEnum x)
 376     pred x   = toEnum (fromEnum x - 1)
 377
 378     toEnum i = tag2con_Foo i
 379
 380     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 381
 382     -- or, really...
 383     enumFrom a
 384       = case con2tag_Foo a of
 385           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 386
 387    enumFromThen a b
 388      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 389
 390     -- or, really...
 391     enumFromThen a b
 392       = case con2tag_Foo a of { a# ->
 393         case con2tag_Foo b of { b# ->
 394         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 395         }}
 396 \end{verbatim}
 397
 398 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 399
 400 \begin{code}
 401 gen_Enum_binds :: TyCon -> LHsBinds RdrName
 402
 403 gen_Enum_binds tycon
 404   = listToBag [
 405         succ_enum,
 406         pred_enum,
 407         to_enum,
 408         enum_from,
 409         enum_from_then,
 410         from_enum
 411     ]
 412   where
 413     tycon_loc = getSrcSpan tycon
 414     occ_nm    = getOccString tycon
 415
 416     succ_enum
 417       = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
 418         untag_Expr tycon [(a_RDR, ah_RDR)] $
 419         nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
 420                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 421              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 422              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 423                     (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 424                                         nlHsIntLit 1]))
 425
 426     pred_enum
 427       = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
 428         untag_Expr tycon [(a_RDR, ah_RDR)] $
 429         nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
 430                                nlHsVarApps intDataCon_RDR [ah_RDR]])
 431              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 432              (nlHsApp (nlHsVar (tag2con_RDR tycon))
 433                            (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 434                                                nlHsLit (HsInt (-1))]))
 435
 436     to_enum
 437       = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
 438         nlHsIf (nlHsApps and_RDR
 439                 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
 440                  nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
 441              (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
 442              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 443
 444     enum_from
 445       = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
 446           untag_Expr tycon [(a_RDR, ah_RDR)] $
 447           nlHsApps map_RDR
 448                 [nlHsVar (tag2con_RDR tycon),
 449                  nlHsPar (enum_from_to_Expr
 450                             (nlHsVarApps intDataCon_RDR [ah_RDR])
 451                             (nlHsVar (maxtag_RDR tycon)))]
 452
 453     enum_from_then
 454       = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
 455           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 456           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 457             nlHsPar (enum_from_then_to_Expr
 458                     (nlHsVarApps intDataCon_RDR [ah_RDR])
 459                     (nlHsVarApps intDataCon_RDR [bh_RDR])
 460                     (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
 461                                              nlHsVarApps intDataCon_RDR [bh_RDR]])
 462                            (nlHsIntLit 0)
 463                            (nlHsVar (maxtag_RDR tycon))
 464                            ))
 465
 466     from_enum
 467       = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
 468           untag_Expr tycon [(a_RDR, ah_RDR)] $
 469           (nlHsVarApps intDataCon_RDR [ah_RDR])
 470 \end{code}
 471
 472 %************************************************************************
 473 %*                                                                      *
 474 \subsubsection{Generating @Bounded@ instance declarations}
 475 %*                                                                      *
 476 %************************************************************************
 477
 478 \begin{code}
 479 gen_Bounded_binds tycon
 480   = if isEnumerationTyCon tycon then
 481         listToBag [ min_bound_enum, max_bound_enum ]
 482     else
 483         ASSERT(isSingleton data_cons)
 484         listToBag [ min_bound_1con, max_bound_1con ]
 485   where
 486     data_cons = tyConDataCons tycon
 487     tycon_loc = getSrcSpan tycon
 488
 489     ----- enum-flavored: ---------------------------
 490     min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
 491     max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
 492
 493     data_con_1    = head data_cons
 494     data_con_N    = last data_cons
 495     data_con_1_RDR = getRdrName data_con_1
 496     data_con_N_RDR = getRdrName data_con_N
 497
 498     ----- single-constructor-flavored: -------------
 499     arity          = dataConSourceArity data_con_1
 500
 501     min_bound_1con = mkVarBind tycon_loc minBound_RDR $
 502                      nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
 503     max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
 504                      nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
 505 \end{code}
 506
 507 %************************************************************************
 508 %*                                                                      *
 509 \subsubsection{Generating @Ix@ instance declarations}
 510 %*                                                                      *
 511 %************************************************************************
 512
 513 Deriving @Ix@ is only possible for enumeration types and
 514 single-constructor types.  We deal with them in turn.
 515
 516 For an enumeration type, e.g.,
 517 \begin{verbatim}
 518     data Foo ... = N1 | N2 | ... | Nn
 519 \end{verbatim}
 520 things go not too differently from @Enum@:
 521 \begin{verbatim}
 522 instance ... Ix (Foo ...) where
 523     range (a, b)
 524       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 525
 526     -- or, really...
 527     range (a, b)
 528       = case (con2tag_Foo a) of { a# ->
 529         case (con2tag_Foo b) of { b# ->
 530         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 531         }}
 532
 533     -- Generate code for unsafeIndex, becuase using index leads
 534     -- to lots of redundant range tests
 535     unsafeIndex c@(a, b) d
 536       = case (con2tag_Foo d -# con2tag_Foo a) of
 537                r# -> I# r#
 538
 539     inRange (a, b) c
 540       = let
 541             p_tag = con2tag_Foo c
 542         in
 543         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 544
 545     -- or, really...
 546     inRange (a, b) c
 547       = case (con2tag_Foo a)   of { a_tag ->
 548         case (con2tag_Foo b)   of { b_tag ->
 549         case (con2tag_Foo c)   of { c_tag ->
 550         if (c_tag >=# a_tag) then
 551           c_tag <=# b_tag
 552         else
 553           False
 554         }}}
 555 \end{verbatim}
 556 (modulo suitable case-ification to handle the unlifted tags)
 557
 558 For a single-constructor type (NB: this includes all tuples), e.g.,
 559 \begin{verbatim}
 560     data Foo ... = MkFoo a b Int Double c c
 561 \end{verbatim}
 562 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 563 (p.~147).
 564
 565 \begin{code}
 566 gen_Ix_binds :: TyCon -> LHsBinds RdrName
 567
 568 gen_Ix_binds tycon
 569   = if isEnumerationTyCon tycon
 570     then enum_ixes
 571     else single_con_ixes
 572   where
 573     tycon_loc = getSrcSpan tycon
 574
 575     --------------------------------------------------------------
 576     enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
 577
 578     enum_range
 579       = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
 580           untag_Expr tycon [(a_RDR, ah_RDR)] $
 581           untag_Expr tycon [(b_RDR, bh_RDR)] $
 582           nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
 583               nlHsPar (enum_from_to_Expr
 584                         (nlHsVarApps intDataCon_RDR [ah_RDR])
 585                         (nlHsVarApps intDataCon_RDR [bh_RDR]))
 586
 587     enum_index
 588       = mk_easy_FunBind tycon_loc unsafeIndex_RDR
 589                 [noLoc (AsPat (noLoc c_RDR)
 590                            (nlTuplePat [a_Pat, nlWildPat] Boxed)),
 591                                 d_Pat] (
 592            untag_Expr tycon [(a_RDR, ah_RDR)] (
 593            untag_Expr tycon [(d_RDR, dh_RDR)] (
 594            let
 595                 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
 596            in
 597            nlHsCase
 598              (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
 599              [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
 600            ))
 601         )
 602
 603     enum_inRange
 604       = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
 605           untag_Expr tycon [(a_RDR, ah_RDR)] (
 606           untag_Expr tycon [(b_RDR, bh_RDR)] (
 607           untag_Expr tycon [(c_RDR, ch_RDR)] (
 608           nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
 609              (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
 610           ) {-else-} (
 611              false_Expr
 612           ))))
 613
 614     --------------------------------------------------------------
 615     single_con_ixes
 616       = listToBag [single_con_range, single_con_index, single_con_inRange]
 617
 618     data_con
 619       = case maybeTyConSingleCon tycon of -- just checking...
 620           Nothing -> panic "get_Ix_binds"
 621           Just dc | any isUnLiftedType (dataConOrigArgTys dc)
 622                   -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
 623                   | otherwise -> dc
 624
 625     con_arity    = dataConSourceArity data_con
 626     data_con_RDR = getRdrName data_con
 627
 628     as_needed = take con_arity as_RDRs
 629     bs_needed = take con_arity bs_RDRs
 630     cs_needed = take con_arity cs_RDRs
 631
 632     con_pat  xs  = nlConVarPat data_con_RDR xs
 633     con_expr     = nlHsVarApps data_con_RDR cs_needed
 634
 635     --------------------------------------------------------------
 636     single_con_range
 637       = mk_easy_FunBind tycon_loc range_RDR
 638           [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
 639         nlHsDo ListComp stmts con_expr
 640       where
 641         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 642
 643         mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
 644                                  (nlHsApp (nlHsVar range_RDR)
 645                                         (nlTuple [nlHsVar a, nlHsVar b] Boxed))
 646
 647     ----------------
 648     single_con_index
 649       = mk_easy_FunBind tycon_loc unsafeIndex_RDR
 650                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 651                  con_pat cs_needed]
 652                 (mk_index (zip3 as_needed bs_needed cs_needed))
 653       where
 654         -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
 655         mk_index []        = nlHsIntLit 0
 656         mk_index [(l,u,i)] = mk_one l u i
 657         mk_index ((l,u,i) : rest)
 658           = genOpApp (
 659                 mk_one l u i
 660             ) plus_RDR (
 661                 genOpApp (
 662                     (nlHsApp (nlHsVar unsafeRangeSize_RDR)
 663                            (nlTuple [nlHsVar l, nlHsVar u] Boxed))
 664                 ) times_RDR (mk_index rest)
 665            )
 666         mk_one l u i
 667           = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
 668
 669     ------------------
 670     single_con_inRange
 671       = mk_easy_FunBind tycon_loc inRange_RDR
 672                 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
 673                  con_pat cs_needed] $
 674           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
 675       where
 676         in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
 677                                                nlHsVar c]
 678 \end{code}
 679
 680 %************************************************************************
 681 %*                                                                      *
 682 \subsubsection{Generating @Read@ instance declarations}
 683 %*                                                                      *
 684 %************************************************************************
 685
 686 Example
 687
 688   infix 4 %%
 689   data T = Int %% Int
 690          | T1 { f1 :: Int }
 691          | T2 T
 692
 693
 694 instance Read T where
 695   readPrec =
 696     parens
 697     ( prec 4 (
 698         do x           <- ReadP.step Read.readPrec
 699            Symbol "%%" <- Lex.lex
 700            y           <- ReadP.step Read.readPrec
 701            return (x %% y))
 702       +++
 703       prec (appPrec+1) (
 704         -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
 705         -- Record construction binds even more tightly than application
 706         do Ident "T1" <- Lex.lex
 707            Punc '{' <- Lex.lex
 708            Ident "f1" <- Lex.lex
 709            Punc '=' <- Lex.lex
 710            x          <- ReadP.reset Read.readPrec
 711            Punc '}' <- Lex.lex
 712            return (T1 { f1 = x }))
 713       +++
 714       prec appPrec (
 715         do Ident "T2" <- Lex.lexP
 716            x          <- ReadP.step Read.readPrec
 717            return (T2 x))
 718     )
 719
 720   readListPrec = readListPrecDefault
 721   readList     = readListDefault
 722
 723
 724 \begin{code}
 725 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 726
 727 gen_Read_binds get_fixity tycon
 728   = listToBag [read_prec, default_readlist, default_readlistprec]
 729   where
 730     -----------------------------------------------------------------------
 731     default_readlist
 732         = mkVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)
 733
 734     default_readlistprec
 735         = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
 736     -----------------------------------------------------------------------
 737
 738     loc       = getSrcSpan tycon
 739     data_cons = tyConDataCons tycon
 740     (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
 741
 742     read_prec = mkVarBind loc readPrec_RDR
 743                               (nlHsApp (nlHsVar parens_RDR) read_cons)
 744
 745     read_cons             = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
 746     read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
 747
 748     read_nullary_cons
 749       = case nullary_cons of
 750             []    -> []
 751             [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
 752                                     (result_expr con [])]
 753             _     -> [nlHsApp (nlHsVar choose_RDR)
 754                               (nlList (map mk_pair nullary_cons))]
 755
 756     mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
 757                            result_expr con []]
 758                           Boxed
 759
 760     read_non_nullary_con data_con
 761       | is_infix  = mk_parser infix_prec  infix_stmts  body
 762       | is_record = mk_parser record_prec record_stmts body
 763 --              Using these two lines instead allows the derived
 764 --              read for infix and record bindings to read the prefix form
 765 --      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
 766 --      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
 767       | otherwise = prefix_parser
 768       where
 769         body = result_expr data_con as_needed
 770         con_str = data_con_str data_con
 771
 772         prefix_parser = mk_parser prefix_prec prefix_stmts body
 773         prefix_stmts            -- T a b c
 774           = (if not (isSym con_str) then
 775                   [bindLex (ident_pat con_str)]
 776              else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
 777             ++ read_args
 778
 779         infix_stmts             -- a %% b, or  a `T` b
 780           = [read_a1]
 781             ++  (if isSym con_str
 782                  then [bindLex (symbol_pat con_str)]
 783                  else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
 784             ++ [read_a2]
 785
 786         record_stmts            -- T { f1 = a, f2 = b }
 787           = [bindLex (ident_pat (wrapOpParens con_str)),
 788              read_punc "{"]
 789             ++ concat (intersperse [read_punc ","] field_stmts)
 790             ++ [read_punc "}"]
 791
 792         field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed
 793
 794         con_arity    = dataConSourceArity data_con
 795         labels       = dataConFieldLabels data_con
 796         dc_nm        = getName data_con
 797         is_infix     = dataConIsInfix data_con
 798         is_record    = length labels > 0
 799         as_needed    = take con_arity as_RDRs
 800         read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
 801         (read_a1:read_a2:_) = read_args
 802
 803         prefix_prec = appPrecedence
 804         infix_prec  = getPrecedence get_fixity dc_nm
 805         record_prec = appPrecedence + 1 -- Record construction binds even more tightly
 806                                         -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
 807
 808     ------------------------------------------------------------------------
 809     --          Helpers
 810     ------------------------------------------------------------------------
 811     mk_alt e1 e2       = genOpApp e1 alt_RDR e2                                 -- e1 +++ e2
 812     mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b]   -- prec p (do { ss ; b })
 813     bindLex pat        = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))              -- pat <- lexP
 814     con_app con as     = nlHsVarApps (getRdrName con) as                        -- con as
 815     result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)         -- return (con as)
 816
 817     punc_pat s   = nlConPat punc_RDR   [nlLitPat (mkHsString s)]  -- Punc 'c'
 818     ident_pat s  = nlConPat ident_RDR  [nlLitPat (mkHsString s)]  -- Ident "foo"
 819     symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]  -- Symbol ">>"
 820
 821     data_con_str con = occNameString (getOccName con)
 822
 823     read_punc c = bindLex (punc_pat c)
 824     read_arg a ty
 825         | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
 826         | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
 827
 828     read_field lbl a = read_lbl lbl ++
 829                        [read_punc "=",
 830                         noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
 831
 832         -- When reading field labels we might encounter
 833         --      a  = 3
 834         --      _a = 3
 835         -- or   (#) = 4
 836         -- Note the parens!
 837     read_lbl lbl | isSym lbl_str
 838                  = [read_punc "(",
 839                     bindLex (symbol_pat lbl_str),
 840                     read_punc ")"]
 841                  | otherwise
 842                  = [bindLex (ident_pat lbl_str)]
 843                  where
 844                    lbl_str = occNameString (getOccName lbl)
 845 \end{code}
 846
 847
 848 %************************************************************************
 849 %*                                                                      *
 850 \subsubsection{Generating @Show@ instance declarations}
 851 %*                                                                      *
 852 %************************************************************************
 853
 854 Example
 855
 856     infixr 5 :^:
 857
 858     data Tree a =  Leaf a  |  Tree a :^: Tree a
 859
 860     instance (Show a) => Show (Tree a) where
 861
 862         showsPrec d (Leaf m) = showParen (d > app_prec) showStr
 863           where
 864              showStr = showString "Leaf " . showsPrec (app_prec+1) m
 865
 866         showsPrec d (u :^: v) = showParen (d > up_prec) showStr
 867           where
 868              showStr = showsPrec (up_prec+1) u .
 869                        showString " :^: "      .
 870                        showsPrec (up_prec+1) v
 871                 -- Note: right-associativity of :^: ignored
 872
 873     up_prec  = 5    -- Precedence of :^:
 874     app_prec = 10   -- Application has precedence one more than
 875                     -- the most tightly-binding operator
 876
 877 \begin{code}
 878 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
 879
 880 gen_Show_binds get_fixity tycon
 881   = listToBag [shows_prec, show_list]
 882   where
 883     tycon_loc = getSrcSpan tycon
 884     -----------------------------------------------------------------------
 885     show_list = mkVarBind tycon_loc showList_RDR
 886                   (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
 887     -----------------------------------------------------------------------
 888     shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 889       where
 890         pats_etc data_con
 891           | nullary_con =  -- skip the showParen junk...
 892              ASSERT(null bs_needed)
 893              ([nlWildPat, con_pat], mk_showString_app con_str)
 894           | otherwise   =
 895              ([a_Pat, con_pat],
 896                   showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
 897                                  (nlHsPar (nested_compose_Expr show_thingies)))
 898             where
 899              data_con_RDR  = getRdrName data_con
 900              con_arity     = dataConSourceArity data_con
 901              bs_needed     = take con_arity bs_RDRs
 902              arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed
 903              con_pat       = nlConVarPat data_con_RDR bs_needed
 904              nullary_con   = con_arity == 0
 905              labels        = dataConFieldLabels data_con
 906              lab_fields    = length labels
 907              record_syntax = lab_fields > 0
 908
 909              dc_nm          = getName data_con
 910              dc_occ_nm      = getOccName data_con
 911              con_str        = occNameString dc_occ_nm
 912              op_con_str     = wrapOpParens con_str
 913              backquote_str  = wrapOpBackquotes con_str
 914
 915              show_thingies
 916                 | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
 917                 | record_syntax = mk_showString_app (op_con_str ++ " {") :
 918                                   show_record_args ++ [mk_showString_app "}"]
 919                 | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args
 920
 921              show_label l = mk_showString_app (nm ++ " = ")
 922                         -- Note the spaces around the "=" sign.  If we don't have them
 923                         -- then we get Foo { x=-1 } and the "=-" parses as a single
 924                         -- lexeme.  Only the space after the '=' is necessary, but
 925                         -- it seems tidier to have them both sides.
 926                  where
 927                    occ_nm   = getOccName l
 928                    nm       = wrapOpParens (occNameString occ_nm)
 929
 930              show_args               = zipWith show_arg bs_needed arg_tys
 931              (show_arg1:show_arg2:_) = show_args
 932              show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args
 933
 934                 --  Assumption for record syntax: no of fields == no of labelled fields
 935                 --            (and in same order)
 936              show_record_args = concat $
 937                                 intersperse [mk_showString_app ", "] $
 938                                 [ [show_label lbl, arg]
 939                                 | (lbl,arg) <- zipEqual "gen_Show_binds"
 940                                                         labels show_args ]
 941
 942                 -- Generates (showsPrec p x) for argument x, but it also boxes
 943                 -- the argument first if necessary.  Note that this prints unboxed
 944                 -- things without any '#' decorations; could change that if need be
 945              show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
 946                                                          box_if_necy "Show" tycon (nlHsVar b) arg_ty]
 947
 948                 -- Fixity stuff
 949              is_infix = dataConIsInfix data_con
 950              con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
 951              arg_prec | record_syntax = 0       -- Record fields don't need parens
 952                       | otherwise     = con_prec_plus_one
 953
 954 wrapOpParens :: String -> String
 955 wrapOpParens s | isSym s   = '(' : s ++ ")"
 956                | otherwise = s
 957
 958 wrapOpBackquotes :: String -> String
 959 wrapOpBackquotes s | isSym s   = s
 960                    | otherwise = '`' : s ++ "`"
 961
 962 isSym :: String -> Bool
 963 isSym ""     = False
 964 isSym (c:cs) = startsVarSym c || startsConSym c
 965
 966 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
 967 \end{code}
 968
 969 \begin{code}
 970 getPrec :: Bool -> FixityEnv -> Name -> Integer
 971 getPrec is_infix get_fixity nm
 972   | not is_infix   = appPrecedence
 973   | otherwise      = getPrecedence get_fixity nm
 974
 975 appPrecedence :: Integer
 976 appPrecedence = fromIntegral maxPrecedence + 1
 977   -- One more than the precedence of the most
 978   -- tightly-binding operator
 979
 980 getPrecedence :: FixityEnv -> Name -> Integer
 981 getPrecedence get_fixity nm
 982    = case lookupFixity get_fixity nm of
 983         Fixity x _ -> fromIntegral x
 984 \end{code}
 985
 986
 987 %************************************************************************
 988 %*                                                                      *
 989 \subsection{Typeable}
 990 %*                                                                      *
 991 %************************************************************************
 992
 993 From the data type
 994
 995         data T a b = ....
 996
 997 we generate
 998
 999         instance Typeable2 T where
1000                 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1001
1002 We are passed the Typeable2 class as well as T
1003
1004 \begin{code}
1005 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1006 gen_Typeable_binds tycon
1007   = unitBag $
1008         mk_easy_FunBind tycon_loc
1009                 (mk_typeOf_RDR tycon)   -- Name of appropriate type0f function
1010                 [nlWildPat]
1011                 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1012   where
1013     tycon_loc = getSrcSpan tycon
1014     tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1015
1016 mk_typeOf_RDR :: TyCon -> RdrName
1017 -- Use the arity of the TyCon to make the right typeOfn function
1018 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1019                 where
1020                   arity = tyConArity tycon
1021                   suffix | arity == 0 = ""
1022                          | otherwise  = show arity
1023 \end{code}
1024
1025
1026
1027 %************************************************************************
1028 %*                                                                      *
1029 \subsection{Data}
1030 %*                                                                      *
1031 %************************************************************************
1032
1033 From the data type
1034
1035   data T a b = T1 a b | T2
1036
1037 we generate
1038
1039   $cT1 = mkDataCon $dT "T1" Prefix
1040   $cT2 = mkDataCon $dT "T2" Prefix
1041   $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
1042   -- the [] is for field labels.
1043
1044   instance (Data a, Data b) => Data (T a b) where
1045     gfoldl k z (T1 a b) = z T `k` a `k` b
1046     gfoldl k z T2           = z T2
1047     -- ToDo: add gmapT,Q,M, gfoldr
1048
1049     gunfold k z c = case conIndex c of
1050                         I# 1# -> k (k (z T1))
1051                         I# 2# -> z T2
1052
1053     toConstr (T1 _ _) = $cT1
1054     toConstr T2       = $cT2
1055
1056     dataTypeOf _ = $dT
1057
1058 \begin{code}
1059 gen_Data_binds :: FixityEnv
1060                -> TyCon
1061                -> (LHsBinds RdrName,    -- The method bindings
1062                    LHsBinds RdrName)    -- Auxiliary bindings
1063 gen_Data_binds fix_env tycon
1064   = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1065                 -- Auxiliary definitions: the data type and constructors
1066      datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1067   where
1068     tycon_loc  = getSrcSpan tycon
1069     tycon_name = tyConName tycon
1070     data_cons  = tyConDataCons tycon
1071     n_cons     = length data_cons
1072     one_constr = n_cons == 1
1073
1074         ------------ gfoldl
1075     gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1076     gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1077                        foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1078                    where
1079                      con_name ::  RdrName
1080                      con_name = getRdrName con
1081                      as_needed = take (dataConSourceArity con) as_RDRs
1082                      mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1083
1084         ------------ gunfold
1085     gunfold_bind = mk_FunBind tycon_loc
1086                               gunfold_RDR
1087                               [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1088                                 gunfold_rhs)]
1089
1090     gunfold_rhs
1091         | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case
1092         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1093                                 (map gunfold_alt data_cons)
1094
1095     gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1096     mk_unfold_rhs dc = foldr nlHsApp
1097                            (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1098                            (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1099
1100     mk_unfold_pat dc    -- Last one is a wild-pat, to avoid
1101                         -- redundant test, and annoying warning
1102       | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor
1103       | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1104       where
1105         tag = dataConTag dc
1106
1107         ------------ toConstr
1108     toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1109     to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1110
1111         ------------ dataTypeOf
1112     dataTypeOf_bind = mk_easy_FunBind
1113                         tycon_loc
1114                         dataTypeOf_RDR
1115                         [nlWildPat]
1116                         (nlHsVar data_type_name)
1117
1118         ------------  $dT
1119
1120     data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1121     datatype_bind  = mkVarBind
1122                        tycon_loc
1123                        data_type_name
1124                        (           nlHsVar mkDataType_RDR
1125                          `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1126                          `nlHsApp` nlList constrs
1127                        )
1128     constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1129
1130
1131         ------------  $cT1 etc
1132     mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1133     mk_con_bind dc = mkVarBind
1134                        tycon_loc
1135                        (mk_constr_name dc)
1136                        (nlHsApps mkConstr_RDR (constr_args dc))
1137     constr_args dc =
1138          [ -- nlHsIntLit (toInteger (dataConTag dc)),           -- Tag
1139            nlHsVar data_type_name,                              -- DataType
1140            nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1141            nlList  labels,                                      -- Field labels
1142            nlHsVar fixity]                                      -- Fixity
1143         where
1144           labels   = map (nlHsLit . mkHsString . getOccString)
1145                          (dataConFieldLabels dc)
1146           dc_occ   = getOccName dc
1147           is_infix = isDataSymOcc dc_occ
1148           fixity | is_infix  = infix_RDR
1149                  | otherwise = prefix_RDR
1150
1151 gfoldl_RDR     = varQual_RDR gENERICS FSLIT("gfoldl")
1152 gunfold_RDR    = varQual_RDR gENERICS FSLIT("gunfold")
1153 toConstr_RDR   = varQual_RDR gENERICS FSLIT("toConstr")
1154 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1155 mkConstr_RDR   = varQual_RDR gENERICS FSLIT("mkConstr")
1156 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1157 conIndex_RDR   = varQual_RDR gENERICS FSLIT("constrIndex")
1158 prefix_RDR     = dataQual_RDR gENERICS FSLIT("Prefix")
1159 infix_RDR      = dataQual_RDR gENERICS FSLIT("Infix")
1160 \end{code}
1161
1162 %************************************************************************
1163 %*                                                                      *
1164 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1165 %*                                                                      *
1166 %************************************************************************
1167
1168 \begin{verbatim}
1169 data Foo ... = ...
1170
1171 con2tag_Foo :: Foo ... -> Int#
1172 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1173 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1174 \end{verbatim}
1175
1176 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1177 fiddling around.
1178
1179 \begin{code}
1180 data TagThingWanted
1181   = GenCon2Tag | GenTag2Con | GenMaxTag
1182
1183 gen_tag_n_con_monobind
1184     :: ( RdrName,           -- (proto)Name for the thing in question
1185         TyCon,              -- tycon in question
1186         TagThingWanted)
1187     -> LHsBind RdrName
1188
1189 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1190   | lots_of_constructors
1191   = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1192
1193   | otherwise
1194   = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1195
1196   where
1197     tycon_loc = getSrcSpan tycon
1198
1199     tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1200         -- We can't use gerRdrName because that makes an Exact  RdrName
1201         -- and we can't put them in the LocalRdrEnv
1202
1203         -- Give a signature to the bound variable, so
1204         -- that the case expression generated by getTag is
1205         -- monomorphic.  In the push-enter model we get better code.
1206     get_tag_rhs = noLoc $ ExprWithTySig
1207                         (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1208                                               (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1209                         (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1210
1211     con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1212                        (map nlHsTyVar tvs)
1213                 `nlHsFunTy`
1214                 nlHsTyVar (getRdrName intPrimTyCon)
1215
1216     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1217
1218     mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1219     mk_stuff con = ([nlWildConPat con],
1220                     nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1221
1222 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1223   = mk_FunBind (getSrcSpan tycon) rdr_name
1224         [([nlConVarPat intDataCon_RDR [a_RDR]],
1225            noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1226                          (nlHsTyVar (getRdrName tycon))))]
1227
1228 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1229   = mkVarBind (getSrcSpan tycon) rdr_name
1230                   (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1231   where
1232     max_tag =  case (tyConDataCons tycon) of
1233                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1234
1235 \end{code}
1236
1237 %************************************************************************
1238 %*                                                                      *
1239 \subsection{Utility bits for generating bindings}
1240 %*                                                                      *
1241 %************************************************************************
1242
1243
1244 ToDo: Better SrcLocs.
1245
1246 \begin{code}
1247 compare_gen_Case ::
1248           LHsExpr RdrName       -- What to do for equality
1249           -> LHsExpr RdrName -> LHsExpr RdrName
1250           -> LHsExpr RdrName
1251 careful_compare_Case :: -- checks for primitive types...
1252           TyCon                 -- The tycon we are deriving for
1253           -> Type
1254           -> LHsExpr RdrName    -- What to do for equality
1255           -> LHsExpr RdrName -> LHsExpr RdrName
1256           -> LHsExpr RdrName
1257
1258 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1259         -- Was: compare_gen_Case cmp_eq_RDR
1260
1261 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1262   = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1263 compare_gen_Case eq a b                         -- General case
1264   = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1265       [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1266        mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1267        mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1268
1269 careful_compare_Case tycon ty eq a b
1270   | not (isUnLiftedType ty)
1271   = compare_gen_Case eq a b
1272   | otherwise      -- We have to do something special for primitive things...
1273   = nlHsIf (genOpApp a relevant_eq_op b)
1274          eq
1275          (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1276   where
1277     relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1278     relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1279
1280
1281 box_if_necy :: String           -- The class involved
1282             -> TyCon            -- The tycon involved
1283             -> LHsExpr RdrName  -- The argument
1284             -> Type             -- The argument type
1285             -> LHsExpr RdrName  -- Boxed version of the arg
1286 box_if_necy cls_str tycon arg arg_ty
1287   | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1288   | otherwise             = arg
1289   where
1290     box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1291
1292 assoc_ty_id :: String           -- The class involved
1293             -> TyCon            -- The tycon involved
1294             -> [(Type,a)]       -- The table
1295             -> Type             -- The type
1296             -> a                -- The result of the lookup
1297 assoc_ty_id cls_str tycon tbl ty
1298   | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1299                                               text "for primitive type" <+> ppr ty)
1300   | otherwise = head res
1301   where
1302     res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1303
1304 eq_op_tbl :: [(Type, PrimOp)]
1305 eq_op_tbl =
1306     [(charPrimTy,       CharEqOp)
1307     ,(intPrimTy,        IntEqOp)
1308     ,(wordPrimTy,       WordEqOp)
1309     ,(addrPrimTy,       AddrEqOp)
1310     ,(floatPrimTy,      FloatEqOp)
1311     ,(doublePrimTy,     DoubleEqOp)
1312     ]
1313
1314 lt_op_tbl :: [(Type, PrimOp)]
1315 lt_op_tbl =
1316     [(charPrimTy,       CharLtOp)
1317     ,(intPrimTy,        IntLtOp)
1318     ,(wordPrimTy,       WordLtOp)
1319     ,(addrPrimTy,       AddrLtOp)
1320     ,(floatPrimTy,      FloatLtOp)
1321     ,(doublePrimTy,     DoubleLtOp)
1322     ]
1323
1324 box_con_tbl =
1325     [(charPrimTy,       getRdrName charDataCon)
1326     ,(intPrimTy,        getRdrName intDataCon)
1327     ,(wordPrimTy,       wordDataCon_RDR)
1328     ,(floatPrimTy,      getRdrName floatDataCon)
1329     ,(doublePrimTy,     getRdrName doubleDataCon)
1330     ]
1331
1332 -----------------------------------------------------------------------
1333
1334 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1335 and_Expr a b = genOpApp a and_RDR    b
1336
1337 -----------------------------------------------------------------------
1338
1339 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1340 eq_Expr tycon ty a b = genOpApp a eq_op b
1341  where
1342    eq_op
1343     | not (isUnLiftedType ty) = eq_RDR
1344     | otherwise               = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1345          -- we have to do something special for primitive things...
1346 \end{code}
1347
1348 \begin{code}
1349 untag_Expr :: TyCon -> [( RdrName,  RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1350 untag_Expr tycon [] expr = expr
1351 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1352   = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1353       [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1354
1355 cmp_tags_Expr ::  RdrName               -- Comparison op
1356              ->  RdrName ->  RdrName    -- Things to compare
1357              -> LHsExpr RdrName                 -- What to return if true
1358              -> LHsExpr RdrName         -- What to return if false
1359              -> LHsExpr RdrName
1360
1361 cmp_tags_Expr op a b true_case false_case
1362   = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1363
1364 enum_from_to_Expr
1365         :: LHsExpr RdrName -> LHsExpr RdrName
1366         -> LHsExpr RdrName
1367 enum_from_then_to_Expr
1368         :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1369         -> LHsExpr RdrName
1370
1371 enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1372 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1373
1374 showParen_Expr
1375         :: LHsExpr RdrName -> LHsExpr RdrName
1376         -> LHsExpr RdrName
1377
1378 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1379
1380 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1381
1382 nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty
1383 nested_compose_Expr [e] = parenify e
1384 nested_compose_Expr (e:es)
1385   = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1386
1387 -- impossible_Expr is used in case RHSs that should never happen.
1388 -- We generate these to keep the desugarer from complaining that they *might* happen!
1389 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1390
1391 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1392 -- method. It is currently only used by Enum.{succ,pred}
1393 illegal_Expr meth tp msg =
1394    nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1395
1396 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1397 -- to include the value of a_RDR in the error string.
1398 illegal_toEnum_tag tp maxtag =
1399    nlHsApp (nlHsVar error_RDR)
1400            (nlHsApp (nlHsApp (nlHsVar append_RDR)
1401                        (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1402                     (nlHsApp (nlHsApp (nlHsApp
1403                            (nlHsVar showsPrec_RDR)
1404                            (nlHsIntLit 0))
1405                            (nlHsVar a_RDR))
1406                            (nlHsApp (nlHsApp
1407                                (nlHsVar append_RDR)
1408                                (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1409                                (nlHsApp (nlHsApp (nlHsApp
1410                                         (nlHsVar showsPrec_RDR)
1411                                         (nlHsIntLit 0))
1412                                         (nlHsVar maxtag))
1413                                         (nlHsLit (mkHsString ")"))))))
1414
1415 parenify e@(L _ (HsVar _)) = e
1416 parenify e                 = mkHsPar e
1417
1418 -- genOpApp wraps brackets round the operator application, so that the
1419 -- renamer won't subsequently try to re-associate it.
1420 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1421 \end{code}
1422
1423 \begin{code}
1424 getSrcSpan = srcLocSpan . getSrcLoc
1425 \end{code}
1426
1427 \begin{code}
1428 a_RDR           = mkVarUnqual FSLIT("a")
1429 b_RDR           = mkVarUnqual FSLIT("b")
1430 c_RDR           = mkVarUnqual FSLIT("c")
1431 d_RDR           = mkVarUnqual FSLIT("d")
1432 k_RDR           = mkVarUnqual FSLIT("k")
1433 z_RDR           = mkVarUnqual FSLIT("z")
1434 ah_RDR          = mkVarUnqual FSLIT("a#")
1435 bh_RDR          = mkVarUnqual FSLIT("b#")
1436 ch_RDR          = mkVarUnqual FSLIT("c#")
1437 dh_RDR          = mkVarUnqual FSLIT("d#")
1438 cmp_eq_RDR      = mkVarUnqual FSLIT("cmp_eq")
1439
1440 as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1441 bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1442 cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1443
1444 a_Expr          = nlHsVar a_RDR
1445 b_Expr          = nlHsVar b_RDR
1446 c_Expr          = nlHsVar c_RDR
1447 ltTag_Expr      = nlHsVar ltTag_RDR
1448 eqTag_Expr      = nlHsVar eqTag_RDR
1449 gtTag_Expr      = nlHsVar gtTag_RDR
1450 false_Expr      = nlHsVar false_RDR
1451 true_Expr       = nlHsVar true_RDR
1452
1453 a_Pat           = nlVarPat a_RDR
1454 b_Pat           = nlVarPat b_RDR
1455 c_Pat           = nlVarPat c_RDR
1456 d_Pat           = nlVarPat d_RDR
1457 k_Pat           = nlVarPat k_RDR
1458 z_Pat           = nlVarPat z_RDR
1459
1460 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon ->  RdrName
1461 -- Generates Orig s RdrName, for the binding positions
1462 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1463 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1464 maxtag_RDR  tycon = mk_tc_deriv_name tycon "maxtag_"
1465
1466 mk_tc_deriv_name tycon str
1467   = mkDerivedRdrName tc_name mk_occ
1468   where
1469     tc_name = tyConName tycon
1470     mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1471                   where
1472                     new_str = str ++ occNameString tc_occ ++ "#"
1473 \end{code}
1474
1475 s RdrName for PrimOps.  Can't be done in PrelNames, because PrimOp imports
1476 PrelNames, so PrelNames can't import PrimOp.
1477
1478 \begin{code}
1479 primOpRdrName op = getRdrName (primOpId op)
1480
1481 minusInt_RDR  = primOpRdrName IntSubOp
1482 eqInt_RDR     = primOpRdrName IntEqOp
1483 ltInt_RDR     = primOpRdrName IntLtOp
1484 geInt_RDR     = primOpRdrName IntGeOp
1485 leInt_RDR     = primOpRdrName IntLeOp
1486 tagToEnum_RDR = primOpRdrName TagToEnumOp
1487
1488 error_RDR = getRdrName eRROR_ID
1489 \end{code}