TcGenDeriv.hs 117 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
        hasBuiltinDeriving,
22 23
        FFoldType(..), functorLikeTraverse,
        deepSubtypesContaining, foldDataConArgs,
24
        mkCoerceClassMethEqn,
25
        gen_Newtype_binds,
26
        genAuxBinds,
Ryan Scott's avatar
Ryan Scott committed
27
        ordOpTbl, boxConTbl, litConTbl,
cactus's avatar
cactus committed
28
        mkRdrFunBind
29
    ) where
30

31
#include "HsVersions.h"
32

33 34 35 36

import LoadIface( loadInterfaceForName )
import HscTypes( lookupFixity, mi_fix )
import TcRnMonad
37
import HsSyn
38 39
import RdrName
import BasicTypes
40
import Module( getModule )
41 42
import DataCon
import Name
niteria's avatar
niteria committed
43 44
import Fingerprint
import Encoding
45

46
import DynFlags
47
import PrelInfo
48
import FamInstEnv( FamInst )
49
import PrelNames
Ryan Scott's avatar
Ryan Scott committed
50 51
import THNames
import Module ( moduleName, moduleNameString
52
              , moduleUnitId, unitIdString )
53
import MkId ( coerceId )
54 55 56 57 58 59
import PrimOp
import SrcLoc
import TyCon
import TcType
import TysPrim
import TysWiredIn
60
import Type
61
import Class
62
import TyCoRep
63
import VarSet
64
import VarEnv
65
import State
66
import Util
67
import Var
68
import Outputable
69
import Lexeme
70
import FastString
71
import Pair
72
import Bag
73
import StaticFlags( opt_PprStyle_Debug )
74

75 76
import ListSetOps ( assocMaybe )
import Data.List  ( partition, intersperse )
77
import Data.Maybe ( catMaybes, isJust )
78

79 80
type BagDerivStuff = Bag DerivStuff

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

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

92
  -- Generics and DeriveAnyClass
Simon Peyton Jones's avatar
Simon Peyton Jones committed
93
  | DerivFamInst FamInst               -- New type family instances
94

95
  -- New top-level auxiliary bindings
96
  | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
97

Austin Seipp's avatar
Austin Seipp committed
98 99 100
{-
************************************************************************
*                                                                      *
101
                Class deriving diagnostics
Austin Seipp's avatar
Austin Seipp committed
102 103
*                                                                      *
************************************************************************
104

105 106 107 108 109 110 111 112
Only certain blessed classes can be used in a deriving clause. These classes
are listed below in the definition of hasBuiltinDeriving (with the exception
of Generic and Generic1, which are handled separately in TcGenGenerics).

A class might be able to be used in a deriving clause if it -XDeriveAnyClass
is willing to support it. The canDeriveAnyClass function checks if this is
the case.
-}
113

114
hasBuiltinDeriving :: Class
115 116
                   -> Maybe (SrcSpan
                             -> TyCon
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
                             -> TcM (LHsBinds RdrName, BagDerivStuff))
hasBuiltinDeriving clas
  = assocMaybe gen_list (getUnique clas)
  where
    gen_list :: [(Unique, SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff))]
    gen_list = [ (eqClassKey,          simple gen_Eq_binds)
               , (ordClassKey,         simple gen_Ord_binds)
               , (enumClassKey,        simple gen_Enum_binds)
               , (boundedClassKey,     simple gen_Bounded_binds)
               , (ixClassKey,          simple gen_Ix_binds)
               , (showClassKey,        with_fix_env gen_Show_binds)
               , (readClassKey,        with_fix_env gen_Read_binds)
               , (dataClassKey,        gen_Data_binds)
               , (functorClassKey,     simple gen_Functor_binds)
               , (foldableClassKey,    simple gen_Foldable_binds)
               , (traversableClassKey, simple gen_Traversable_binds)
               , (liftClassKey,        simple gen_Lift_binds) ]

    simple gen_fn loc tc
      = return (gen_fn loc tc)

    with_fix_env gen_fn loc tc
      = do { fix_env <- getDataConFixityFun tc
           ; return (gen_fn fix_env loc tc) }

getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)
-- If the TyCon is locally defined, we want the local fixity env;
-- but if it is imported (which happens for standalone deriving)
-- we need to get the fixity env from the interface file
-- c.f. RnEnv.lookupFixity, and Trac #9830
getDataConFixityFun tc
  = do { this_mod <- getModule
       ; if nameIsLocalOrFrom this_mod name
         then do { fix_env <- getFixityEnv
                 ; return (lookupFixity fix_env) }
         else do { iface <- loadInterfaceForName doc name
                            -- Should already be loaded!
                 ; return (mi_fix iface . nameOccName) } }
155
  where
156 157 158
    name = tyConName tc
    doc = text "Data con fixities for" <+> ppr name

159

Austin Seipp's avatar
Austin Seipp committed
160 161 162
{-
************************************************************************
*                                                                      *
163
                Eq instances
Austin Seipp's avatar
Austin Seipp committed
164 165
*                                                                      *
************************************************************************
166

167 168 169 170 171 172 173 174 175
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
176 177
  Usual Thing, e.g.,:

178 179 180 181 182 183 184
    (==) (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
185 186
  for that particular test.

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

190 191 192 193
      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}
194

195 196 197 198 199
  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
200 201
  catch-all:

202
     (==) a b  = False
203

204
* For the @(/=)@ method, we normally just use the default method.
205 206 207 208
  If the type is an enumeration type, we could/may/should? generate
  special code that calls @con2tag_Foo@, much like for @(==)@ shown
  above.

209 210 211 212 213 214 215 216
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
217
-}
sof's avatar
sof committed
218

dreixel's avatar
dreixel committed
219
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
220
gen_Eq_binds loc tycon
dreixel's avatar
dreixel committed
221
  = (method_binds, aux_binds)
222
  where
223 224 225 226 227 228 229 230 231
    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)
232

233
    no_tag_match_cons = null tag_match_cons
234

235
    fall_through_eqn
236 237
      | no_tag_match_cons   -- All constructors have arguments
      = case pat_match_cons of
238
          []  -> []   -- No constructors; no fall-though case
239
          [_] -> []   -- One constructor; no fall-though case
240
          _   ->      -- Two or more constructors; add fall-through of
241 242
                      --       (==) _ _ = False
                 [([nlWildPat, nlWildPat], false_Expr)]
243

244
      | otherwise -- One or more tag_match cons; add fall-through of
245 246
                  -- extract tags compare for equality
      = [([a_Pat, b_Pat],
247
         untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
248
                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
249

250 251
    aux_binds | no_tag_match_cons = emptyBag
              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
252

dreixel's avatar
dreixel committed
253
    method_binds = listToBag [eq_bind, ne_bind]
254
    eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
255
    ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
256
                        nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
257

258 259 260
    ------------------------------------------------------------------
    pats_etc data_con
      = let
261 262 263 264 265 266 267 268 269 270
            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)
271
      where
272 273 274 275 276
        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))
277

