TcGenDeriv.hs 101 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
{-
2
    %
Austin Seipp's avatar
Austin Seipp committed
3 4 5
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

6 7

TcGenDeriv: Generating derived instance declarations
8 9 10 11 12

This module is nominally ``subordinate'' to @TcDeriv@, which is the
``official'' interface to deriving-related things.

This is where we do all the grimy bindings' generation.
Austin Seipp's avatar
Austin Seipp committed
13
-}
14

15
{-# LANGUAGE CPP, ScopedTypeVariables #-}
16
{-# LANGUAGE FlexibleContexts #-}
17

18
module TcGenDeriv (
19 20
        BagDerivStuff, DerivStuff(..),

21 22
        canDeriveAnyClass,
        genDerivedBinds,
23 24
        FFoldType(..), functorLikeTraverse,
        deepSubtypesContaining, foldDataConArgs,
25
        mkCoerceClassMethEqn,
26
        gen_Newtype_binds,
27
        genAuxBinds,
Ryan Scott's avatar
Ryan Scott committed
28
        ordOpTbl, boxConTbl, litConTbl,
cactus's avatar
cactus committed
29
        mkRdrFunBind
30
    ) where
31

32
#include "HsVersions.h"
33

34
import HsSyn
35 36 37 38
import RdrName
import BasicTypes
import DataCon
import Name
niteria's avatar
niteria committed
39 40
import Fingerprint
import Encoding
41

42
import DynFlags
43
import PrelInfo
44
import FamInstEnv( FamInst )
45
import MkCore ( eRROR_ID )
46
import PrelNames hiding (error_RDR)
Ryan Scott's avatar
Ryan Scott committed
47 48 49
import THNames
import Module ( moduleName, moduleNameString
              , modulePackageKey, packageKeyString )
50
import MkId ( coerceId )
51 52 53 54 55 56
import PrimOp
import SrcLoc
import TyCon
import TcType
import TysPrim
import TysWiredIn
57
import Type
58
import Class
59 60
import TypeRep
import VarSet
61
import VarEnv
62
import State
63
import Util
64
import Var
65
#if __GLASGOW_HASKELL__ < 709
66
import MonadUtils
67
#endif
68
import Outputable
69
import Lexeme
70
import FastString
71
import Pair
72
import Bag
73
import TcEnv (InstInfo)
74
import StaticFlags( opt_PprStyle_Debug )
75

76 77 78
import ListSetOps ( assocMaybe )
import Data.List  ( partition, intersperse )
import Data.Maybe ( isNothing )
79

80 81
type BagDerivStuff = Bag DerivStuff

82
data AuxBindSpec
83 84 85
  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
  | DerivTag2Con TyCon  -- ...ditto tag2Con
  | DerivMaxTag  TyCon  -- ...and maxTag
86
  deriving( Eq )
87 88 89
  -- All these generate ZERO-BASED tag operations
  -- I.e first constructor has tag 0

90 91 92
data DerivStuff     -- Please add this auxiliary stuff
  = DerivAuxBind AuxBindSpec

93
  -- Generics
94
  | DerivTyCon TyCon                   -- New data types
Simon Peyton Jones's avatar
Simon Peyton Jones committed
95
  | DerivFamInst FamInst               -- New type family instances
96

97
  -- New top-level auxiliary bindings
98
  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
dreixel's avatar
dreixel committed
99
  | DerivInst (InstInfo RdrName)                -- New, auxiliary instances
100

Austin Seipp's avatar
Austin Seipp committed
101 102 103
{-
************************************************************************
*                                                                      *
104
                Top level function
Austin Seipp's avatar
Austin Seipp committed
105 106 107
*                                                                      *
************************************************************************
-}
108

109
genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
Simon Peyton Jones's avatar
Simon Peyton Jones committed
110 111 112
                -> ( LHsBinds RdrName  -- The method bindings of the instance declaration
                   , BagDerivStuff)    -- Specifies extra top-level declarations needed
                                       -- to support the instance declaration
113 114 115 116 117
genDerivedBinds dflags fix_env clas loc tycon
  | Just gen_fn <- assocMaybe gen_list (getUnique clas)
  = gen_fn loc tycon

  | otherwise
118 119 120 121 122 123
  -- Deriving any class simply means giving an empty instance, so no
  -- bindings have to be generated.
  = ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
           , ppr "genDerivStuff: bad derived class" <+> ppr clas )
    (emptyBag, emptyBag)

124 125 126 127 128 129 130 131 132 133 134 135
  where
    gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
    gen_list = [ (eqClassKey,          gen_Eq_binds)
               , (ordClassKey,         gen_Ord_binds)
               , (enumClassKey,        gen_Enum_binds)
               , (boundedClassKey,     gen_Bounded_binds)
               , (ixClassKey,          gen_Ix_binds)
               , (showClassKey,        gen_Show_binds fix_env)
               , (readClassKey,        gen_Read_binds fix_env)
               , (dataClassKey,        gen_Data_binds dflags)
               , (functorClassKey,     gen_Functor_binds)
               , (foldableClassKey,    gen_Foldable_binds)
Ryan Scott's avatar
Ryan Scott committed
136 137
               , (traversableClassKey, gen_Traversable_binds)
               , (liftClassKey,        gen_Lift_binds) ]
138 139 140 141 142 143 144 145 146 147 148 149 150

-- Nothing: we can (try to) derive it via Generics
-- Just s:  we can't, reason s
canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
canDeriveAnyClass dflags _tycon clas =
  let b `orElse` s = if b then Nothing else Just (ptext (sLit s))
      Just m  <> _ = Just m
      Nothing <> n = n
  -- We can derive a given class for a given tycon via Generics iff
  in  -- 1) The class is not a "standard" class (like Show, Functor, etc.)
        (not (getUnique clas `elem` standardClassKeys) `orElse` "")
      -- 2) Opt_DeriveAnyClass is on
     <> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass")
