ghc/compiler/typecheck/TcGenDeriv.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcGenDeriv]{Generating derived instance declarations}
   5
   6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
   7 ``official'' interface to deriving-related things.
   8
   9 This is where we do all the grimy bindings' generation.
  10
  11 \begin{code}
  12 module TcGenDeriv (
  13         gen_Bounded_binds,
  14         gen_Enum_binds,
  15         gen_Eq_binds,
  16         gen_Ix_binds,
  17         gen_Ord_binds,
  18         gen_Read_binds,
  19         gen_Show_binds,
  20         gen_tag_n_con_monobind,
  21
  22         con2tag_RDR, tag2con_RDR, maxtag_RDR,
  23
  24         TagThingWanted(..)
  25     ) where
  26
  27 #include "HsVersions.h"
  28
  29 import HsSyn            ( InPat(..), HsExpr(..), MonoBinds(..),
  30                           Match(..), GRHSs(..), Stmt(..), HsLit(..),
  31                           HsBinds(..), HsType(..), HsDoContext(..),
  32                           unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
  33                         )
  34 import RdrHsSyn         ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
  35 import RdrName          ( RdrName, mkUnqual )
  36 import BasicTypes       ( RecFlag(..), Fixity(..), FixityDirection(..)
  37                         , maxPrecedence
  38                         , Boxity(..)
  39                         )
  40 import FieldLabel       ( fieldLabelName )
  41 import DataCon          ( isNullaryDataCon, dataConTag,
  42                           dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
  43                           DataCon,
  44                           dataConFieldLabels )
  45 import Name             ( getOccString, getOccName, getSrcLoc, occNameString,
  46                           occNameUserString, nameRdrName, varName,
  47                           Name, NamedThing(..),
  48                           isDataSymOcc, isSymOcc
  49                         )
  50
  51 import HscTypes         ( FixityEnv, lookupFixity )
  52 import PrelInfo         -- Lots of RdrNames
  53 import SrcLoc           ( generatedSrcLoc, SrcLoc )
  54 import TyCon            ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
  55                           maybeTyConSingleCon, tyConFamilySize
  56                         )
  57 import TcType           ( isUnLiftedType, tcEqType, Type )
  58 import TysPrim          ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
  59                           floatPrimTy, doublePrimTy
  60                         )
  61 import Util             ( mapAccumL, zipEqual, zipWithEqual, isSingleton,
  62                           zipWith3Equal, nOfThem )
  63 import Panic            ( panic, assertPanic )
  64 import Maybes           ( maybeToBool )
  65 import Constants
  66 import List             ( partition, intersperse )
  67 \end{code}
  68
  69 %************************************************************************
  70 %*                                                                      *
  71 \subsection{Generating code, by derivable class}
  72 %*                                                                      *
  73 %************************************************************************
  74
  75 %************************************************************************
  76 %*                                                                      *
  77 \subsubsection{Generating @Eq@ instance declarations}
  78 %*                                                                      *
  79 %************************************************************************
  80
  81 Here are the heuristics for the code we generate for @Eq@:
  82 \begin{itemize}
  83 \item
  84   Let's assume we have a data type with some (possibly zero) nullary
  85   data constructors and some ordinary, non-nullary ones (the rest,
  86   also possibly zero of them).  Here's an example, with both \tr{N}ullary
  87   and \tr{O}rdinary data cons.
  88 \begin{verbatim}
  89 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
  90 \end{verbatim}
  91
  92 \item
  93   For the ordinary constructors (if any), we emit clauses to do The
  94   Usual Thing, e.g.,:
  95
  96 \begin{verbatim}
  97 (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
  98 (==) (O2 a1)       (O2 a2)       = a1 == a2
  99 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
 100 \end{verbatim}
 101
 102   Note: if we're comparing unlifted things, e.g., if \tr{a1} and
 103   \tr{a2} are \tr{Float#}s, then we have to generate
 104 \begin{verbatim}
 105 case (a1 `eqFloat#` a2) of
 106   r -> r
 107 \end{verbatim}
 108   for that particular test.
 109
 110 \item
 111   If there are any nullary constructors, we emit a catch-all clause of
 112   the form:
 113
 114 \begin{verbatim}
 115 (==) a b  = case (con2tag_Foo a) of { a# ->
 116             case (con2tag_Foo b) of { b# ->
 117             case (a# ==# b#)     of {
 118               r -> r
 119             }}}
 120 \end{verbatim}
 121
 122   If there aren't any nullary constructors, we emit a simpler
 123   catch-all:
 124 \begin{verbatim}
 125 (==) a b  = False
 126 \end{verbatim}
 127
 128 \item
 129   For the @(/=)@ method, we normally just use the default method.
 130
 131   If the type is an enumeration type, we could/may/should? generate
 132   special code that calls @con2tag_Foo@, much like for @(==)@ shown
 133   above.
 134
 135 \item
 136   We thought about doing this: If we're also deriving @Ord@ for this
 137   tycon, we generate:
 138 \begin{verbatim}
 139 instance ... Eq (Foo ...) where
 140   (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
 141   (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
 142 \begin{verbatim}
 143   However, that requires that \tr{Ord <whatever>} was put in the context
 144   for the instance decl, which it probably wasn't, so the decls
 145   produced don't get through the typechecker.
 146 \end{itemize}
 147
 148
 149 deriveEq :: RdrName                             -- Class
 150          -> RdrName                             -- Type constructor
 151          -> [ (RdrName, [RdrType]) ]    -- Constructors
 152          -> (RdrContext,                -- Context for the inst decl
 153              [RdrBind],                 -- Binds in the inst decl
 154              [RdrBind])                 -- Extra value bindings outside
 155
 156 deriveEq clas tycon constrs
 157   = (context, [eq_bind, ne_bind], [])
 158   where
 159     context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
 160
 161     ne_bind = mkBind
 162     (nullary_cons, non_nullary_cons) = partition is_nullary constrs
 163     is_nullary (_, args) = null args
 164
 165 \begin{code}
 166 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
 167
 168 gen_Eq_binds tycon
 169   = let
 170         tycon_loc = getSrcLoc tycon
 171         (nullary_cons, nonnullary_cons)
 172            | isNewTyCon tycon = ([], tyConDataCons tycon)
 173            | otherwise        = partition isNullaryDataCon (tyConDataCons tycon)
 174
 175         rest
 176           = if (null nullary_cons) then
 177                 case maybeTyConSingleCon tycon of
 178                   Just _ -> []
 179                   Nothing -> -- if cons don't match, then False
 180                      [([wildPat, wildPat], false_Expr)]
 181             else -- calc. and compare the tags
 182                  [([a_Pat, b_Pat],
 183                     untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
 184                                (genOpApp (HsVar ah_RDR) eqH_Int_RDR (HsVar bh_RDR)))]
 185     in
 186     mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
 187             `AndMonoBinds`
 188     mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
 189         HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
 190   where
 191     ------------------------------------------------------------------
 192     pats_etc data_con
 193       = let
 194             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 195             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 196
 197             data_con_RDR = qual_orig_name data_con
 198             con_arity   = length tys_needed
 199             as_needed   = take con_arity as_RDRs
 200             bs_needed   = take con_arity bs_RDRs
 201             tys_needed  = dataConOrigArgTys data_con
 202         in
 203         ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
 204       where
 205         nested_eq_expr []  [] [] = true_Expr
 206         nested_eq_expr tys as bs
 207           = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
 208           where
 209             nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
 210 \end{code}
 211
 212 %************************************************************************
 213 %*                                                                      *
 214 \subsubsection{Generating @Ord@ instance declarations}
 215 %*                                                                      *
 216 %************************************************************************
 217
 218 For a derived @Ord@, we concentrate our attentions on @compare@
 219 \begin{verbatim}
 220 compare :: a -> a -> Ordering
 221 data Ordering = LT | EQ | GT deriving ()
 222 \end{verbatim}
 223
 224 We will use the same example data type as above:
 225 \begin{verbatim}
 226 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
 227 \end{verbatim}
 228
 229 \begin{itemize}
 230 \item
 231   We do all the other @Ord@ methods with calls to @compare@:
 232 \begin{verbatim}
 233 instance ... (Ord <wurble> <wurble>) where
 234     a <  b  = case (compare a b) of { LT -> True;  EQ -> False; GT -> False }
 235     a <= b  = case (compare a b) of { LT -> True;  EQ -> True;  GT -> False }
 236     a >= b  = case (compare a b) of { LT -> False; EQ -> True;  GT -> True  }
 237     a >  b  = case (compare a b) of { LT -> False; EQ -> False; GT -> True  }
 238
 239     max a b = case (compare a b) of { LT -> b; EQ -> a;  GT -> a }
 240     min a b = case (compare a b) of { LT -> a; EQ -> b;  GT -> b }
 241
 242     -- compare to come...
 243 \end{verbatim}
 244
 245 \item
 246   @compare@ always has two parts.  First, we use the compared
 247   data-constructors' tags to deal with the case of different
 248   constructors:
 249 \begin{verbatim}
 250 compare a b = case (con2tag_Foo a) of { a# ->
 251               case (con2tag_Foo b) of { b# ->
 252               case (a# ==# b#)     of {
 253                True  -> cmp_eq a b
 254                False -> case (a# <# b#) of
 255                          True  -> _LT
 256                          False -> _GT
 257               }}}
 258   where
 259     cmp_eq = ... to come ...
 260 \end{verbatim}
 261
 262 \item
 263   We are only left with the ``help'' function @cmp_eq@, to deal with
 264   comparing data constructors with the same tag.
 265
 266   For the ordinary constructors (if any), we emit the sorta-obvious
 267   compare-style stuff; for our example:
 268 \begin{verbatim}
 269 cmp_eq (O1 a1 b1) (O1 a2 b2)
 270   = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
 271
 272 cmp_eq (O2 a1) (O2 a2)
 273   = compare a1 a2
 274
 275 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
 276   = case (compare a1 a2) of {
 277       LT -> LT;
 278       GT -> GT;
 279       EQ -> case compare b1 b2 of {
 280               LT -> LT;
 281               GT -> GT;
 282               EQ -> compare c1 c2
 283             }
 284     }
 285 \end{verbatim}
 286
 287   Again, we must be careful about unlifted comparisons.  For example,
 288   if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
 289   generate:
 290
 291 \begin{verbatim}
 292 cmp_eq lt eq gt (O2 a1) (O2 a2)
 293   = compareInt# a1 a2
 294   -- or maybe the unfolded equivalent
 295 \end{verbatim}
 296
 297 \item
 298   For the remaining nullary constructors, we already know that the
 299   tags are equal so:
 300 \begin{verbatim}
 301 cmp_eq _ _ = EQ
 302 \end{verbatim}
 303 \end{itemize}
 304
 305 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
 306 JJQC-30-Nov-1997
 307
 308 \begin{code}
 309 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
 310
 311 gen_Ord_binds tycon
 312   = compare     -- `AndMonoBinds` compare
 313                 -- The default declaration in PrelBase handles this
 314   where
 315     tycon_loc = getSrcLoc tycon
 316     --------------------------------------------------------------------
 317     compare = mk_easy_FunMonoBind tycon_loc compare_RDR
 318                 [a_Pat, b_Pat]
 319                 [cmp_eq]
 320             (if maybeToBool (maybeTyConSingleCon tycon) then
 321
 322 --              cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 323 -- Weird.  Was: case (cmp a b) of { LT -> LT; EQ -> EQ; GT -> GT }
 324
 325                 cmp_eq_Expr a_Expr b_Expr
 326              else
 327                 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
 328                   (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
 329                         -- True case; they are equal
 330                         -- If an enumeration type we are done; else
 331                         -- recursively compare their components
 332                     (if isEnumerationTyCon tycon then
 333                         eqTag_Expr
 334                      else
 335 --                      cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
 336 -- Ditto
 337                         cmp_eq_Expr a_Expr b_Expr
 338                     )
 339                         -- False case; they aren't equal
 340                         -- So we need to do a less-than comparison on the tags
 341                     (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
 342
 343     tycon_data_cons = tyConDataCons tycon
 344     (nullary_cons, nonnullary_cons)
 345        | isNewTyCon tycon = ([], tyConDataCons tycon)
 346        | otherwise        = partition isNullaryDataCon tycon_data_cons
 347
 348     cmp_eq =
 349        mk_FunMonoBind tycon_loc
 350                       cmp_eq_RDR
 351                       (if null nonnullary_cons && isSingleton nullary_cons then
 352                            -- catch this specially to avoid warnings
 353                            -- about overlapping patterns from the desugarer.
 354                           let
 355                            data_con     = head nullary_cons
 356                            data_con_RDR = qual_orig_name data_con
 357                            pat          = ConPatIn data_con_RDR []
 358                           in
 359                           [([pat,pat], eqTag_Expr)]
 360                        else
 361                           map pats_etc nonnullary_cons ++
 362                           -- leave out wildcards to silence desugarer.
 363                           (if isSingleton tycon_data_cons then
 364                               []
 365                            else
 366                               [([WildPatIn, WildPatIn], default_rhs)]))
 367       where
 368         pats_etc data_con
 369           = ([con1_pat, con2_pat],
 370              nested_compare_expr tys_needed as_needed bs_needed)
 371           where
 372             con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
 373             con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 374
 375             data_con_RDR = qual_orig_name data_con
 376             con_arity   = length tys_needed
 377             as_needed   = take con_arity as_RDRs
 378             bs_needed   = take con_arity bs_RDRs
 379             tys_needed  = dataConOrigArgTys data_con
 380
 381             nested_compare_expr [ty] [a] [b]
 382               = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
 383
 384             nested_compare_expr (ty:tys) (a:as) (b:bs)
 385               = let eq_expr = nested_compare_expr tys as bs
 386                 in  careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
 387
 388         default_rhs | null nullary_cons = impossible_Expr       -- Keep desugarer from complaining about
 389                                                                 -- inexhaustive patterns
 390                     | otherwise         = eqTag_Expr            -- Some nullary constructors;
 391                                                                 -- Tags are equal, no args => return EQ
 392 \end{code}
 393
 394 %************************************************************************
 395 %*                                                                      *
 396 \subsubsection{Generating @Enum@ instance declarations}
 397 %*                                                                      *
 398 %************************************************************************
 399
 400 @Enum@ can only be derived for enumeration types.  For a type
 401 \begin{verbatim}
 402 data Foo ... = N1 | N2 | ... | Nn
 403 \end{verbatim}
 404
 405 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
 406 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
 407
 408 \begin{verbatim}
 409 instance ... Enum (Foo ...) where
 410     succ x   = toEnum (1 + fromEnum x)
 411     pred x   = toEnum (fromEnum x - 1)
 412
 413     toEnum i = tag2con_Foo i
 414
 415     enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
 416
 417     -- or, really...
 418     enumFrom a
 419       = case con2tag_Foo a of
 420           a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
 421
 422    enumFromThen a b
 423      = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
 424
 425     -- or, really...
 426     enumFromThen a b
 427       = case con2tag_Foo a of { a# ->
 428         case con2tag_Foo b of { b# ->
 429         map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
 430         }}
 431 \end{verbatim}
 432
 433 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
 434
 435 \begin{code}
 436 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
 437
 438 gen_Enum_binds tycon
 439   = succ_enum           `AndMonoBinds`
 440     pred_enum           `AndMonoBinds`
 441     to_enum             `AndMonoBinds`
 442     enum_from           `AndMonoBinds`
 443     enum_from_then      `AndMonoBinds`
 444     from_enum
 445   where
 446     tycon_loc = getSrcLoc tycon
 447     occ_nm    = getOccString tycon
 448
 449     succ_enum
 450       = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
 451         untag_Expr tycon [(a_RDR, ah_RDR)] $
 452         HsIf (HsApp (HsApp (HsVar eq_RDR)
 453                            (HsVar (maxtag_RDR tycon)))
 454                            (mk_easy_App mkInt_RDR [ah_RDR]))
 455              (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
 456              (HsApp (HsVar (tag2con_RDR tycon))
 457                     (HsApp (HsApp (HsVar plus_RDR)
 458                                   (mk_easy_App mkInt_RDR [ah_RDR]))
 459                            (HsLit (HsInt 1))))
 460              tycon_loc
 461
 462     pred_enum
 463       = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
 464         untag_Expr tycon [(a_RDR, ah_RDR)] $
 465         HsIf (HsApp (HsApp (HsVar eq_RDR) (HsLit (HsInt 0)))
 466                     (mk_easy_App mkInt_RDR [ah_RDR]))
 467              (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
 468              (HsApp (HsVar (tag2con_RDR tycon))
 469                            (HsApp (HsApp (HsVar plus_RDR)
 470                                          (mk_easy_App mkInt_RDR [ah_RDR]))
 471                                   (HsLit (HsInt (-1)))))
 472              tycon_loc
 473
 474     to_enum
 475       = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
 476         HsIf (HsApp (HsApp
 477                     (HsVar and_RDR)
 478                     (HsApp (HsApp (HsVar ge_RDR)
 479                                   (HsVar a_RDR))
 480                                   (HsLit (HsInt 0))))
 481                     (HsApp (HsApp (HsVar le_RDR)
 482                                   (HsVar a_RDR))
 483                                   (HsVar (maxtag_RDR tycon))))
 484              (mk_easy_App (tag2con_RDR tycon) [a_RDR])
 485              (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
 486              tycon_loc
 487
 488     enum_from
 489       = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
 490           untag_Expr tycon [(a_RDR, ah_RDR)] $
 491           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 492             HsPar (enum_from_to_Expr
 493                     (mk_easy_App mkInt_RDR [ah_RDR])
 494                     (HsVar (maxtag_RDR tycon)))
 495
 496     enum_from_then
 497       = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
 498           untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
 499           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 500             HsPar (enum_from_then_to_Expr
 501                     (mk_easy_App mkInt_RDR [ah_RDR])
 502                     (mk_easy_App mkInt_RDR [bh_RDR])
 503                     (HsIf  (HsApp (HsApp (HsVar gt_RDR)
 504                                          (mk_easy_App mkInt_RDR [ah_RDR]))
 505                                          (mk_easy_App mkInt_RDR [bh_RDR]))
 506                            (HsLit (HsInt 0))
 507                            (HsVar (maxtag_RDR tycon))
 508                            tycon_loc))
 509
 510     from_enum
 511       = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
 512           untag_Expr tycon [(a_RDR, ah_RDR)] $
 513           (mk_easy_App mkInt_RDR [ah_RDR])
 514 \end{code}
 515
 516 %************************************************************************
 517 %*                                                                      *
 518 \subsubsection{Generating @Bounded@ instance declarations}
 519 %*                                                                      *
 520 %************************************************************************
 521
 522 \begin{code}
 523 gen_Bounded_binds tycon
 524   = if isEnumerationTyCon tycon then
 525         min_bound_enum `AndMonoBinds` max_bound_enum
 526     else
 527         ASSERT(isSingleton data_cons)
 528         min_bound_1con `AndMonoBinds` max_bound_1con
 529   where
 530     data_cons = tyConDataCons tycon
 531     tycon_loc = getSrcLoc tycon
 532
 533     ----- enum-flavored: ---------------------------
 534     min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
 535     max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
 536
 537     data_con_1    = head data_cons
 538     data_con_N    = last data_cons
 539     data_con_1_RDR = qual_orig_name data_con_1
 540     data_con_N_RDR = qual_orig_name data_con_N
 541
 542     ----- single-constructor-flavored: -------------
 543     arity          = dataConSourceArity data_con_1
 544
 545     min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
 546                      mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
 547     max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
 548                      mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
 549 \end{code}
 550
 551 %************************************************************************
 552 %*                                                                      *
 553 \subsubsection{Generating @Ix@ instance declarations}
 554 %*                                                                      *
 555 %************************************************************************
 556
 557 Deriving @Ix@ is only possible for enumeration types and
 558 single-constructor types.  We deal with them in turn.
 559
 560 For an enumeration type, e.g.,
 561 \begin{verbatim}
 562     data Foo ... = N1 | N2 | ... | Nn
 563 \end{verbatim}
 564 things go not too differently from @Enum@:
 565 \begin{verbatim}
 566 instance ... Ix (Foo ...) where
 567     range (a, b)
 568       = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
 569
 570     -- or, really...
 571     range (a, b)
 572       = case (con2tag_Foo a) of { a# ->
 573         case (con2tag_Foo b) of { b# ->
 574         map tag2con_Foo (enumFromTo (I# a#) (I# b#))
 575         }}
 576
 577     index c@(a, b) d
 578       = if inRange c d
 579         then case (con2tag_Foo d -# con2tag_Foo a) of
 580                r# -> I# r#
 581         else error "Ix.Foo.index: out of range"
 582
 583     inRange (a, b) c
 584       = let
 585             p_tag = con2tag_Foo c
 586         in
 587         p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
 588
 589     -- or, really...
 590     inRange (a, b) c
 591       = case (con2tag_Foo a)   of { a_tag ->
 592         case (con2tag_Foo b)   of { b_tag ->
 593         case (con2tag_Foo c)   of { c_tag ->
 594         if (c_tag >=# a_tag) then
 595           c_tag <=# b_tag
 596         else
 597           False
 598         }}}
 599 \end{verbatim}
 600 (modulo suitable case-ification to handle the unlifted tags)
 601
 602 For a single-constructor type (NB: this includes all tuples), e.g.,
 603 \begin{verbatim}
 604     data Foo ... = MkFoo a b Int Double c c
 605 \end{verbatim}
 606 we follow the scheme given in Figure~19 of the Haskell~1.2 report
 607 (p.~147).
 608
 609 \begin{code}
 610 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
 611
 612 gen_Ix_binds tycon
 613   = if isEnumerationTyCon tycon
 614     then enum_ixes
 615     else single_con_ixes
 616   where
 617     tycon_str = getOccString tycon
 618     tycon_loc = getSrcLoc tycon
 619
 620     --------------------------------------------------------------
 621     enum_ixes = enum_range `AndMonoBinds`
 622                 enum_index `AndMonoBinds` enum_inRange
 623
 624     enum_range
 625       = mk_easy_FunMonoBind tycon_loc range_RDR
 626                 [TuplePatIn [a_Pat, b_Pat] Boxed] [] $
 627           untag_Expr tycon [(a_RDR, ah_RDR)] $
 628           untag_Expr tycon [(b_RDR, bh_RDR)] $
 629           HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
 630               HsPar (enum_from_to_Expr
 631                         (mk_easy_App mkInt_RDR [ah_RDR])
 632                         (mk_easy_App mkInt_RDR [bh_RDR]))
 633
 634     enum_index
 635       = mk_easy_FunMonoBind tycon_loc index_RDR
 636                 [AsPatIn c_RDR (TuplePatIn [a_Pat, wildPat] Boxed),
 637                                 d_Pat] [] (
 638         HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
 639            untag_Expr tycon [(a_RDR, ah_RDR)] (
 640            untag_Expr tycon [(d_RDR, dh_RDR)] (
 641            let
 642                 rhs = mk_easy_App mkInt_RDR [c_RDR]
 643            in
 644            HsCase
 645              (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
 646              [mkSimpleMatch [VarPatIn c_RDR] rhs placeHolderType tycon_loc]
 647              tycon_loc
 648            ))
 649         ) {-else-} (
 650            HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
 651         )
 652         tycon_loc)
 653
 654     enum_inRange
 655       = mk_easy_FunMonoBind tycon_loc inRange_RDR
 656           [TuplePatIn [a_Pat, b_Pat] Boxed, c_Pat] [] (
 657           untag_Expr tycon [(a_RDR, ah_RDR)] (
 658           untag_Expr tycon [(b_RDR, bh_RDR)] (
 659           untag_Expr tycon [(c_RDR, ch_RDR)] (
 660           HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
 661              (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
 662           ) {-else-} (
 663              false_Expr
 664           ) tycon_loc))))
 665
 666     --------------------------------------------------------------
 667     single_con_ixes
 668       = single_con_range `AndMonoBinds`
 669         single_con_index `AndMonoBinds`
 670         single_con_inRange
 671
 672     data_con
 673       = case maybeTyConSingleCon tycon of -- just checking...
 674           Nothing -> panic "get_Ix_binds"
 675           Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
 676                          error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
 677                      else
 678                          dc
 679
 680     con_arity    = dataConSourceArity data_con
 681     data_con_RDR = qual_orig_name data_con
 682
 683     as_needed = take con_arity as_RDRs
 684     bs_needed = take con_arity bs_RDRs
 685     cs_needed = take con_arity cs_RDRs
 686
 687     con_pat  xs  = ConPatIn data_con_RDR (map VarPatIn xs)
 688     con_expr     = mk_easy_App data_con_RDR cs_needed
 689
 690     --------------------------------------------------------------
 691     single_con_range
 692       = mk_easy_FunMonoBind tycon_loc range_RDR
 693           [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed] [] $
 694         HsDo ListComp stmts tycon_loc
 695       where
 696         stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
 697                 ++
 698                 [ResultStmt con_expr tycon_loc]
 699
 700         mk_qual a b c = BindStmt (VarPatIn c)
 701                                  (HsApp (HsVar range_RDR)
 702                                         (ExplicitTuple [HsVar a, HsVar b] Boxed))
 703                                  tycon_loc
 704
 705     ----------------
 706     single_con_index
 707       = mk_easy_FunMonoBind tycon_loc index_RDR
 708                 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
 709                  con_pat cs_needed] [range_size] (
 710         foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
 711       where
 712         mk_index multiply_by (l, u, i)
 713           = genOpApp (
 714                (HsApp (HsApp (HsVar index_RDR)
 715                       (ExplicitTuple [HsVar l, HsVar u] Boxed)) (HsVar i))
 716            ) plus_RDR (
 717                 genOpApp (
 718                     (HsApp (HsVar rangeSize_RDR)
 719                            (ExplicitTuple [HsVar l, HsVar u] Boxed))
 720                 ) times_RDR multiply_by
 721            )
 722
 723         range_size
 724           = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
 725                         [TuplePatIn [a_Pat, b_Pat] Boxed] [] (
 726                 genOpApp (
 727                     (HsApp (HsApp (HsVar index_RDR)
 728                            (ExplicitTuple [a_Expr, b_Expr] Boxed)) b_Expr)
 729                 ) plus_RDR (HsLit (HsInt 1)))
 730
 731     ------------------
 732     single_con_inRange
 733       = mk_easy_FunMonoBind tycon_loc inRange_RDR
 734                 [TuplePatIn [con_pat as_needed, con_pat bs_needed] Boxed,
 735                  con_pat cs_needed]
 736                            [] (
 737           foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
 738       where
 739         in_range a b c = HsApp (HsApp (HsVar inRange_RDR)
 740                                       (ExplicitTuple [HsVar a, HsVar b] Boxed))
 741                                (HsVar c)
 742 \end{code}
 743
 744 %************************************************************************
 745 %*                                                                      *
 746 \subsubsection{Generating @Read@ instance declarations}
 747 %*                                                                      *
 748 %************************************************************************
 749
 750 \begin{code}
 751 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
 752
 753 gen_Read_binds get_fixity tycon
 754   = reads_prec `AndMonoBinds` read_list
 755   where
 756     tycon_loc = getSrcLoc tycon
 757     -----------------------------------------------------------------------
 758     read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
 759                   (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
 760     -----------------------------------------------------------------------
 761     reads_prec
 762       = let
 763             read_con_comprehensions
 764               = map read_con (tyConDataCons tycon)
 765         in
 766         mk_easy_FunMonoBind tycon_loc readsPrec_RDR [zz_a_Pat, b_Pat] [] (
 767               foldr1 append_Expr read_con_comprehensions
 768         )
 769       where
 770         read_con data_con   -- note: "b" is the string being "read"
 771           = HsApp (
 772               readParen_Expr read_paren_arg $ HsPar $
 773                  HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
 774                         HsDo ListComp stmts tycon_loc)
 775               ) (HsVar b_RDR)
 776          where
 777            data_con_RDR = qual_orig_name data_con
 778            data_con_str = occNameUserString (getOccName data_con)
 779            con_arity    = dataConSourceArity data_con
 780            con_expr     = mk_easy_App data_con_RDR as_needed
 781            nullary_con  = con_arity == 0
 782            labels       = dataConFieldLabels data_con
 783            lab_fields   = length labels
 784            dc_nm        = getName data_con
 785            is_infix     = isDataSymOcc (getOccName dc_nm)
 786
 787            as_needed    = take con_arity as_RDRs
 788            bs_needed
 789              | is_infix        = take (1 + con_arity) bs_RDRs
 790              | lab_fields == 0 = take con_arity bs_RDRs
 791              | otherwise       = take (4*lab_fields + 1) bs_RDRs
 792                                   -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
 793
 794            (as1:as2:_)     = as_needed
 795            (bs1:bs2:bs3:_) = bs_needed
 796
 797            con_qual
 798              | not is_infix =
 799                  BindStmt
 800                   (TuplePatIn [LitPatIn (mkHsString data_con_str), d_Pat] Boxed)
 801                   (HsApp (HsVar lex_RDR) c_Expr)
 802                   tycon_loc
 803              | otherwise    =
 804                  BindStmt
 805                   (TuplePatIn [LitPatIn (mkHsString data_con_str), VarPatIn bs2] Boxed)
 806                   (HsApp (HsVar lex_RDR) (HsVar bs1))
 807                   tycon_loc
 808
 809
 810            str_qual str res draw_from =
 811                BindStmt
 812                   (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
 813                   (HsApp (HsVar lex_RDR) draw_from)
 814                   tycon_loc
 815
 816            str_qual_paren str res draw_from =
 817                BindStmt
 818                   (TuplePatIn [LitPatIn (mkHsString str), VarPatIn res] Boxed)
 819                   (HsApp (readParen_Expr true_Expr (HsVar lex_RDR)) draw_from)
 820                   tycon_loc
 821
 822            read_label f = [rd_lab, str_qual "="]
 823                             -- There might be spaces between the label and '='
 824                 where
 825                   rd_lab
 826                    | is_op      = str_qual_paren nm
 827                    | otherwise  = str_qual nm
 828
 829                   occ_nm  = getOccName (fieldLabelName f)
 830                   is_op   = isSymOcc occ_nm
 831                   nm      = occNameUserString occ_nm
 832
 833            field_quals
 834               | is_infix  =
 835                   snd (mapAccumL mk_qual_infix
 836                                  c_Expr
 837                                  [ (mk_read_qual lp as1, bs1, bs2)
 838                                  , (mk_read_qual rp as2, bs3, bs3)
 839                                  ])
 840               | lab_fields == 0 =  -- common case.
 841                   snd (mapAccumL mk_qual
 842                                  d_Expr
 843                                  (zipWithEqual "as_needed"
 844                                                (\ con_field draw_from -> (mk_read_qual 10 con_field,
 845                                                                           draw_from))
 846                                                 as_needed bs_needed))
 847               | otherwise =
 848                   snd $
 849                   mapAccumL mk_qual d_Expr
 850                         (zipEqual "bs_needed"
 851                            ((str_qual "{":
 852                              concat (
 853                              intersperse [str_qual ","] $
 854                              zipWithEqual
 855                                 "field_quals"
 856                                 (\ as b -> as ++ [b])
 857                                     -- The labels
 858                                 (map read_label labels)
 859                                     -- The fields
 860                                 (map (mk_read_qual 10) as_needed))) ++ [str_qual "}"])
 861                             bs_needed)
 862
 863            mk_qual_infix draw_from (f, str_left, str_left2) =
 864                 (HsVar str_left2,       -- what to draw from down the line...
 865                  f str_left draw_from)
 866
 867            mk_qual draw_from (f, str_left) =
 868                 (HsVar str_left,        -- what to draw from down the line...
 869                  f str_left draw_from)
 870
 871            mk_read_qual p con_field res draw_from =
 872               BindStmt
 873                  (TuplePatIn [VarPatIn con_field, VarPatIn res] Boxed)
 874                  (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt p))) draw_from)
 875                  tycon_loc
 876
 877            result_expr = ExplicitTuple [con_expr, if null bs_needed
 878                                                     then d_Expr
 879                                                     else HsVar (last bs_needed)] Boxed
 880
 881            [lp,rp] = getLRPrecs is_infix get_fixity dc_nm
 882
 883            quals
 884             | is_infix  = let (h:t) = field_quals in (h:con_qual:t)
 885             | otherwise = con_qual:field_quals
 886
 887            stmts = quals ++ [ResultStmt result_expr tycon_loc]
 888
 889             {-
 890               c.f. Figure 18 in Haskell 1.1 report.
 891             -}
 892            paren_prec_limit
 893              | not is_infix  = defaultPrecedence
 894              | otherwise     = getPrecedence get_fixity dc_nm
 895
 896            read_paren_arg   -- parens depend on precedence...
 897             | nullary_con  = false_Expr -- it's optional.
 898             | otherwise    = HsPar (genOpApp zz_a_Expr gt_RDR (HsLit (HsInt paren_prec_limit)))
 899 \end{code}
 900
 901 %************************************************************************
 902 %*                                                                      *
 903 \subsubsection{Generating @Show@ instance declarations}
 904 %*                                                                      *
 905 %************************************************************************
 906
 907 \begin{code}
 908 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
 909
 910 gen_Show_binds get_fixity tycon
 911   = shows_prec `AndMonoBinds` show_list
 912   where
 913     tycon_loc = getSrcLoc tycon
 914     -----------------------------------------------------------------------
 915     show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
 916                   (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
 917     -----------------------------------------------------------------------
 918     shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
 919       where
 920         pats_etc data_con
 921           | nullary_con =  -- skip the showParen junk...
 922              ASSERT(null bs_needed)
 923              ([wildPat, con_pat], show_con)
 924           | otherwise   =
 925              ([a_Pat, con_pat],
 926                   showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt paren_prec_limit))))
 927                                  (HsPar (nested_compose_Expr show_thingies)))
 928             where
 929              data_con_RDR = qual_orig_name data_con
 930              con_arity    = dataConSourceArity data_con
 931              bs_needed    = take con_arity bs_RDRs
 932              con_pat      = ConPatIn data_con_RDR (map VarPatIn bs_needed)
 933              nullary_con  = con_arity == 0
 934              labels       = dataConFieldLabels data_con
 935              lab_fields   = length labels
 936
 937              dc_nm          = getName data_con
 938              dc_occ_nm      = getOccName data_con
 939              dc_occ_nm_str  = occNameUserString dc_occ_nm
 940
 941              is_infix     = isDataSymOcc dc_occ_nm
 942
 943
 944              show_con
 945                | is_infix  = mk_showString_app (' ':dc_occ_nm_str)
 946                | otherwise = mk_showString_app (dc_occ_nm_str ++ space_ocurly_maybe)
 947                  where
 948                   space_ocurly_maybe
 949                     | nullary_con     = ""
 950                     | lab_fields == 0 = " "
 951                     | otherwise       = "{"
 952
 953
 954              show_all con fs@(x:xs)
 955                 | is_infix  = x:con:xs
 956                 | otherwise =
 957                   let
 958                     ccurly_maybe
 959                       | lab_fields > 0  = [mk_showString_app "}"]
 960                       | otherwise       = []
 961                   in
 962                   con:fs ++ ccurly_maybe
 963
 964              show_thingies = show_all show_con real_show_thingies_with_labs
 965
 966              show_label l = mk_showString_app (the_name ++ "=")
 967                  where
 968                    occ_nm   = getOccName (fieldLabelName l)
 969                     -- legal, but rare.
 970                    is_op    = isSymOcc occ_nm
 971                    the_name
 972                      | is_op     = '(':nm ++ ")"
 973                      | otherwise = nm
 974
 975                    nm       = occNameUserString occ_nm
 976
 977
 978              mk_showString_app str = HsApp (HsVar showString_RDR)
 979                                            (HsLit (mkHsString str))
 980
 981              prec_cons = getLRPrecs is_infix get_fixity dc_nm
 982
 983              real_show_thingies
 984                 | is_infix  =
 985                      [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt p))) (HsVar b)
 986                      | (p,b) <- zip prec_cons bs_needed ]
 987                 | otherwise =
 988                      [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
 989                      | b <- bs_needed ]
 990
 991              real_show_thingies_with_labs
 992                 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
 993                 | otherwise       = --Assumption: no of fields == no of labelled fields
 994                                      --            (and in same order)
 995                     concat $
 996                     intersperse ([mk_showString_app ","]) $ -- Using SLIT()s containing ,s spells trouble.
 997                     zipWithEqual "gen_Show_binds"
 998                                  (\ a b -> [a,b])
 999                                  (map show_label labels)
1000                                  real_show_thingies
1001
1002               {-
1003                 c.f. Figure 16 and 17 in Haskell 1.1 report
1004               -}
1005              paren_prec_limit
1006                 | not is_infix = defaultPrecedence + 1
1007                 | otherwise    = getPrecedence get_fixity dc_nm + 1
1008
1009 \end{code}
1010
1011 \begin{code}
1012 getLRPrecs :: Bool -> FixityEnv -> Name -> [Integer]
1013 getLRPrecs is_infix get_fixity nm = [lp, rp]
1014     where
1015      {-
1016         Figuring out the fixities of the arguments to a constructor,
1017         cf. Figures 16-18 in Haskell 1.1 report.
1018      -}
1019      (con_left_assoc, con_right_assoc) = isLRAssoc get_fixity nm
1020      paren_con_prec = getPrecedence get_fixity nm
1021
1022      lp
1023       | not is_infix   = defaultPrecedence + 1
1024       | con_left_assoc = paren_con_prec
1025       | otherwise      = paren_con_prec + 1
1026
1027      rp
1028       | not is_infix    = defaultPrecedence + 1
1029       | con_right_assoc = paren_con_prec
1030       | otherwise       = paren_con_prec + 1
1031
1032 defaultPrecedence :: Integer
1033 defaultPrecedence = fromIntegral maxPrecedence
1034
1035 getPrecedence :: FixityEnv -> Name -> Integer
1036 getPrecedence get_fixity nm
1037    = case lookupFixity get_fixity nm of
1038         Fixity x _ -> fromIntegral x
1039
1040 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1041 isLRAssoc get_fixity nm =
1042      case lookupFixity get_fixity nm of
1043        Fixity _ InfixN -> (False, False)
1044        Fixity _ InfixR -> (False, True)
1045        Fixity _ InfixL -> (True,  False)
1046 \end{code}
1047
1048
1049 %************************************************************************
1050 %*                                                                      *
1051 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1052 %*                                                                      *
1053 %************************************************************************
1054
1055 \begin{verbatim}
1056 data Foo ... = ...
1057
1058 con2tag_Foo :: Foo ... -> Int#
1059 tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
1060 maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
1061 \end{verbatim}
1062
1063 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1064 fiddling around.
1065
1066 \begin{code}
1067 data TagThingWanted
1068   = GenCon2Tag | GenTag2Con | GenMaxTag
1069
1070 gen_tag_n_con_monobind
1071     :: (RdrName,            -- (proto)Name for the thing in question
1072         TyCon,              -- tycon in question
1073         TagThingWanted)
1074     -> RdrNameMonoBinds
1075
1076 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1077   | lots_of_constructors
1078   = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1079         [([VarPatIn a_RDR], HsApp getTag_Expr a_Expr)]
1080
1081   | otherwise
1082   = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
1083
1084   where
1085     lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1086
1087     mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1088     mk_stuff var
1089       = ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
1090       where
1091         pat    = ConPatIn var_RDR (nOfThem (dataConSourceArity var) WildPatIn)
1092         var_RDR = qual_orig_name var
1093
1094 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1095   = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1096         [([ConPatIn mkInt_RDR [VarPatIn a_RDR]],
1097            ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1098                          (HsTyVar (qual_orig_name tycon)))]
1099
1100 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1101   = mk_easy_FunMonoBind (getSrcLoc tycon)
1102                 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1103   where
1104     max_tag =  case (tyConDataCons tycon) of
1105                  data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1106
1107 \end{code}
1108
1109 %************************************************************************
1110 %*                                                                      *
1111 \subsection{Utility bits for generating bindings}
1112 %*                                                                      *
1113 %************************************************************************
1114
1115 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1116 \begin{verbatim}
1117     fun pat1 pat2 ... patN = expr where binds
1118 \end{verbatim}
1119
1120 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1121 multi-clause definitions; it generates:
1122 \begin{verbatim}
1123     fun p1a p1b ... p1N = e1
1124     fun p2a p2b ... p2N = e2
1125     ...
1126     fun pMa pMb ... pMN = eM
1127 \end{verbatim}
1128
1129 \begin{code}
1130 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1131                     -> [RdrNameMonoBinds] -> RdrNameHsExpr
1132                     -> RdrNameMonoBinds
1133
1134 mk_easy_FunMonoBind loc fun pats binds expr
1135   = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1136
1137 mk_easy_Match loc pats binds expr
1138   = mk_match loc pats expr (mkMonoBind (andMonoBindList binds) [] Recursive)
1139         -- The renamer expects everything in its input to be a
1140         -- "recursive" MonoBinds, and it is its job to sort things out
1141         -- from there.
1142
1143 mk_FunMonoBind  :: SrcLoc -> RdrName
1144                 -> [([RdrNamePat], RdrNameHsExpr)]
1145                 -> RdrNameMonoBinds
1146
1147 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1148 mk_FunMonoBind loc fun pats_and_exprs
1149   = FunMonoBind fun False{-not infix-}
1150                 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1151                 loc
1152
1153 mk_match loc pats expr binds
1154   = Match (map paren pats) Nothing
1155           (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1156   where
1157     paren p@(VarPatIn _) = p
1158     paren other_p        = ParPatIn other_p
1159 \end{code}
1160
1161 \begin{code}
1162 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1163 \end{code}
1164
1165 ToDo: Better SrcLocs.
1166
1167 \begin{code}
1168 compare_gen_Case ::
1169           RdrName
1170           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1171           -> RdrNameHsExpr -> RdrNameHsExpr
1172           -> RdrNameHsExpr
1173 careful_compare_Case :: -- checks for primitive types...
1174           Type
1175           -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1176           -> RdrNameHsExpr -> RdrNameHsExpr
1177           -> RdrNameHsExpr
1178
1179 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1180         -- Was: compare_gen_Case cmp_eq_RDR
1181
1182 compare_gen_Case fun lt eq gt a b
1183   = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1184       [mkSimpleMatch [ConPatIn ltTag_RDR []] lt placeHolderType generatedSrcLoc,
1185        mkSimpleMatch [ConPatIn eqTag_RDR []] eq placeHolderType generatedSrcLoc,
1186        mkSimpleMatch [ConPatIn gtTag_RDR []] gt placeHolderType generatedSrcLoc]
1187       generatedSrcLoc
1188
1189 careful_compare_Case ty lt eq gt a b
1190   | not (isUnLiftedType ty) =
1191        compare_gen_Case compare_RDR lt eq gt a b
1192   | otherwise               =
1193          -- we have to do something special for primitive things...
1194        HsIf (genOpApp a relevant_eq_op b)
1195             eq
1196             (HsIf (genOpApp a relevant_lt_op b) lt gt generatedSrcLoc)
1197             generatedSrcLoc
1198   where
1199     relevant_eq_op = assoc_ty_id eq_op_tbl ty
1200     relevant_lt_op = assoc_ty_id lt_op_tbl ty
1201
1202 assoc_ty_id tyids ty
1203   = if null res then panic "assoc_ty"
1204     else head res
1205   where
1206     res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1207
1208 eq_op_tbl =
1209     [(charPrimTy,       eqH_Char_RDR)
1210     ,(intPrimTy,        eqH_Int_RDR)
1211     ,(wordPrimTy,       eqH_Word_RDR)
1212     ,(addrPrimTy,       eqH_Addr_RDR)
1213     ,(floatPrimTy,      eqH_Float_RDR)
1214     ,(doublePrimTy,     eqH_Double_RDR)
1215     ]
1216
1217 lt_op_tbl =
1218     [(charPrimTy,       ltH_Char_RDR)
1219     ,(intPrimTy,        ltH_Int_RDR)
1220     ,(wordPrimTy,       ltH_Word_RDR)
1221     ,(addrPrimTy,       ltH_Addr_RDR)
1222     ,(floatPrimTy,      ltH_Float_RDR)
1223     ,(doublePrimTy,     ltH_Double_RDR)
1224     ]
1225
1226 -----------------------------------------------------------------------
1227
1228 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1229
1230 and_Expr    a b = genOpApp a and_RDR    b
1231 append_Expr a b = genOpApp a append_RDR b
1232
1233 -----------------------------------------------------------------------
1234
1235 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1236 eq_Expr ty a b = genOpApp a eq_op b
1237  where
1238    eq_op
1239     | not (isUnLiftedType ty) = eq_RDR
1240     | otherwise               =
1241          -- we have to do something special for primitive things...
1242         assoc_ty_id eq_op_tbl ty
1243
1244 \end{code}
1245
1246 \begin{code}
1247 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1248 untag_Expr tycon [] expr = expr
1249 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1250   = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1251       [mkSimpleMatch [VarPatIn put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1252       generatedSrcLoc
1253
1254 cmp_tags_Expr :: RdrName                -- Comparison op
1255              -> RdrName -> RdrName      -- Things to compare
1256              -> RdrNameHsExpr           -- What to return if true
1257              -> RdrNameHsExpr           -- What to return if false
1258              -> RdrNameHsExpr
1259
1260 cmp_tags_Expr op a b true_case false_case
1261   = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1262
1263 enum_from_to_Expr
1264         :: RdrNameHsExpr -> RdrNameHsExpr
1265         -> RdrNameHsExpr
1266 enum_from_then_to_Expr
1267         :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1268         -> RdrNameHsExpr
1269
1270 enum_from_to_Expr      f   t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1271 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1272
1273 showParen_Expr, readParen_Expr
1274         :: RdrNameHsExpr -> RdrNameHsExpr
1275         -> RdrNameHsExpr
1276
1277 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1278 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1279
1280 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1281
1282 nested_compose_Expr [e] = parenify e
1283 nested_compose_Expr (e:es)
1284   = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1285
1286 -- impossible_Expr is used in case RHSs that should never happen.
1287 -- We generate these to keep the desugarer from complaining that they *might* happen!
1288 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1289
1290 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1291 -- method. It is currently only used by Enum.{succ,pred}
1292 illegal_Expr meth tp msg =
1293    HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ (meth ++ '{':tp ++ "}: " ++ msg))))
1294
1295 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1296 -- to include the value of a_RDR in the error string.
1297 illegal_toEnum_tag tp maxtag =
1298    HsApp (HsVar error_RDR)
1299          (HsApp (HsApp (HsVar append_RDR)
1300                        (HsLit (HsString (_PK_ ("toEnum{" ++ tp ++ "}: tag (")))))
1301                        (HsApp (HsApp (HsApp
1302                            (HsVar showsPrec_RDR)
1303                            (HsLit (HsInt 0)))
1304                            (HsVar a_RDR))
1305                            (HsApp (HsApp
1306                                (HsVar append_RDR)
1307                                (HsLit (HsString (_PK_ ") is outside of enumeration's range (0,"))))
1308                                (HsApp (HsApp (HsApp
1309                                         (HsVar showsPrec_RDR)
1310                                         (HsLit (HsInt 0)))
1311                                         (HsVar maxtag))
1312                                         (HsLit (HsString (_PK_ ")")))))))
1313
1314 parenify e@(HsVar _) = e
1315 parenify e           = HsPar e
1316
1317 -- genOpApp wraps brackets round the operator application, so that the
1318 -- renamer won't subsequently try to re-associate it.
1319 -- For some reason the renamer doesn't reassociate it right, and I can't
1320 -- be bothered to find out why just now.
1321
1322 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1323 \end{code}
1324
1325 \begin{code}
1326 qual_orig_name n = nameRdrName (getName n)
1327 varUnqual n      = mkUnqual varName n
1328
1329 zz_a_RDR        = varUnqual SLIT("_a")
1330 a_RDR           = varUnqual SLIT("a")
1331 b_RDR           = varUnqual SLIT("b")
1332 c_RDR           = varUnqual SLIT("c")
1333 d_RDR           = varUnqual SLIT("d")
1334 ah_RDR          = varUnqual SLIT("a#")
1335 bh_RDR          = varUnqual SLIT("b#")
1336 ch_RDR          = varUnqual SLIT("c#")
1337 dh_RDR          = varUnqual SLIT("d#")
1338 cmp_eq_RDR      = varUnqual SLIT("cmp_eq")
1339 rangeSize_RDR   = varUnqual SLIT("rangeSize")
1340
1341 as_RDRs         = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1342 bs_RDRs         = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1343 cs_RDRs         = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1344
1345 mkHsString s = HsString (_PK_ s)
1346
1347 zz_a_Expr       = HsVar zz_a_RDR
1348 a_Expr          = HsVar a_RDR
1349 b_Expr          = HsVar b_RDR
1350 c_Expr          = HsVar c_RDR
1351 d_Expr          = HsVar d_RDR
1352 ltTag_Expr      = HsVar ltTag_RDR
1353 eqTag_Expr      = HsVar eqTag_RDR
1354 gtTag_Expr      = HsVar gtTag_RDR
1355 false_Expr      = HsVar false_RDR
1356 true_Expr       = HsVar true_RDR
1357
1358 getTag_Expr     = HsVar getTag_RDR
1359 tagToEnum_Expr  = HsVar tagToEnumH_RDR
1360 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1361
1362 wildPat         = WildPatIn
1363 zz_a_Pat        = VarPatIn zz_a_RDR
1364 a_Pat           = VarPatIn a_RDR
1365 b_Pat           = VarPatIn b_RDR
1366 c_Pat           = VarPatIn c_RDR
1367 d_Pat           = VarPatIn d_RDR
1368
1369 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1370
1371 con2tag_RDR tycon = varUnqual (_PK_ ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1372 tag2con_RDR tycon = varUnqual (_PK_ ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1373 maxtag_RDR tycon  = varUnqual (_PK_ ("maxtag_"  ++ occNameString (getOccName tycon) ++ "#"))
1374 \end{code}