TcGenDeriv.hs 96.5 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,
cactus's avatar
cactus committed
28 29
        ordOpTbl, boxConTbl,
        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)
47
import MkId ( coerceId )
48 49 50 51 52 53
import PrimOp
import SrcLoc
import TyCon
import TcType
import TysPrim
import TysWiredIn
54
import Type
55
import Class
56 57
import TypeRep
import VarSet
58
import VarEnv
59
import State
60
import Util
61
import Var
62
#if __GLASGOW_HASKELL__ < 709
63
import MonadUtils
64
#endif
65
import Outputable
66
import Lexeme
67
import FastString
68
import Pair
69
import Bag
70
import TcEnv (InstInfo)
71
import StaticFlags( opt_PprStyle_Debug )
72

73 74 75
import ListSetOps ( assocMaybe )
import Data.List  ( partition, intersperse )
import Data.Maybe ( isNothing )
76

77 78
type BagDerivStuff = Bag DerivStuff

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

87 88 89
data DerivStuff     -- Please add this auxiliary stuff
  = DerivAuxBind AuxBindSpec

90
  -- Generics
91
  | DerivTyCon TyCon                   -- New data types
Simon Peyton Jones's avatar
Simon Peyton Jones committed
92
  | DerivFamInst FamInst               -- New type family instances
93

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

Austin Seipp's avatar
Austin Seipp committed
98 99 100
{-
************************************************************************
*                                                                      *
101
                Top level function
Austin Seipp's avatar
Austin Seipp committed
102 103 104
*                                                                      *
************************************************************************
-}
105

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

  | otherwise
115 116 117 118 119 120
  -- 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)

121 122 123 124 125 126 127 128 129 130 131 132 133
  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)
               , (traversableClassKey, gen_Traversable_binds) ]
134 135 136 137 138 139 140 141 142 143 144 145 146 147


-- 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")
148

Austin Seipp's avatar
Austin Seipp committed
149 150 151
{-
************************************************************************
*                                                                      *
152
                Eq instances
Austin Seipp's avatar
Austin Seipp committed
153 154
*                                                                      *
************************************************************************
155

156 157 158 159 160 161 162 163 164
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
165 166
  Usual Thing, e.g.,:

167 168 169 170 171 172 173
    (==) (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
174 175
  for that particular test.

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

179 180 181 182
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
183

184 185 186 187 188
  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
189 190
  catch-all:

191
     (==) a b  = False
192

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

198 199 200 201 202 203 204 205
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
206
-}
sof's avatar
sof committed
207

dreixel's avatar
dreixel committed
208
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
209
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
210
  = (method_binds, aux_binds)
211
  where
212 213 214 215 216 217 218 219 220
    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)
221

222
    no_tag_match_cons = null tag_match_cons
223

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

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

239 240
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
241

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

247 248 249
    ------------------------------------------------------------------
    pats_etc data_con
      = let
250 251 252 253 254 255 256 257 258 259
            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)
260
      where
261 262 263 264 265
        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))
266

Austin Seipp's avatar
Austin Seipp committed
267 268 269
{-
************************************************************************
*                                                                      *
270
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
271 272
*                                                                      *
************************************************************************
273

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

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

* To make rhs_i
288 289
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
290 291 292 293 294 295 296 297
                   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
298
                 else case b of
299 300 301
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

302
* To make eq_rhs(K), which knows that
303 304 305 306 307 308
    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
309 310
     case con2tag a of a# ->
     case con2tag b of ->
311 312 313 314 315 316 317
     a# `compare` b#

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
318
  values we can't call the overloaded functions.
319 320 321 322 323
  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
324
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
325 326 327 328
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
329
                            False -> case ==# x y of
330 331
                                       True  -> False
                                       False -> True
332

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

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

387 388 389
        -- 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
390
              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
391
              | otherwise
392
              = emptyBag
393

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

398 399 400 401
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
402 403
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
404

405
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
406

407

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

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

420 421
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
422

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

428

429
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
430
    -- Make the alternative  (Ki a1 a2 .. av ->
431 432 433 434 435 436 437 438 439 440 441 442 443
    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) ]
444
      | tag == last_tag
445 446
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
                                 , mkSimpleHsAlt nlWildPat (gtResult op) ]
447

448 449 450 451 452 453 454 455 456
      | 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) ]

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

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

474
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
475 476 477 478
    -- 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) $
479
        mkCompareFields tycon op (dataConOrigArgTys data_con)
480 481 482 483
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

484
    mkTagCmp :: OrdOp -> LHsExpr RdrName