151

Austin Seipp's avatar
Austin Seipp committed
152 153 154
{-
************************************************************************
*                                                                      *
155
                Eq instances
Austin Seipp's avatar
Austin Seipp committed
156 157
*                                                                      *
************************************************************************
158

159 160 161 162 163 164 165 166 167
Here are the heuristics for the code we generate for @Eq@. Let's
assume we have a data type with some (possibly zero) nullary data
constructors and some ordinary, non-nullary ones (the rest, also
possibly zero of them).  Here's an example, with both \tr{N}ullary and
\tr{O}rdinary data cons.

  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...

* For the ordinary constructors (if any), we emit clauses to do The
168 169
  Usual Thing, e.g.,:

170 171 172 173 174 175 176
    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2
    (==) (O2 a1)       (O2 a2)       = a1 == a2
    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2

  Note: if we're comparing unlifted things, e.g., if 'a1' and
  'a2' are Float#s, then we have to generate
       case (a1 `eqFloat#` a2) of r -> r
177 178
  for that particular test.

179 180
* If there are a lot of (more than en) nullary constructors, we emit a
  catch-all clause of the form:
181

182 183 184 185
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
186

187 188 189 190 191
  If con2tag gets inlined this leads to join point stuff, so
  it's better to use regular pattern matching if there aren't too
  many nullary constructors.  "Ten" is arbitrary, of course

* If there aren't any nullary constructors, we emit a simpler
192 193
  catch-all:

194
     (==) a b  = False
195

196
* For the @(/=)@ method, we normally just use the default method.
197 198 199 200
  If the type is an enumeration type, we could/may/should? generate
  special code that calls @con2tag_Foo@, much like for @(==)@ shown
  above.

201 202 203 204 205 206 207 208
We thought about doing this: If we're also deriving 'Ord' for this
tycon, we generate:
  instance ... Eq (Foo ...) where
    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
However, that requires that (Ord <whatever>) was put in the context
for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
Austin Seipp's avatar
Austin Seipp committed
209
-}
sof's avatar
sof committed
210

dreixel's avatar
dreixel committed
211
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
212
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
213
  = (method_binds, aux_binds)
214
  where
215 216 217 218 219 220 221 222 223
    all_cons = tyConDataCons tycon
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons

    -- If there are ten or more (arbitrary number) nullary constructors,
    -- use the con2tag stuff.  For small types it's better to use
    -- ordinary pattern matching.
    (tag_match_cons, pat_match_cons)
       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
       | otherwise                       = ([],           all_cons)
224

225
    no_tag_match_cons = null tag_match_cons
226

227
    fall_through_eqn