Austin Seipp's avatar
Austin Seipp committed
278 279 280
{-
************************************************************************
*                                                                      *
281
        Ord instances
Austin Seipp's avatar
Austin Seipp committed
282 283
*                                                                      *
************************************************************************
284

285 286
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
287
Suppose constructors are K1..Kn, and some are nullary.
288 289 290
The general form we generate is:

* Do case on first argument
291
        case a of
292 293 294 295 296 297 298
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
299 300
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
301 302 303 304 305 306 307 308
                   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
309
                 else case b of
310 311 312
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

313
* To make eq_rhs(K), which knows that
314 315 316 317 318 319
    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
320 321
     case con2tag a of a# ->
     case con2tag b of ->
322 323 324 325 326 327 328
     a# `compare` b#

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
329
  values we can't call the overloaded functions.
330 331 332 333 334
  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
335
comparisons on top of it; see Trac #2130, #4019.  Reason: we don't
336 337 338 339
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
340
                            False -> case ==# x y of
341 342
                                       True  -> False
                                       False -> True
343

344
So for sufficiently small types (few constructors, or all nullary)
345
we generate all methods; for large ones we just use 'compare'.
Austin Seipp's avatar
Austin Seipp committed
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 380 381 382 383 384 385 386 387
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
388
gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
389
gen_Ord_binds loc tycon
390
  | null tycon_data_cons        -- No data-cons => invoke bale-out case
dreixel's avatar
dreixel committed
391
  = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
392
  | otherwise
dreixel's avatar
dreixel committed
393
  = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
394
  where
395
    aux_binds | single_con_type = emptyBag
396
              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
397

398 399 400
        -- 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
401
              = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
402
              | otherwise
403
              = emptyBag
404

405 406 407
    get_tag con = dataConTag con - fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!
408

409 410 411 412
    tycon_data_cons = tyConDataCons tycon
    single_con_type = isSingleton tycon_data_cons
    (first_con : _) = tycon_data_cons
    (last_con : _)  = reverse tycon_data_cons
413 414
    first_tag       = get_tag first_con
    last_tag        = get_tag last_con
415

416
    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
417

418

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

423
    mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
424
    mkOrdOpRhs op       -- RHS for comparing 'a' and 'b' according to op
425
      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
426
      = nlHsCase (nlHsVar a_RDR) $
427
        map (mkOrdOpAlt op) tycon_data_cons
428
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
429
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }
430

431 432
      | null non_nullary_cons    -- All nullary, so go straight to comparing tags
      = mkTagCmp op
433

434
      | otherwise                -- Mixed nullary and non-nullary
435
      = nlHsCase (nlHsVar a_RDR) $
436
        (map (mkOrdOpAlt op) non_nullary_cons
437
         ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
438

439

440
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
441
    -- Make the alternative  (Ki a1 a2 .. av ->
442
    mkOrdOpAlt op data_con
443 444
      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
                    (mkInnerRhs op data_con)
445 446 447 448 449 450 451 452 453 454
      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
455
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
456
      | tag == last_tag
457
      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
458
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
459

460
      | tag == first_tag + 1
461 462
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
                                             (gtResult op)
463
                                 , mkInnerEqAlt op data_con
464
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
465
      | tag == last_tag - 1
466 467
      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
                                             (ltResult op)
468
                                 , mkInnerEqAlt op data_con
469
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
470

471
      | tag > last_tag `div` 2  -- lower range is larger
472
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
473
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
474
               (gtResult op) $  -- Definitely GT
475
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
476
                                 , mkHsCaseAlt nlWildPat (ltResult op) ]
477 478

      | otherwise               -- upper range is larger
479
      = untag_Expr tycon [(b_RDR, bh_RDR)] $
480
        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
481
               (ltResult op) $  -- Definitely LT
482
        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
483
                                 , mkHsCaseAlt nlWildPat (gtResult op) ]
484
      where
485
        tag     = get_tag data_con
486
        tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
487

488
    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
489 490 491
    -- 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
492
      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
493
        mkCompareFields tycon op (dataConOrigArgTys data_con)
494 495 496 497
      where
        data_con_RDR = getRdrName data_con
        bs_needed    = take (dataConSourceArity data_con) bs_RDRs

498
    mkTagCmp :: OrdOp -> LHsExpr RdrName
499 500 501 502
    -- 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
503

504 505 506 507 508 509 510 511
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:_)
512
      | isUnliftedType ty     = unliftedOrdOp tycon ty op a b
513
      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
514 515
    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
                                  (ltResult op)
516
                                  (go tys as bs)
517
                                  (gtResult op)
518 519 520 521
    go _ _ _ = panic "mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
522
    -- but with suitable special cases for