485 486 487 488
    -- 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
489

490 491 492 493 494 495 496 497 498 499
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)
500 501
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
502
                                  (go tys as bs)
503
                                  (gtResult op)
504 505 506 507
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
508
    -- but with suitable special cases for
509 510 511
    mk_compare ty a b lt eq gt
      | isUnLiftedType ty
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
512
      | otherwise
513 514 515 516 517 518 519 520 521 522 523 524
      = 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
525
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
526 527 528 529 530 531 532
                                     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
533
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
534 535 536
   a_expr = nlHsVar a
   b_expr = nlHsVar b

537
unliftedCompare :: RdrName -> RdrName
538
                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
539 540 541 542
                -> 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
543
  = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
Gabor Greif's avatar
typos  
Gabor Greif committed
544
                        -- Test (<) first, not (==), because the latter
545 546
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
547
        nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
548 549 550 551

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

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

@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
572 573 574
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

575 576
    toEnum i = tag2con_Foo i

577 578 579 580 581
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

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

   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# ->
590 591 592
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
593 594 595
\end{verbatim}

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

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

613
    occ_nm = getOccString tycon
sof's avatar
sof committed
614 615

    succ_enum
616
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
617 618 619 620 621 622 623 624
        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
625
    pred_enum
626
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
627 628 629 630 631 632
        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],
633
                                               nlHsLit (HsInt "-1" (-1))]))
634 635

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

643
    enum_from
644
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
645 646 647 648 649 650
          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)))]
651 652

    enum_from_then
653
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
654 655 656 657 658 659 660 661 662 663
          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))
                           ))
664 665

    from_enum
666
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
667 668
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
669

Austin Seipp's avatar
Austin Seipp committed
670 671 672
{-
************************************************************************
*                                                                      *
673
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
674 675 676
*                                                                      *
************************************************************************
-}
677

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

    ----- enum-flavored: ---------------------------
689 690
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
691

692 693
    data_con_1     = head data_cons
    data_con_N     = last data_cons
694 695
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
696 697

    ----- single-constructor-flavored: -------------
698
    arity          = dataConSourceArity data_con_1
699

700
    min_bound_1con = mkHsVarBind loc minBound_RDR $
701
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
702
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
703
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
704

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

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# ->
728 729 730
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
731

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

    inRange (a, b) c
      = let
740 741 742
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
743 744 745 746

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
747 748 749 750 751 752 753
        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
        }}}
754
\end{verbatim}
755
(modulo suitable case-ification to handle the unlifted tags)
756 757 758 759 760 761 762

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
763
-}
764

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

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

    enum_range
779
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
780 781 782 783 784 785
          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]))
786 787

    enum_index
788 789 790 791 792 793 794 795 796 797 798 799 800 801
      = 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]
           ))
        )
802 803

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

    --------------------------------------------------------------
815
    single_con_ixes
dreixel's avatar
dreixel committed
816
      = listToBag [single_con_range, single_con_index, single_con_inRange]
817 818

    data_con
819 820 821
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
822

823
    con_arity    = dataConSourceArity data_con
824
    data_con_RDR = getRdrName data_con
825

826 827 828
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
829

830 831
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
832

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

841 842 843
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
844 845 846

    ----------------
    single_con_index
847 848 849
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
850 851 852 853
        -- 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.
854
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
855
      where
856 857 858 859 860 861 862 863 864 865 866 867 868 869
        -- 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]
870 871 872

    ------------------
    single_con_inRange
873 874 875 876
      = mk_easy_FunBind loc inRange_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed] $
          foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
877
      where
878
        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
879

Austin Seipp's avatar
Austin Seipp committed
880 881 882
{-
************************************************************************
*                                                                      *
883
        Read instances
Austin Seipp's avatar
Austin Seipp committed
884 885
*                                                                      *
************************************************************************
886

887 888 889 890
Example

  infix 4 %%
  data T = Int %% Int
891 892
         | T1 { f1 :: Int }
         | T2 T
893 894 895

instance Read T where
  readPrec =
896
    parens
897
    ( prec 4 (
898 899 900
        do x <- ReadP.step Read.readPrec
           expectP (Symbol "%%")
           y <- ReadP.step Read.readPrec
901 902
           return (x %% y))
      +++
903
      prec (appPrec+1) (
904 905
        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
        -- Record construction binds even more tightly than application
906 907 908 909
        do expectP (Ident "T1")
           expectP (Punc '{')
           expectP (Ident "f1")
           expectP (Punc '=')