228 229
      | no_tag_match_cons   -- All constructors have arguments
      = case pat_match_cons of
230
          []  -> []   -- No constructors; no fall-though case
231
          [_] -> []   -- One constructor; no fall-though case
232
          _   ->      -- Two or more constructors; add fall-through of
233 234
                      --       (==) _ _ = False
                 [([nlWildPat, nlWildPat], false_Expr)]
235

236
      | otherwise -- One or more tag_match cons; add fall-through of
237 238
                  -- extract tags compare for equality
      = [([a_Pat, b_Pat],
239
         untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
240
                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
241

242 243
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
244

dreixel's avatar
dreixel committed
245
    method_binds = listToBag [eq_bind, ne_bind]
246
    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
247
    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
248
                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
249

250 251 252
    ------------------------------------------------------------------
    pats_etc data_con
      = let
253 254 255 256 257 258 259 260 261 262
            con1_pat = nlConVarPat data_con_RDR as_needed
            con2_pat = nlConVarPat data_con_RDR bs_needed

            data_con_RDR = getRdrName data_con
            con_arity   = length tys_needed
            as_needed   = take con_arity as_RDRs
            bs_needed   = take con_arity bs_RDRs
            tys_needed  = dataConOrigArgTys data_con
        in
        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
263
      where
264 265 266 267 268
        nested_eq_expr []  [] [] = true_Expr
        nested_eq_expr tys as bs
          = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
          where
            nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
269

Austin Seipp's avatar
Austin Seipp committed
270 271 272
{-
************************************************************************
*                                                                      *
273
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
274 275
*                                                                      *
************************************************************************
276

277 278
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
279
Suppose constructors are K1..Kn, and some are nullary.
280 281 282
The general form we generate is:

* Do case on first argument
283
        case a of
284 285 286 287 288 289 290
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
291 292
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
293 294 295 296 297 298 299 300
                   K1 {}  -> LT
                   K2 ... -> ...eq_rhs(K2)...
                   _      -> GT

     Otherwise do a tag compare against the bigger range
     (because this is the one most likely to succeed)
        rhs_3    case tag b of tb ->
                 if 3 <# tg then GT
301
                 else case b of
302 303 304
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

305
* To make eq_rhs(K), which knows that
306 307 308 309 310 311
    a = K a1 .. av
    b = K b1 .. bv
  we just want to compare (a1,b1) then (a2,b2) etc.
  Take care on the last field to tail-call into comparing av,bv

* To make nullary_rhs generate this
312 313
     case con2tag a of a# ->
     case con2tag b of ->
314 315 316 317 318 319 320
     a# `compare` b#

Several special cases:

* Two or fewer nullary constructors: don't generate nullary_rhs

* Be careful about unlifted comparisons.  When comparing unboxed
321
  values we can't call the overloaded functions.
322 323 324 325 326
  See function unliftedOrdOp

Note [Do not rely on compare]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
Gabor Greif's avatar
Gabor Greif committed
327
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
328 329 330 331
want to laboriously make a three-way comparison, only to extract a
binary result, something like this:
     (>) (I# x) (I# y) = case <# x y of
                            True -> False
332
                            False -> case ==# x y of
333 334
                                       True  -> False
                                       False -> True
335

336
So for sufficiently small types (few constructors, or all nullary)
337
we generate all methods; for large ones we just use 'compare'.
Austin Seipp's avatar
Austin Seipp committed
338
-}
339

340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379
data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT

------------
ordMethRdr :: OrdOp -> RdrName
ordMethRdr op
  = case op of
       OrdCompare -> compare_RDR
       OrdLT      -> lt_RDR
       OrdLE      -> le_RDR
       OrdGE      -> ge_RDR
       OrdGT      -> gt_RDR

------------
ltResult :: OrdOp -> LHsExpr RdrName
-- Knowing a<b, what is the result for a `op` b?
ltResult OrdCompare = ltTag_Expr
ltResult OrdLT      = true_Expr
ltResult OrdLE      = true_Expr
ltResult OrdGE      = false_Expr
ltResult OrdGT      = false_Expr

------------
eqResult :: OrdOp -> LHsExpr RdrName
-- Knowing a=b, what is the result for a `op` b?
eqResult OrdCompare = eqTag_Expr
eqResult OrdLT      = false_Expr
eqResult OrdLE      = true_Expr
eqResult OrdGE      = true_Expr
eqResult OrdGT      = false_Expr

------------
gtResult :: OrdOp -> LHsExpr RdrName
-- Knowing a>b, what is the result for a `op` b?
gtResult OrdCompare = gtTag_Expr
gtResult OrdLT      = false_Expr
gtResult OrdLE      = false_Expr
gtResult OrdGE      = true_Expr
gtResult OrdGT      = true_Expr

------------
dreixel's avatar
dreixel committed
380
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
381
gen_Ord_binds loc tycon
382
  | null tycon_data_cons        -- No data-cons => invoke bale-out case
dreixel's avatar
dreixel committed
383
  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
384
  | otherwise
dreixel's avatar
dreixel committed
385
  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
386
  where
387
    aux_binds | single_con_type = emptyBag
388
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
389

390 391 392
        -- Note [Do not rely on compare]
    other_ops | (last_tag - first_tag) <= 2     -- 1-3 constructors
                || null non_nullary_cons        -- Or it's an enumeration
393
              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
394
              | otherwise
395
              = emptyBag
396

397 398 399
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
400

401 402 403 404
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
405 406
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
407

408
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
409

410

411
    mkOrdOp :: OrdOp -> LHsBind RdrName
412
    -- Returns a binding   op a b = ... compares a and b according to op ....
dreixel's avatar
dreixel committed
413
    mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
414

415
    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
416
    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
417
      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
418
      = nlHsCase (nlHsVar a_RDR) $
419
        map (mkOrdOpAlt op) tycon_data_cons
420
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
421
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
422

423 424
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
425

426
      | otherwise                -- Mixed nullary and non-nullary
427
      = nlHsCase (nlHsVar a_RDR) $
428
        (map (mkOrdOpAlt op) non_nullary_cons
429
         ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
430

431

432
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
433
    -- Make the alternative  (Ki a1 a2 .. av ->
434 435 436 437 438 439 440 441 442 443 444 445 446
    mkOrdOpAlt op data_con
      = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
      where
        as_needed    = take (dataConSourceArity data_con) as_RDRs
        data_con_RDR = getRdrName data_con

    mkInnerRhs op data_con
      | single_con_type
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]

      | tag == first_tag
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
447
      | tag == last_tag
448 449
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
450

451 452 453 454 455 456 457 458 459
      | tag == first_tag + 1
      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
                                 , mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
      | tag == last_tag - 1
      = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
                                 , mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]

460
      | tag > last_tag `div` 2  -- lower range is larger
461
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
462
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
463
               (gtResult op) $  -- Definitely GT
464 465
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (ltResult op) ]
466 467

      | otherwise               -- upper range is larger
468
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
469
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
470
               (ltResult op) $  -- Definitely LT
471 472 473
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
      where
474
        tag     = get_tag data_con
475
        tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
476

477
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
478 479 480 481
    -- First argument 'a' known to be built with K
    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
    mkInnerEqAlt op data_con
      = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
482
        mkCompareFields tycon op (dataConOrigArgTys data_con)
483 484 485 486
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

487
    mkTagCmp :: OrdOp -> LHsExpr RdrName
488 489 490 491
    -- Both constructors known to be nullary
    -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
    mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
                  unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
492

493 494 495 496 497 498 499 500 501 502
mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
-- where the ai,bi have the given types
mkCompareFields tycon op tys
  = go tys as_RDRs bs_RDRs
  where
    go []   _      _          = eqResult op
    go [ty] (a:_)  (b:_)
      | isUnLiftedType ty     = unliftedOrdOp tycon ty op a b
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
503 504
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
505
                                  (go tys as bs)
506
                                  (gtResult op)
507 508 509 510
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
511
    -- but with suitable special cases for
512 513 514
    mk_compare ty a b lt eq gt
      | isUnLiftedType ty
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
515
      | otherwise
516 517 518 519 520 521 522 523 524 525 526 527
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
          [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
           mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
           mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
      where
        a_expr = nlHsVar a
        b_expr = nlHsVar b
        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty

unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
unliftedOrdOp tycon ty op a b
  = case op of
528
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
529 530 531 532 533 534 535
                                     ltTag_Expr eqTag_Expr gtTag_Expr
       OrdLT      -> wrap lt_op
       OrdLE      -> wrap le_op
       OrdGE      -> wrap ge_op
       OrdGT      -> wrap gt_op
  where
   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
536
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
537 538 539
   a_expr = nlHsVar a
   b_expr = nlHsVar b

540
unliftedCompare :: RdrName -> RdrName
541
                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
542 543 544 545
                -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName  -- Three results
                -> LHsExpr RdrName
-- Return (if a < b then lt else if a == b then eq else gt)
unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
546
  = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
Gabor Greif's avatar
typos  
Gabor Greif committed
547
                        -- Test (<) first, not (==), because the latter
548 549
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
550
        nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
551 552 553 554

nlConWildPat :: DataCon -> LPat RdrName
-- The pattern (K {})
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
555
                                   (RecCon (HsRecFields { rec_flds = []
556
                                                        , rec_dotdot = Nothing })))
557

Austin Seipp's avatar
Austin Seipp committed
558 559 560
{-
************************************************************************
*                                                                      *
561
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
562 563
*                                                                      *
************************************************************************
564 565 566 567 568 569 570 571 572 573 574

@Enum@ can only be derived for enumeration types.  For a type
\begin{verbatim}
data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}

we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).

\begin{verbatim}
instance ... Enum (Foo ...) where
sof's avatar
sof committed
575 576 577
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

578 579
    toEnum i = tag2con_Foo i

580 581 582 583 584
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
585
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
586 587 588 589 590 591 592

   enumFromThen a b
     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]

    -- or, really...
    enumFromThen a b
      = case con2tag_Foo a of { a# ->
593 594 595
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
596 597 598
\end{verbatim}

For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
Austin Seipp's avatar
Austin Seipp committed
599
-}
600