523
    mk_compare ty a b lt eq gt
524
      | isUnliftedType ty
525
      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
526
      | otherwise
527
      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
528 529 530
          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
531 532 533 534 535 536 537 538
      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
539
       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
540 541 542 543 544 545 546
                                     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
547
   wrap prim_op = genPrimOpApp a_expr prim_op b_expr
548 549 550
   a_expr = nlHsVar a
   b_expr = nlHsVar b

551
unliftedCompare :: RdrName -> RdrName
552
                -> LHsExpr RdrName -> LHsExpr RdrName   -- What to cmpare
553 554 555 556
                -> 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
557
  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
Gabor Greif's avatar
typos  
Gabor Greif committed
558
                        -- Test (<) first, not (==), because the latter
559 560
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
561 562 563
        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
  where
    ascribeBool e = nlExprWithTySig e (toLHsSigWcType boolTy)
564 565 566 567

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

Austin Seipp's avatar
Austin Seipp committed
571 572 573
{-
************************************************************************
*                                                                      *
574
        Enum instances
Austin Seipp's avatar
Austin Seipp committed
575 576
*                                                                      *
************************************************************************
577 578 579 580 581 582 583 584 585 586 587

@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
588 589 590
    succ x   = toEnum (1 + fromEnum x)
    pred x   = toEnum (fromEnum x - 1)

591 592
    toEnum i = tag2con_Foo i

593 594 595 596 597
    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
598
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
599 600 601 602 603 604 605

   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# ->
606 607 608
        case con2tag_Foo b of { b# ->
        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
        }}
609 610 611
\end{verbatim}

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

dreixel's avatar
dreixel committed
614
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
615
gen_Enum_binds loc tycon
dreixel's avatar
dreixel committed
616
  = (method_binds, aux_binds)
617
  where
dreixel's avatar
dreixel committed
618
    method_binds = listToBag [
619 620 621 622 623 624 625
                        succ_enum,
                        pred_enum,
                        to_enum,
                        enum_from,
                        enum_from_then,
                        from_enum
                    ]
626 627
    aux_binds = listToBag $ map DerivAuxBind
                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
628

629
    occ_nm = getOccString tycon
sof's avatar
sof committed
630 631

    succ_enum
632
      = mk_easy_FunBind loc succ_RDR [a_Pat] $
633 634 635 636 637 638 639 640
        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
641
    pred_enum
642
      = mk_easy_FunBind loc pred_RDR [a_Pat] $
643 644 645 646 647 648
        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],
649
                                               nlHsLit (HsInt "-1" (-1))]))
650 651

    to_enum
652
      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
653 654
        nlHsIf (nlHsApps and_RDR
                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
655 656
                 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
             (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
657
             (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
658

659
    enum_from
660
      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
661 662 663 664 665 666
          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)))]
667 668

    enum_from_then
669
      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
670 671 672 673 674 675 676 677 678 679
          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))
                           ))
680 681

    from_enum
682
      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
683 684
          untag_Expr tycon [(a_RDR, ah_RDR)] $
          (nlHsVarApps intDataCon_RDR [ah_RDR])
685

Austin Seipp's avatar
Austin Seipp committed
686 687 688
{-
************************************************************************
*                                                                      *
689
        Bounded instances
Austin Seipp's avatar
Austin Seipp committed
690 691 692
*                                                                      *
************************************************************************
-}
693

dreixel's avatar
dreixel committed
694
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
695
gen_Bounded_binds loc tycon
696
  | isEnumerationTyCon tycon
dreixel's avatar
dreixel committed
697
  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
698 699
  | otherwise
  = ASSERT(isSingleton data_cons)
dreixel's avatar
dreixel committed
700
    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
701
  where
702
    data_cons = tyConDataCons tycon
703 704

    ----- enum-flavored: ---------------------------
705 706
    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
707

708 709
    data_con_1     = head data_cons
    data_con_N     = last data_cons
710 711
    data_con_1_RDR = getRdrName data_con_1
    data_con_N_RDR = getRdrName data_con_N
712 713

    ----- single-constructor-flavored: -------------
714
    arity          = dataConSourceArity data_con_1
715

716
    min_bound_1con = mkHsVarBind loc minBound_RDR $
717
                     nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
718
    max_bound_1con = mkHsVarBind loc maxBound_RDR $
719
                     nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
720

Austin Seipp's avatar
Austin Seipp committed
721 722 723
{-
************************************************************************
*                                                                      *
724
        Ix instances
Austin Seipp's avatar
Austin Seipp committed
725 726
*                                                                      *
************************************************************************
727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743

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# ->
744 745 746
        case (con2tag_Foo b) of { b# ->
        map tag2con_Foo (enumFromTo (I# a#) (I# b#))
        }}
747

Gabor Greif's avatar
typos  
Gabor Greif committed
748
    -- Generate code for unsafeIndex, because using index leads
749 750 751
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
752
               r# -> I# r#
753 754 755

    inRange (a, b) c
      = let
756 757 758
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
759 760 761 762

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
763 764 765 766 767 768 769
        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
        }}}
770
\end{verbatim}
771
(modulo suitable case-ification to handle the unlifted tags)
772 773 774 775 776 777 778

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
779
-}
780

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

783
gen_Ix_binds loc tycon
784
  | isEnumerationTyCon tycon
785 786 787
  = ( enum_ixes
    , listToBag $ map DerivAuxBind
                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
788
  | otherwise
789
  = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
790 791
  where
    --------------------------------------------------------------
dreixel's avatar
dreixel committed
792
    enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
793 794

    enum_range
795
      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
796 797 798 799 800 801
          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]))
802 803

    enum_index
804 805 806 807 808 809 810 811 812 813 814
      = 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))
815
             [mkHsCaseAlt (nlVarPat c_RDR) rhs]
816 817
           ))
        )
818

819
    -- This produces something like `(ch >= ah) && (ch <= bh)`
820
    enum_inRange
821
      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
822 823 824
          untag_Expr tycon [(a_RDR, ah_RDR)] (
          untag_Expr tycon [(b_RDR, bh_RDR)] (
          untag_Expr tycon [(c_RDR, ch_RDR)] (
825 826 827 828 829 830 831
          -- This used to use `if`, which interacts badly with RebindableSyntax.
          -- See #11396.
          nlHsApps and_RDR
              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
              ]
          )))
832 833

    --------------------------------------------------------------
834
    single_con_ixes
dreixel's avatar
dreixel committed
835
      = listToBag [single_con_range, single_con_index, single_con_inRange]
836 837

    data_con
838 839 840
      = case tyConSingleDataCon_maybe tycon of -- just checking...
          Nothing -> panic "get_Ix_binds"
          Just dc -> dc
841

842
    con_arity    = dataConSourceArity data_con
843
    data_con_RDR = getRdrName data_con
844

845 846 847
    as_needed = take con_arity as_RDRs
    bs_needed = take con_arity bs_RDRs
    cs_needed = take con_arity cs_RDRs
848

849 850
    con_pat  xs  = nlConVarPat data_con_RDR xs
    con_expr     = nlHsVarApps data_con_RDR cs_needed
sof's avatar
sof committed
851

852 853
    --------------------------------------------------------------
    single_con_range
854 855 856
      = mk_easy_FunBind loc range_RDR
          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
        noLoc (mkHsComp ListComp stmts con_expr)
857
      where
858
        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
859

860 861 862
        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
                                 (nlHsApp (nlHsVar range_RDR)
                                          (mkLHsVarTuple [a,b]))
863 864 865

    ----------------
    single_con_index
866 867 868
      = mk_easy_FunBind loc unsafeIndex_RDR
                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
                 con_pat cs_needed]
869 870 871 872
        -- 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.
873
                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
874
      where
875 876 877 878 879 880 881 882 883 884 885 886 887