dreixel's avatar
dreixel committed
601
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
602
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
603
  = (method_binds, aux_binds)
604
  where
dreixel's avatar
dreixel committed
605
    method_binds = listToBag [
606 607 608 609 610 611 612
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
613 614
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
615

616
    occ_nm = getOccString tycon
sof's avatar
sof committed
617 618

    succ_enum
619
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
620 621 622 623 624 625 626 627
        untag_Expr tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
             (nlHsApp (nlHsVar (tag2con_RDR tycon))
                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                        nlHsIntLit 1]))

sof's avatar
sof committed
628
    pred_enum
629
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
630 631 632 633 634 635
        untag_Expr tycon [(a_RDR, ah_RDR)] $
        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
                               nlHsVarApps intDataCon_RDR [ah_RDR]])
             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
             (nlHsApp (nlHsVar (tag2con_RDR tycon))
                           (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
636
                                               nlHsLit (HsInt "-1" (-1))]))
637 638

    to_enum
639
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
640 641
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
642 643
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
644
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
645

646
    enum_from
647
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
648 649 650 651 652 653
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          nlHsApps map_RDR
                [nlHsVar (tag2con_RDR tycon),
                 nlHsPar (enum_from_to_Expr
                            (nlHsVarApps intDataCon_RDR [ah_RDR])
                            (nlHsVar (maxtag_RDR tycon)))]
654 655

    enum_from_then
656
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
657 658 659 660 661 662 663 664 665 666
          untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
            nlHsPar (enum_from_then_to_Expr
                    (nlHsVarApps intDataCon_RDR [ah_RDR])
                    (nlHsVarApps intDataCon_RDR [bh_RDR])
                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
                                               nlHsVarApps intDataCon_RDR [bh_RDR]])
                           (nlHsIntLit 0)
                           (nlHsVar (maxtag_RDR tycon))
                           ))
667 668

    from_enum
669
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
670 671
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
672

Austin Seipp's avatar
Austin Seipp committed
673 674 675
{-
************************************************************************
*                                                                      *
676
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
677 678 679
*                                                                      *
************************************************************************
-}
680

dreixel's avatar
dreixel committed
681
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
682
gen_Bounded_binds loc tycon
683
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
684
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
685 686
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
687
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
688
  where
689
    data_cons = tyConDataCons tycon
690 691

    ----- enum-flavored: ---------------------------
692 693
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
694

695 696
    data_con_1     = head data_cons
    data_con_N     = last data_cons
697 698
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
699 700

    ----- single-constructor-flavored: -------------
701
    arity          = dataConSourceArity data_con_1
702

703
    min_bound_1con = mkHsVarBind loc minBound_RDR $
704
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
705
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
706
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
707

Austin Seipp's avatar
Austin Seipp committed
708 709 710
{-
************************************************************************
*                                                                      *
711
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
712 713
*                                                                      *
************************************************************************
714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730

Deriving @Ix@ is only possible for enumeration types and
single-constructor types.  We deal with them in turn.

For an enumeration type, e.g.,
\begin{verbatim}
    data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}
things go not too differently from @Enum@:
\begin{verbatim}
instance ... Ix (Foo ...) where
    range (a, b)
      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]

    -- or, really...
    range (a, b)
      = case (con2tag_Foo a) of { a# ->
731 732 733
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
734

Gabor Greif's avatar
typos  
Gabor Greif committed
735
    -- Generate code for unsafeIndex, because using index leads
736 737 738
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
739
               r# -> I# r#
740 741 742

    inRange (a, b) c
      = let
743 744 745
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
746 747 748 749

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
750 751 752 753 754 755 756
        case (con2tag_Foo b)   of { b_tag ->
        case (con2tag_Foo c)   of { c_tag ->
        if (c_tag >=# a_tag) then
          c_tag <=# b_tag
        else
          False
        }}}
757
\end{verbatim}
758
(modulo suitable case-ification to handle the unlifted tags)
759 760 761 762 763 764 765

For a single-constructor type (NB: this includes all tuples), e.g.,
\begin{verbatim}
    data Foo ... = MkFoo a b Int Double c c
\end{verbatim}
we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
Austin Seipp's avatar
Austin Seipp committed
766
-}
767

dreixel's avatar
dreixel committed
768
gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
769

770
gen_Ix_binds loc tycon
771
  | isEnumerationTyCon tycon
772 773 774
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
775
  | otherwise
776
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
777 778
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
779
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
780 781

    enum_range
782
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
783 784 785 786 787 788
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          untag_Expr tycon [(b_RDR, bh_RDR)] $
          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
              nlHsPar (enum_from_to_Expr
                        (nlHsVarApps intDataCon_RDR [ah_RDR])
                        (nlHsVarApps intDataCon_RDR [bh_RDR]))
789 790

    enum_index
791 792 793 794 795 796 797 798 799 800 801 802 803 804
      = mk_easy_FunBind loc unsafeIndex_RDR
                [noLoc (AsPat (noLoc c_RDR)
                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),
                                d_Pat] (
           untag_Expr tycon [(a_RDR, ah_RDR)] (
           untag_Expr tycon [(d_RDR, dh_RDR)] (
           let
                rhs = nlHsVarApps intDataCon_RDR [c_RDR]
           in
           nlHsCase
             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
             [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
           ))
        )
805 806

    enum_inRange
807
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
808 809 810
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
811 812
          nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
             (genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
813 814 815
          ) {-else-} (
             false_Expr
          ))))
816 817

    --------------------------------------------------------------
818
    single_con_ixes
dreixel's avatar
dreixel committed
819
      = listToBag [single_con_range, single_con_index, single_con_inRange]
820 821

    data_con
822 823 824
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
825

826
    con_arity    = dataConSourceArity data_con
827
    data_con_RDR = getRdrName data_con
828

829 830 831
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
832

833 834
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
835

836 837
    --------------------------------------------------------------
    single_con_range
838 839 840
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
841
      where
842
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
843

844 845 846
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
847 848 849

    ----------------
    single_con_index
850 851 852
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
853 854 855 856
        -- We need to reverse the order we consider the components in
        -- so that
        --     range (l,u) !! index (l,u) i == i   -- when i is in range
        -- (from http://haskell.org/onlinereport/ix.html) holds.
857
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
858
      where
859 860 861 862 863 864 865 866 867 868 869 870 871 872
        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
        mk_index []        = nlHsIntLit 0
        mk_index [(l,u,i)] = mk_one l u i
        mk_index ((l,u,i) : rest)
          = genOpApp (
                mk_one l u i
            ) plus_RDR (
                genOpApp (
                    (nlHsApp (nlHsVar unsafeRangeSize_RDR)
                             (mkLHsVarTuple [l,u]))
                ) times_RDR (mk_index rest)
           )
        mk_one l u i
          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]