{-
    %
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

-}

{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

-- | Generating derived instance declarations
--
-- This module is nominally ``subordinate'' to @GHC.Tc.Deriv@, which is the
-- ``official'' interface to deriving-related things.
--
-- This is where we do all the grimy bindings' generation.
module GHC.Tc.Deriv.Generate (
        BagDerivStuff, DerivStuff(..),

        gen_Eq_binds,
        gen_Ord_binds,
        gen_Enum_binds,
        gen_Bounded_binds,
        gen_Ix_binds,
        gen_Show_binds,
        gen_Read_binds,
        gen_Data_binds,
        gen_Lift_binds,
        gen_Newtype_binds,
        mkCoerceClassMethEqn,
        genAuxBinds,
        ordOpTbl, boxConTbl, litConTbl,
        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
    ) where

#include "HsVersions.h"

import GHC.Prelude

import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Utils.Fingerprint
import GHC.Utils.Encoding

import GHC.Driver.Session
import GHC.Builtin.Utils
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Builtin.Names
import GHC.Builtin.Names.TH
import GHC.Types.Id.Make ( coerceId )
import GHC.Builtin.PrimOps
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Validity ( checkValidCoAxBranch )
import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Core.Type
import GHC.Core.Class
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Lexeme
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Bag

import Data.List  ( find, partition, intersperse )

type BagDerivStuff = Bag DerivStuff

data AuxBindSpec
  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon
  | DerivTag2Con TyCon  -- ...ditto tag2Con
  | DerivMaxTag  TyCon  -- ...and maxTag
  deriving( AuxBindSpec -> AuxBindSpec -> Bool
(AuxBindSpec -> AuxBindSpec -> Bool)
-> (AuxBindSpec -> AuxBindSpec -> Bool) -> Eq AuxBindSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuxBindSpec -> AuxBindSpec -> Bool
$c/= :: AuxBindSpec -> AuxBindSpec -> Bool
== :: AuxBindSpec -> AuxBindSpec -> Bool
$c== :: AuxBindSpec -> AuxBindSpec -> Bool
External instance of the constraint type Eq TyCon
External instance of the constraint type Eq TyCon
Eq )
  -- All these generate ZERO-BASED tag operations
  -- I.e first constructor has tag 0

data DerivStuff     -- Please add this auxiliary stuff
  = DerivAuxBind AuxBindSpec

  -- Generics and DeriveAnyClass
  | DerivFamInst FamInst               -- New type family instances

  -- New top-level auxiliary bindings
  | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB


{-
************************************************************************
*                                                                      *
                Eq instances
*                                                                      *
************************************************************************

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
  Usual Thing, e.g.,:

    (==) (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
  for that particular test.

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

      (==) a b  = case (con2tag_Foo a) of { a# ->
                  case (con2tag_Foo b) of { b# ->
                  case (a# ==# b#)     of {
                    r -> r }}}

  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
  catch-all:

     (==) a b  = False

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

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.
-}

gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Eq_binds SrcSpan
loc TyCon
tycon = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
    (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
-> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (DynFlags -> LHsBinds (GhcPass 'Parsed)
method_binds DynFlags
dflags, BagDerivStuff
aux_binds)
  where
    all_cons :: [DataCon]
all_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    ([DataCon]
nullary_cons, [DataCon]
non_nullary_cons) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
isNullarySrcDataCon [DataCon]
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.
    ([DataCon]
tag_match_cons, [DataCon]
pat_match_cons)
       | [DataCon]
nullary_cons [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
10 = ([DataCon]
nullary_cons, [DataCon]
non_nullary_cons)
       | Bool
otherwise                       = ([],           [DataCon]
all_cons)

    no_tag_match_cons :: Bool
no_tag_match_cons = [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [DataCon]
tag_match_cons

    fall_through_eqn :: DynFlags
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
fall_through_eqn DynFlags
dflags
      | Bool
no_tag_match_cons   -- All constructors have arguments
      = case [DataCon]
pat_match_cons of
          []  -> []   -- No constructors; no fall-though case
          [DataCon
_] -> []   -- One constructor; no fall-though case
          [DataCon]
_   ->      -- Two or more constructors; add fall-through of
                      --       (==) _ _ = False
                 [([Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
nlWildPat, Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
nlWildPat], LHsExpr (GhcPass 'Parsed)
false_Expr)]

      | Bool
otherwise -- One or more tag_match cons; add fall-through of
                  -- extract tags compare for equality
      = [([Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
a_Pat, Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
b_Pat],
         DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR,RdrName
ah_RDR), (RdrName
b_RDR,RdrName
bh_RDR)]
                    (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
ah_RDR) RdrName
eqInt_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
bh_RDR)))]

    aux_binds :: BagDerivStuff
aux_binds | Bool
no_tag_match_cons = BagDerivStuff
forall a. Bag a
emptyBag
              | Bool
otherwise         = DerivStuff -> BagDerivStuff
forall a. a -> Bag a
unitBag (DerivStuff -> BagDerivStuff) -> DerivStuff -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ AuxBindSpec -> DerivStuff
DerivAuxBind (AuxBindSpec -> DerivStuff) -> AuxBindSpec -> DerivStuff
forall a b. (a -> b) -> a -> b
$ TyCon -> AuxBindSpec
DerivCon2Tag TyCon
tycon

    method_binds :: DynFlags -> LHsBinds (GhcPass 'Parsed)
method_binds DynFlags
dflags = LHsBind (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a. a -> Bag a
unitBag (DynFlags -> LHsBind (GhcPass 'Parsed)
eq_bind DynFlags
dflags)
    eq_bind :: DynFlags -> LHsBind (GhcPass 'Parsed)
eq_bind DynFlags
dflags = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
2 SrcSpan
loc RdrName
eq_RDR (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. a -> b -> a
const LHsExpr (GhcPass 'Parsed)
true_Expr)
                                 ((DataCon
 -> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
pats_etc [DataCon]
pat_match_cons
                                   [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a. [a] -> [a] -> [a]
++ DynFlags
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
fall_through_eqn DynFlags
dflags)

    ------------------------------------------------------------------
    pats_etc :: DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
pats_etc DataCon
data_con
      = let
            con1_pat :: LPat (GhcPass 'Parsed)
con1_pat = LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed))
-> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
            con2_pat :: LPat (GhcPass 'Parsed)
con2_pat = LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed))
-> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed

            data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con
            con_arity :: Int
con_arity   = [Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
External instance of the constraint type Foldable []
length [Type]
tys_needed
            as_needed :: [RdrName]
as_needed   = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
            bs_needed :: [RdrName]
bs_needed   = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
bs_RDRs
            tys_needed :: [Type]
tys_needed  = DataCon -> [Type]
dataConOrigArgTys DataCon
data_con
        in
        ([Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
con1_pat, Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
con2_pat], [Type] -> [RdrName] -> [RdrName] -> LHsExpr (GhcPass 'Parsed)
nested_eq_expr [Type]
tys_needed [RdrName]
as_needed [RdrName]
bs_needed)
      where
        nested_eq_expr :: [Type] -> [RdrName] -> [RdrName] -> LHsExpr (GhcPass 'Parsed)
nested_eq_expr []  [] [] = LHsExpr (GhcPass 'Parsed)
true_Expr
        nested_eq_expr [Type]
tys [RdrName]
as [RdrName]
bs
          = (LHsExpr (GhcPass 'Parsed)
 -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
External instance of the constraint type Foldable []
foldr1 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
and_Expr (String
-> (Type -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed))
-> [Type]
-> [RdrName]
-> [RdrName]
-> [LHsExpr (GhcPass 'Parsed)]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"nested_eq" Type -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
nested_eq [Type]
tys [RdrName]
as [RdrName]
bs)
          -- Using 'foldr1' here ensures that the derived code is correctly
          -- associated. See #10859.
          where
            nested_eq :: Type -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
nested_eq Type
ty RdrName
a RdrName
b = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (Type
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
eq_Expr Type
ty (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a) (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b))

{-
************************************************************************
*                                                                      *
        Ord instances
*                                                                      *
************************************************************************

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

* Do case on first argument
        case a of
          K1 ... -> rhs_1
          K2 ... -> rhs_2
          ...
          Kn ... -> rhs_n
          _ -> nullary_rhs

* To make rhs_i
     If i = 1, 2, n-1, n, generate a single case.
        rhs_2    case b of
                   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
                 else case b of
                         K3 ... -> ...eq_rhs(K3)....
                         _      -> LT

* To make eq_rhs(K), which knows that
    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
     case con2tag a of a# ->
     case con2tag b of ->
     a# `compare` b#

Several special cases:

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

* Be careful about unlifted comparisons.  When comparing unboxed
  values we can't call the overloaded functions.
  See function unliftedOrdOp

Note [Game plan for deriving Ord]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
comparisons on top of it; see #2130, #4019.  Reason: we don't
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
                            False -> case ==# x y of
                                       True  -> False
                                       False -> True

This being said, we can get away with generating full code only for
'compare' and '<' thus saving us generation of other three operators.
Other operators can be cheaply expressed through '<':
a <= b = not $ b < a
a > b = b < a
a >= b = not $ a < b

So for sufficiently small types (few constructors, or all nullary)
we generate all methods; for large ones we just use 'compare'.

-}

data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT

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

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

------------
eqResult :: OrdOp -> LHsExpr GhcPs
-- Knowing a=b, what is the result for a `op` b?
eqResult :: OrdOp -> LHsExpr (GhcPass 'Parsed)
eqResult OrdOp
OrdCompare = LHsExpr (GhcPass 'Parsed)
eqTag_Expr
eqResult OrdOp
OrdLT      = LHsExpr (GhcPass 'Parsed)
false_Expr
eqResult OrdOp
OrdLE      = LHsExpr (GhcPass 'Parsed)
true_Expr
eqResult OrdOp
OrdGE      = LHsExpr (GhcPass 'Parsed)
true_Expr
eqResult OrdOp
OrdGT      = LHsExpr (GhcPass 'Parsed)
false_Expr

------------
gtResult :: OrdOp -> LHsExpr GhcPs
-- Knowing a>b, what is the result for a `op` b?
gtResult :: OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
OrdCompare = LHsExpr (GhcPass 'Parsed)
gtTag_Expr
gtResult OrdOp
OrdLT      = LHsExpr (GhcPass 'Parsed)
false_Expr
gtResult OrdOp
OrdLE      = LHsExpr (GhcPass 'Parsed)
false_Expr
gtResult OrdOp
OrdGE      = LHsExpr (GhcPass 'Parsed)
true_Expr
gtResult OrdOp
OrdGT      = LHsExpr (GhcPass 'Parsed)
true_Expr

------------
gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Ord_binds SrcSpan
loc TyCon
tycon = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
    (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
-> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ((LHsBinds (GhcPass 'Parsed), BagDerivStuff)
 -> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff))
-> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
-> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
forall a b. (a -> b) -> a -> b
$ if [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [DataCon]
tycon_data_cons -- No data-cons => invoke bale-out case
      then ( LHsBind (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a. a -> Bag a
unitBag (LHsBind (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed))
-> LHsBind (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
2 SrcSpan
loc RdrName
compare_RDR (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. a -> b -> a
const LHsExpr (GhcPass 'Parsed)
eqTag_Expr) []
           , BagDerivStuff
forall a. Bag a
emptyBag)
      else ( LHsBind (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a. a -> Bag a
unitBag (DynFlags -> OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp DynFlags
dflags OrdOp
OrdCompare) LHsBinds (GhcPass 'Parsed)
-> LHsBinds (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a. Bag a -> Bag a -> Bag a
`unionBags` DynFlags -> LHsBinds (GhcPass 'Parsed)
other_ops DynFlags
dflags
           , BagDerivStuff
aux_binds)
  where
    aux_binds :: BagDerivStuff
aux_binds | Bool
single_con_type = BagDerivStuff
forall a. Bag a
emptyBag
              | Bool
otherwise       = DerivStuff -> BagDerivStuff
forall a. a -> Bag a
unitBag (DerivStuff -> BagDerivStuff) -> DerivStuff -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ AuxBindSpec -> DerivStuff
DerivAuxBind (AuxBindSpec -> DerivStuff) -> AuxBindSpec -> DerivStuff
forall a b. (a -> b) -> a -> b
$ TyCon -> AuxBindSpec
DerivCon2Tag TyCon
tycon

        -- Note [Game plan for deriving Ord]
    other_ops :: DynFlags -> LHsBinds (GhcPass 'Parsed)
other_ops DynFlags
dflags
      | (Int
last_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
first_tag) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
<= Int
2     -- 1-3 constructors
        Bool -> Bool -> Bool
|| [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [DataCon]
non_nullary_cons        -- Or it's an enumeration
      = [LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [DynFlags -> OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp DynFlags
dflags OrdOp
OrdLT, LHsBind (GhcPass 'Parsed)
lE, LHsBind (GhcPass 'Parsed)
gT, LHsBind (GhcPass 'Parsed)
gE]
      | Bool
otherwise
      = LHsBinds (GhcPass 'Parsed)
forall a. Bag a
emptyBag

    negate_expr :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
negate_expr = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
not_RDR)
    lE :: LHsBind (GhcPass 'Parsed)
lE = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
le_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
negate_expr (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
lt_RDR) LHsExpr (GhcPass 'Parsed)
b_Expr) LHsExpr (GhcPass 'Parsed)
a_Expr)
    gT :: LHsBind (GhcPass 'Parsed)
gT = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
gt_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
lt_RDR) LHsExpr (GhcPass 'Parsed)
b_Expr) LHsExpr (GhcPass 'Parsed)
a_Expr
    gE :: LHsBind (GhcPass 'Parsed)
gE = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
ge_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
negate_expr (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
lt_RDR) LHsExpr (GhcPass 'Parsed)
a_Expr) LHsExpr (GhcPass 'Parsed)
b_Expr)

    get_tag :: DataCon -> Int
get_tag DataCon
con = DataCon -> Int
dataConTag DataCon
con Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
fIRST_TAG
        -- We want *zero-based* tags, because that's what
        -- con2Tag returns (generated by untag_Expr)!

    tycon_data_cons :: [DataCon]
tycon_data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    single_con_type :: Bool
single_con_type = [DataCon] -> Bool
forall a. [a] -> Bool
isSingleton [DataCon]
tycon_data_cons
    (DataCon
first_con : [DataCon]
_) = [DataCon]
tycon_data_cons
    (DataCon
last_con : [DataCon]
_)  = [DataCon] -> [DataCon]
forall a. [a] -> [a]
reverse [DataCon]
tycon_data_cons
    first_tag :: Int
first_tag       = DataCon -> Int
get_tag DataCon
first_con
    last_tag :: Int
last_tag        = DataCon -> Int
get_tag DataCon
last_con

    ([DataCon]
nullary_cons, [DataCon]
non_nullary_cons) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
isNullarySrcDataCon [DataCon]
tycon_data_cons


    mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs
    -- Returns a binding   op a b = ... compares a and b according to op ....
    mkOrdOp :: DynFlags -> OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp DynFlags
dflags OrdOp
op = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc (OrdOp -> RdrName
ordMethRdr OrdOp
op) [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat]
                                        (DynFlags -> OrdOp -> LHsExpr (GhcPass 'Parsed)
mkOrdOpRhs DynFlags
dflags OrdOp
op)

    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs
    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr (GhcPass 'Parsed)
mkOrdOpRhs DynFlags
dflags OrdOp
op       -- RHS for comparing 'a' and 'b' according to op
      | [DataCon]
nullary_cons [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtMost` Int
2 -- Two nullary or fewer, so use cases
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a_RDR) ([LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
 -> LHsExpr (GhcPass 'Parsed))
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        (DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags
-> OrdOp
-> DataCon
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt DynFlags
dflags OrdOp
op) [DataCon]
tycon_data_cons
        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
        --                   C2 x   -> case b of C2 x -> ....comopare x.... }

      | [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [DataCon]
non_nullary_cons    -- All nullary, so go straight to comparing tags
      = DynFlags -> OrdOp -> LHsExpr (GhcPass 'Parsed)
mkTagCmp DynFlags
dflags OrdOp
op

      | Bool
otherwise                -- Mixed nullary and non-nullary
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a_RDR) ([LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
 -> LHsExpr (GhcPass 'Parsed))
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        ((DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map (DynFlags
-> OrdOp
-> DataCon
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt DynFlags
dflags OrdOp
op) [DataCon]
non_nullary_cons
         [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
forall a. [a] -> [a] -> [a]
++ [LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (DynFlags -> OrdOp -> LHsExpr (GhcPass 'Parsed)
mkTagCmp DynFlags
dflags OrdOp
op)])


    mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon
                  -> LMatch GhcPs (LHsExpr GhcPs)
    -- Make the alternative  (Ki a1 a2 .. av ->
    mkOrdOpAlt :: DynFlags
-> OrdOp
-> DataCon
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt DynFlags
dflags OrdOp
op DataCon
data_con
      = LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed)
                    (DynFlags -> OrdOp -> DataCon -> LHsExpr (GhcPass 'Parsed)
mkInnerRhs DynFlags
dflags OrdOp
op DataCon
data_con)
      where
        as_needed :: [RdrName]
as_needed    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
data_con) [RdrName]
as_RDRs
        data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con

    mkInnerRhs :: DynFlags -> OrdOp -> DataCon -> LHsExpr (GhcPass 'Parsed)
mkInnerRhs DynFlags
dflags OrdOp
op DataCon
data_con
      | Bool
single_con_type
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con ]

      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
first_tag
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]
      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
last_tag
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]

      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
first_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
1
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR) [ LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat (GhcPass 'Parsed)
nlConWildPat DataCon
first_con)
                                             (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op)
                                 , OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]
      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
last_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
1
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR) [ LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat (GhcPass 'Parsed)
nlConWildPat DataCon
last_con)
                                             (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op)
                                 , OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]

      | Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
> Int
last_tag Int -> Int -> Int
forall a. Integral a => a -> a -> a
External instance of the constraint type Integral Int
`div` Int
2  -- lower range is larger
      = DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
bh_RDR) RdrName
ltInt_RDR LHsExpr (GhcPass 'Parsed)
tag_lit)
               (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$  -- Definitely GT
        LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]

      | Bool
otherwise               -- upper range is larger
      = DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
bh_RDR) RdrName
gtInt_RDR LHsExpr (GhcPass 'Parsed)
tag_lit)
               (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$  -- Definitely LT
        LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]
      where
        tag :: Int
tag     = DataCon -> Int
get_tag DataCon
data_con
        tag_lit :: LHsExpr (GhcPass 'Parsed)
tag_lit = HsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (XLitE (GhcPass 'Parsed)
-> HsLit (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Parsed)
NoExtField
noExtField (XHsIntPrim (GhcPass 'Parsed) -> Integer -> HsLit (GhcPass 'Parsed)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim (GhcPass 'Parsed)
NoSourceText (Int -> Integer
forall a. Integral a => a -> Integer
External instance of the constraint type Integral Int
toInteger Int
tag)))

    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
    -- First argument 'a' known to be built with K
    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
    mkInnerEqAlt :: OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
      = LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed) (LHsExpr (GhcPass 'Parsed)
 -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$
        OrdOp -> [Type] -> LHsExpr (GhcPass 'Parsed)
mkCompareFields OrdOp
op (DataCon -> [Type]
dataConOrigArgTys DataCon
data_con)
      where
        data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con
        bs_needed :: [RdrName]
bs_needed    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
data_con) [RdrName]
bs_RDRs

    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs
    -- Both constructors known to be nullary
    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr (GhcPass 'Parsed)
mkTagCmp DynFlags
dflags OrdOp
op =
      DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon[(RdrName
a_RDR, RdrName
ah_RDR),(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        Type -> OrdOp -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
unliftedOrdOp Type
intPrimTy OrdOp
op RdrName
ah_RDR RdrName
bh_RDR

mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
-- where the ai,bi have the given types
mkCompareFields :: OrdOp -> [Type] -> LHsExpr (GhcPass 'Parsed)
mkCompareFields OrdOp
op [Type]
tys
  = [Type] -> [RdrName] -> [RdrName] -> LHsExpr (GhcPass 'Parsed)
go [Type]
tys [RdrName]
as_RDRs [RdrName]
bs_RDRs
  where
    go :: [Type] -> [RdrName] -> [RdrName] -> LHsExpr (GhcPass 'Parsed)
go []   [RdrName]
_      [RdrName]
_          = OrdOp -> LHsExpr (GhcPass 'Parsed)
eqResult OrdOp
op
    go [Type
ty] (RdrName
a:[RdrName]
_)  (RdrName
b:[RdrName]
_)
      | HasDebugCallStack => Type -> Bool
Type -> Bool
External instance of the constraint type HasDebugCallStack
isUnliftedType Type
ty     = Type -> OrdOp -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
      | Bool
otherwise             = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a) (OrdOp -> RdrName
ordMethRdr OrdOp
op) (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b)
    go (Type
ty:[Type]
tys) (RdrName
a:[RdrName]
as) (RdrName
b:[RdrName]
bs) = Type
-> RdrName
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
mk_compare Type
ty RdrName
a RdrName
b
                                  (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op)
                                  ([Type] -> [RdrName] -> [RdrName] -> LHsExpr (GhcPass 'Parsed)
go [Type]
tys [RdrName]
as [RdrName]
bs)
                                  (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op)
    go [Type]
_ [RdrName]
_ [RdrName]
_ = String -> LHsExpr (GhcPass 'Parsed)
forall a. String -> a
panic String
"mkCompareFields"

    -- (mk_compare ty a b) generates
    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
    -- but with suitable special cases for
    mk_compare :: Type
-> RdrName
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
mk_compare Type
ty RdrName
a RdrName
b LHsExpr (GhcPass 'Parsed)
lt LHsExpr (GhcPass 'Parsed)
eq LHsExpr (GhcPass 'Parsed)
gt
      | HasDebugCallStack => Type -> Bool
Type -> Bool
External instance of the constraint type HasDebugCallStack
isUnliftedType Type
ty
      = RdrName
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr (GhcPass 'Parsed)
a_expr LHsExpr (GhcPass 'Parsed)
b_expr LHsExpr (GhcPass 'Parsed)
lt LHsExpr (GhcPass 'Parsed)
eq LHsExpr (GhcPass 'Parsed)
gt
      | Bool
otherwise
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
compare_RDR) LHsExpr (GhcPass 'Parsed)
a_expr) LHsExpr (GhcPass 'Parsed)
b_expr))
          [LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat (GhcPass 'Parsed)
nlNullaryConPat RdrName
ltTag_RDR) LHsExpr (GhcPass 'Parsed)
lt,
           LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat (GhcPass 'Parsed)
nlNullaryConPat RdrName
eqTag_RDR) LHsExpr (GhcPass 'Parsed)
eq,
           LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat (GhcPass 'Parsed)
nlNullaryConPat RdrName
gtTag_RDR) LHsExpr (GhcPass 'Parsed)
gt]
      where
        a_expr :: LHsExpr (GhcPass 'Parsed)
a_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a
        b_expr :: LHsExpr (GhcPass 'Parsed)
b_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b
        (RdrName
lt_op, RdrName
_, RdrName
eq_op, RdrName
_, RdrName
_) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Ord" Type
ty

unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
  = case OrdOp
op of
       OrdOp
OrdCompare -> RdrName
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr (GhcPass 'Parsed)
a_expr LHsExpr (GhcPass 'Parsed)
b_expr
                                     LHsExpr (GhcPass 'Parsed)
ltTag_Expr LHsExpr (GhcPass 'Parsed)
eqTag_Expr LHsExpr (GhcPass 'Parsed)
gtTag_Expr
       OrdOp
OrdLT      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
lt_op
       OrdOp
OrdLE      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
le_op
       OrdOp
OrdGE      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
ge_op
       OrdOp
OrdGT      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
gt_op
  where
   (RdrName
lt_op, RdrName
le_op, RdrName
eq_op, RdrName
ge_op, RdrName
gt_op) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Ord" Type
ty
   wrap :: RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
prim_op = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a_expr RdrName
prim_op LHsExpr (GhcPass 'Parsed)
b_expr
   a_expr :: LHsExpr (GhcPass 'Parsed)
a_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a
   b_expr :: LHsExpr (GhcPass 'Parsed)
b_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b

unliftedCompare :: RdrName -> RdrName
                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to compare
                -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
                                                    -- Three results
                -> LHsExpr GhcPs
-- Return (if a < b then lt else if a == b then eq else gt)
unliftedCompare :: RdrName
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr (GhcPass 'Parsed)
a_expr LHsExpr (GhcPass 'Parsed)
b_expr LHsExpr (GhcPass 'Parsed)
lt LHsExpr (GhcPass 'Parsed)
eq LHsExpr (GhcPass 'Parsed)
gt
  = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
ascribeBool (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a_expr RdrName
lt_op LHsExpr (GhcPass 'Parsed)
b_expr) LHsExpr (GhcPass 'Parsed)
lt (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
                        -- Test (<) first, not (==), because the latter
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
ascribeBool (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a_expr RdrName
eq_op LHsExpr (GhcPass 'Parsed)
b_expr) LHsExpr (GhcPass 'Parsed)
eq LHsExpr (GhcPass 'Parsed)
gt
  where
    ascribeBool :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
ascribeBool LHsExpr (GhcPass 'Parsed)
e = LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
nlExprWithTySig LHsExpr (GhcPass 'Parsed)
e Type
boolTy

nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
nlConWildPat :: DataCon -> LPat (GhcPass 'Parsed)
nlConWildPat DataCon
con = Pat (GhcPass 'Parsed) -> Located (Pat (GhcPass 'Parsed))
forall e. e -> Located e
noLoc (Pat (GhcPass 'Parsed) -> Located (Pat (GhcPass 'Parsed)))
-> Pat (GhcPass 'Parsed) -> Located (Pat (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> Located (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
  { pat_con_ext :: XConPat (GhcPass 'Parsed)
pat_con_ext = XConPat (GhcPass 'Parsed)
NoExtField
noExtField
  , pat_con :: Located (ConLikeP (GhcPass 'Parsed))
pat_con = RdrName -> Located RdrName
forall e. e -> Located e
noLoc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
con
  , pat_args :: HsConPatDetails (GhcPass 'Parsed)
pat_args = HsRecFields (GhcPass 'Parsed) (Located (Pat (GhcPass 'Parsed)))
-> HsConDetails
     (Located (Pat (GhcPass 'Parsed)))
     (HsRecFields (GhcPass 'Parsed) (Located (Pat (GhcPass 'Parsed))))
forall arg rec. rec -> HsConDetails arg rec
RecCon (HsRecFields (GhcPass 'Parsed) (Located (Pat (GhcPass 'Parsed)))
 -> HsConDetails
      (Located (Pat (GhcPass 'Parsed)))
      (HsRecFields (GhcPass 'Parsed) (Located (Pat (GhcPass 'Parsed)))))
-> HsRecFields (GhcPass 'Parsed) (Located (Pat (GhcPass 'Parsed)))
-> HsConDetails
     (Located (Pat (GhcPass 'Parsed)))
     (HsRecFields (GhcPass 'Parsed) (Located (Pat (GhcPass 'Parsed))))
forall a b. (a -> b) -> a -> b
$ HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Int) -> HsRecFields p arg
HsRecFields
      { rec_flds :: [LHsRecField (GhcPass 'Parsed) (Located (Pat (GhcPass 'Parsed)))]
rec_flds = []
      , rec_dotdot :: Maybe (Located Int)
rec_dotdot = Maybe (Located Int)
forall a. Maybe a
Nothing }
  }

{-
************************************************************************
*                                                                      *
        Enum instances
*                                                                      *
************************************************************************

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

    toEnum i = tag2con_Foo i

    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]

    -- or, really...
    enumFrom a
      = case con2tag_Foo a of
          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)

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

For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
-}

gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Enum_binds SrcSpan
loc TyCon
tycon = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
    (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
-> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (DynFlags -> LHsBinds (GhcPass 'Parsed)
method_binds DynFlags
dflags, BagDerivStuff
aux_binds)
  where
    method_binds :: DynFlags -> LHsBinds (GhcPass 'Parsed)
method_binds DynFlags
dflags = [LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag
      [ DynFlags -> LHsBind (GhcPass 'Parsed)
succ_enum      DynFlags
dflags
      , DynFlags -> LHsBind (GhcPass 'Parsed)
pred_enum      DynFlags
dflags
      , DynFlags -> LHsBind (GhcPass 'Parsed)
to_enum        DynFlags
dflags
      , DynFlags -> LHsBind (GhcPass 'Parsed)
enum_from      DynFlags
dflags -- [0 ..]
      , DynFlags -> LHsBind (GhcPass 'Parsed)
enum_from_then DynFlags
dflags -- [0, 1 ..]
      , DynFlags -> LHsBind (GhcPass 'Parsed)
from_enum      DynFlags
dflags
      ]
    aux_binds :: BagDerivStuff
aux_binds = [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ([DerivStuff] -> BagDerivStuff) -> [DerivStuff] -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ (AuxBindSpec -> DerivStuff) -> [AuxBindSpec] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map AuxBindSpec -> DerivStuff
DerivAuxBind
                  [TyCon -> AuxBindSpec
DerivCon2Tag TyCon
tycon, TyCon -> AuxBindSpec
DerivTag2Con TyCon
tycon, TyCon -> AuxBindSpec
DerivMaxTag TyCon
tycon]

    occ_nm :: String
occ_nm = TyCon -> String
forall a. NamedThing a => a -> String
External instance of the constraint type NamedThing TyCon
getOccString TyCon
tycon

    succ_enum :: DynFlags -> LHsBind (GhcPass 'Parsed)
succ_enum DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
succ_RDR [LPat (GhcPass 'Parsed)
a_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
eq_RDR [IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DynFlags -> TyCon -> RdrName
maxtag_RDR DynFlags
dflags TyCon
tycon),
                               IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR]])
             (String -> String -> String -> LHsExpr (GhcPass 'Parsed)
illegal_Expr String
"succ" String
occ_nm String
"tried to take `succ' of last tag in enumeration")
             (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon))
                    (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
plus_RDR [IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR],
                                        Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
1]))

    pred_enum :: DynFlags -> LHsBind (GhcPass 'Parsed)
pred_enum DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
pred_RDR [LPat (GhcPass 'Parsed)
a_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
eq_RDR [Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0,
                               IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR]])
             (String -> String -> String -> LHsExpr (GhcPass 'Parsed)
illegal_Expr String
"pred" String
occ_nm String
"tried to take `pred' of first tag in enumeration")
             (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon))
                      (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
plus_RDR
                            [ IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR]
                            , HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsInt (GhcPass 'Parsed) -> IntegralLit -> HsLit (GhcPass 'Parsed)
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt XHsInt (GhcPass 'Parsed)
NoExtField
noExtField
                                                (Int -> IntegralLit
forall a. Integral a => a -> IntegralLit
External instance of the constraint type Integral Int
mkIntegralLit (-Int
1 :: Int)))]))

    to_enum :: DynFlags -> LHsBind (GhcPass 'Parsed)
to_enum DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
toEnum_RDR [LPat (GhcPass 'Parsed)
a_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
and_RDR
                [IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
ge_RDR [IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a_RDR, Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0],
                 IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
le_RDR [ IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a_RDR
                                 , IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DynFlags -> TyCon -> RdrName
maxtag_RDR DynFlags
dflags TyCon
tycon)]])
             (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps (DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon) [RdrName
IdP (GhcPass 'Parsed)
a_RDR])
             (String -> RdrName -> LHsExpr (GhcPass 'Parsed)
illegal_toEnum_tag String
occ_nm (DynFlags -> TyCon -> RdrName
maxtag_RDR DynFlags
dflags TyCon
tycon))

    enum_from :: DynFlags -> LHsBind (GhcPass 'Parsed)
enum_from DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFrom_RDR [LPat (GhcPass 'Parsed)
a_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
map_RDR
                [IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon),
                 LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
enum_from_to_Expr
                            (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR])
                            (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DynFlags -> TyCon -> RdrName
maxtag_RDR DynFlags
dflags TyCon
tycon)))]

    enum_from_then :: DynFlags -> LHsBind (GhcPass 'Parsed)
enum_from_then DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFromThen_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR), (RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
map_RDR [DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon]) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
            LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
enum_from_then_to_Expr
                    (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR])
                    (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
bh_RDR])
                    (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf  (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
gt_RDR [IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR],
                                               IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
bh_RDR]])
                           (Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0)
                           (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DynFlags -> TyCon -> RdrName
maxtag_RDR DynFlags
dflags TyCon
tycon))
                           ))

    from_enum :: DynFlags -> LHsBind (GhcPass 'Parsed)
from_enum DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
fromEnum_RDR [LPat (GhcPass 'Parsed)
a_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR])

{-
************************************************************************
*                                                                      *
        Bounded instances
*                                                                      *
************************************************************************
-}

gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Bounded_binds SrcSpan
loc TyCon
tycon
  | TyCon -> Bool
isEnumerationTyCon TyCon
tycon
  = ([LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [ LHsBind (GhcPass 'Parsed)
min_bound_enum, LHsBind (GhcPass 'Parsed)
max_bound_enum ], BagDerivStuff
forall a. Bag a
emptyBag)
  | Bool
otherwise
  = ASSERT(isSingleton data_cons)
    ([LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [ LHsBind (GhcPass 'Parsed)
min_bound_1con, LHsBind (GhcPass 'Parsed)
max_bound_1con ], BagDerivStuff
forall a. Bag a
emptyBag)
  where
    data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon

    ----- enum-flavored: ---------------------------
    min_bound_enum :: LHsBind (GhcPass 'Parsed)
min_bound_enum = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
data_con_1_RDR)
    max_bound_enum :: LHsBind (GhcPass 'Parsed)
max_bound_enum = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
maxBound_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
data_con_N_RDR)

    data_con_1 :: DataCon
data_con_1     = [DataCon] -> DataCon
forall a. [a] -> a
head [DataCon]
data_cons
    data_con_N :: DataCon
data_con_N     = [DataCon] -> DataCon
forall a. [a] -> a
last [DataCon]
data_cons
    data_con_1_RDR :: RdrName
data_con_1_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con_1
    data_con_N_RDR :: RdrName
data_con_N_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con_N

    ----- single-constructor-flavored: -------------
    arity :: Int
arity          = DataCon -> Int
dataConSourceArity DataCon
data_con_1

    min_bound_1con :: LHsBind (GhcPass 'Parsed)
min_bound_1con = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
                     IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
data_con_1_RDR (Int -> RdrName -> [RdrName]
forall a. Int -> a -> [a]
replicate Int
arity RdrName
minBound_RDR)
    max_bound_1con :: LHsBind (GhcPass 'Parsed)
max_bound_1con = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
maxBound_RDR (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
                     IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
data_con_1_RDR (Int -> RdrName -> [RdrName]
forall a. Int -> a -> [a]
replicate Int
arity RdrName
maxBound_RDR)

{-
************************************************************************
*                                                                      *
        Ix instances
*                                                                      *
************************************************************************

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

    -- Generate code for unsafeIndex, because using index leads
    -- to lots of redundant range tests
    unsafeIndex c@(a, b) d
      = case (con2tag_Foo d -# con2tag_Foo a) of
               r# -> I# r#

    inRange (a, b) c
      = let
            p_tag = con2tag_Foo c
        in
        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b

    -- or, really...
    inRange (a, b) c
      = case (con2tag_Foo a)   of { a_tag ->
        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
        }}}
\end{verbatim}
(modulo suitable case-ification to handle the unlifted tags)

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).
-}

gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)

gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Ix_binds SrcSpan
loc TyCon
tycon = do
    DynFlags
dflags <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags
    (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
-> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ((LHsBinds (GhcPass 'Parsed), BagDerivStuff)
 -> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff))
-> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
-> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
forall a b. (a -> b) -> a -> b
$ if TyCon -> Bool
isEnumerationTyCon TyCon
tycon
      then (DynFlags -> LHsBinds (GhcPass 'Parsed)
enum_ixes DynFlags
dflags, [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ([DerivStuff] -> BagDerivStuff) -> [DerivStuff] -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ (AuxBindSpec -> DerivStuff) -> [AuxBindSpec] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map AuxBindSpec -> DerivStuff
DerivAuxBind
                   [TyCon -> AuxBindSpec
DerivCon2Tag TyCon
tycon, TyCon -> AuxBindSpec
DerivTag2Con TyCon
tycon, TyCon -> AuxBindSpec
DerivMaxTag TyCon
tycon])
      else (LHsBinds (GhcPass 'Parsed)
single_con_ixes, DerivStuff -> BagDerivStuff
forall a. a -> Bag a
unitBag (AuxBindSpec -> DerivStuff
DerivAuxBind (TyCon -> AuxBindSpec
DerivCon2Tag TyCon
tycon)))
  where
    --------------------------------------------------------------
    enum_ixes :: DynFlags -> LHsBinds (GhcPass 'Parsed)
enum_ixes DynFlags
dflags = [LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag
      [ DynFlags -> LHsBind (GhcPass 'Parsed)
enum_range   DynFlags
dflags
      , DynFlags -> LHsBind (GhcPass 'Parsed)
enum_index   DynFlags
dflags
      , DynFlags -> LHsBind (GhcPass 'Parsed)
enum_inRange DynFlags
dflags
      ]

    enum_range :: DynFlags -> LHsBind (GhcPass 'Parsed)
enum_range DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] Boxity
Boxed] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
map_RDR [DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon]) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
              LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
enum_from_to_Expr
                        (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
ah_RDR])
                        (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
bh_RDR]))

    enum_index :: DynFlags -> LHsBind (GhcPass 'Parsed)
enum_index DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
                [Pat (GhcPass 'Parsed) -> Located (Pat (GhcPass 'Parsed))
forall e. e -> Located e
noLoc (XAsPat (GhcPass 'Parsed)
-> Located (IdP (GhcPass 'Parsed))
-> LPat (GhcPass 'Parsed)
-> Pat (GhcPass 'Parsed)
forall p. XAsPat p -> Located (IdP p) -> LPat p -> Pat p
AsPat XAsPat (GhcPass 'Parsed)
NoExtField
noExtField (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
c_RDR)
                           ([LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
nlWildPat] Boxity
Boxed)),
                                LPat (GhcPass 'Parsed)
d_Pat] (
           DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR)] (
           DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
d_RDR, RdrName
dh_RDR)] (
           let
                rhs :: LHsExpr (GhcPass 'Parsed)
rhs = IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR [RdrName
IdP (GhcPass 'Parsed)
c_RDR]
           in
           LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase
             (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
dh_RDR) RdrName
minusInt_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
ah_RDR))
             [LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
c_RDR) LHsExpr (GhcPass 'Parsed)
rhs]
           ))
        )

    -- This produces something like `(ch >= ah) && (ch <= bh)`
    enum_inRange :: DynFlags -> LHsBind (GhcPass 'Parsed)
enum_inRange DynFlags
dflags
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] Boxity
Boxed, LPat (GhcPass 'Parsed)
c_Pat] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
a_RDR, RdrName
ah_RDR)] (
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
b_RDR, RdrName
bh_RDR)] (
          DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName
c_RDR, RdrName
ch_RDR)] (
          -- This used to use `if`, which interacts badly with RebindableSyntax.
          -- See #11396.
          IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
and_RDR
              [ LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
ch_RDR) RdrName
geInt_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
ah_RDR)
              , LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
ch_RDR) RdrName
leInt_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
bh_RDR)
              ]
          )))

    --------------------------------------------------------------
    single_con_ixes :: LHsBinds (GhcPass 'Parsed)
single_con_ixes
      = [LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)
single_con_range, LHsBind (GhcPass 'Parsed)
single_con_index, LHsBind (GhcPass 'Parsed)
single_con_inRange]

    data_con :: DataCon
data_con
      = case TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tycon of -- just checking...
          Maybe DataCon
Nothing -> String -> DataCon
forall a. String -> a
panic String
"get_Ix_binds"
          Just DataCon
dc -> DataCon
dc

    con_arity :: Int
con_arity    = DataCon -> Int
dataConSourceArity DataCon
data_con
    data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con

    as_needed :: [RdrName]
as_needed = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
    bs_needed :: [RdrName]
bs_needed = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
bs_RDRs
    cs_needed :: [RdrName]
cs_needed = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
cs_RDRs

    con_pat :: [RdrName] -> LPat (GhcPass 'Parsed)
con_pat  [RdrName]
xs  = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
xs
    con_expr :: LHsExpr (GhcPass 'Parsed)
con_expr     = IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
data_con_RDR [RdrName]
[IdP (GhcPass 'Parsed)]
cs_needed

    --------------------------------------------------------------
    single_con_range :: LHsBind (GhcPass 'Parsed)
single_con_range
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR
          [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        HsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (HsStmtContext GhcRn
-> [ExprLStmt (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> HsExpr (GhcPass 'Parsed)
mkHsComp HsStmtContext GhcRn
forall p. HsStmtContext p
ListComp [ExprLStmt (GhcPass 'Parsed)]
stmts LHsExpr (GhcPass 'Parsed)
con_expr)
      where
        stmts :: [ExprLStmt (GhcPass 'Parsed)]
stmts = String
-> (RdrName -> RdrName -> RdrName -> ExprLStmt (GhcPass 'Parsed))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [ExprLStmt (GhcPass 'Parsed)]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_range" RdrName -> RdrName -> RdrName -> ExprLStmt (GhcPass 'Parsed)
mk_qual [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed

        mk_qual :: RdrName -> RdrName -> RdrName -> ExprLStmt (GhcPass 'Parsed)
mk_qual RdrName
a RdrName
b RdrName
c = StmtLR
  (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (StmtLR
   (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
 -> ExprLStmt (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (bodyR :: * -> *).
LPat (GhcPass 'Parsed)
-> Located (bodyR (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (Located (bodyR (GhcPass 'Parsed)))
mkPsBindStmt (IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
c)
                                 (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
range_RDR)
                                          ([IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP (GhcPass 'Parsed)
a,RdrName
IdP (GhcPass 'Parsed)
b]))

    ----------------
    single_con_index :: LHsBind (GhcPass 'Parsed)
single_con_index
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
                [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed,
                 [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
cs_needed]
        -- 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.
                ([(RdrName, RdrName, RdrName)] -> LHsExpr (GhcPass 'Parsed)
mk_index ([(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)]
forall a. [a] -> [a]
reverse ([(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)])
-> [(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)]
forall a b. (a -> b) -> a -> b
$ [RdrName]
-> [RdrName] -> [RdrName] -> [(RdrName, RdrName, RdrName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed))
      where
        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
        mk_index :: [(RdrName, RdrName, RdrName)] -> LHsExpr (GhcPass 'Parsed)
mk_index []        = Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0
        mk_index [(RdrName
l,RdrName
u,RdrName
i)] = RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
forall {id :: Pass}.
(IsPass id, IdGhcP id ~ RdrName) =>
RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
mk_one RdrName
l RdrName
u RdrName
i
        mk_index ((RdrName
l,RdrName
u,RdrName
i) : [(RdrName, RdrName, RdrName)]
rest)
          = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (
                RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
forall {id :: Pass}.
(IsPass id, IdGhcP id ~ RdrName) =>
RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
mk_one RdrName
l RdrName
u RdrName
i
            ) RdrName
plus_RDR (
                LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (
                    (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
unsafeRangeSize_RDR)
                             ([IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP (GhcPass 'Parsed)
l,RdrName
IdP (GhcPass 'Parsed)
u]))
                ) RdrName
times_RDR ([(RdrName, RdrName, RdrName)] -> LHsExpr (GhcPass 'Parsed)
mk_index [(RdrName, RdrName, RdrName)]
rest)
           )
        mk_one :: RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass id)
mk_one RdrName
l RdrName
u RdrName
i
          = IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
Evidence bound by a type signature of the constraint type IsPass id
nlHsApps RdrName
IdP (GhcPass id)
unsafeIndex_RDR [[IdP (GhcPass id)] -> LHsExpr (GhcPass id)
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP (GhcPass id)
l,RdrName
IdP (GhcPass id)
u], IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass id)
i]

    ------------------
    single_con_inRange :: LHsBind (GhcPass 'Parsed)
single_con_inRange
      = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR
                [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed,
                 [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
cs_needed] (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          if Int
con_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
0
             -- If the product type has no fields, inRange is trivially true
             -- (see #12853).
             then LHsExpr (GhcPass 'Parsed)
true_Expr
             else (LHsExpr (GhcPass 'Parsed)
 -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
External instance of the constraint type Foldable []
foldl1 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
and_Expr (String
-> (RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [LHsExpr (GhcPass 'Parsed)]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_inRange" RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
forall {id :: Pass}.
(IsPass id, IdGhcP id ~ RdrName) =>
RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
in_range
                    [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed)
      where
        in_range :: RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass id)
in_range RdrName
a RdrName
b RdrName
c = IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
Evidence bound by a type signature of the constraint type IsPass id
nlHsApps RdrName
IdP (GhcPass id)
inRange_RDR [[IdP (GhcPass id)] -> LHsExpr (GhcPass id)
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP (GhcPass id)
a,RdrName
IdP (GhcPass id)
b], IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass id)
c]

{-
************************************************************************
*                                                                      *
        Read instances
*                                                                      *
************************************************************************

Example

  infix 4 %%
  data T = Int %% Int
         | T1 { f1 :: Int }
         | T2 T

instance Read T where
  readPrec =
    parens
    ( prec 4 (
        do x <- ReadP.step Read.readPrec
           expectP (Symbol "%%")
           y <- ReadP.step Read.readPrec
           return (x %% y))
      +++
      prec (appPrec+1) (
        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
        -- Record construction binds even more tightly than application
        do expectP (Ident "T1")
           expectP (Punc '{')
           x          <- Read.readField "f1" (ReadP.reset readPrec)
           expectP (Punc '}')
           return (T1 { f1 = x }))
      +++
      prec appPrec (
        do expectP (Ident "T2")
           x <- ReadP.step Read.readPrec
           return (T2 x))
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault


Note [Use expectP]
~~~~~~~~~~~~~~~~~~
Note that we use
   expectP (Ident "T1")
rather than
   Ident "T1" <- lexP
The latter desugares to inline code for matching the Ident and the
string, and this can be very voluminous. The former is much more
compact.  Cf #7258, although that also concerned non-linearity in
the occurrence analyser, a separate issue.

Note [Read for empty data types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
What should we get for this?  (#7931)
   data Emp deriving( Read )   -- No data constructors

Here we want
  read "[]" :: [Emp]   to succeed, returning []
So we do NOT want
   instance Read Emp where
     readPrec = error "urk"
Rather we want
   instance Read Emp where
     readPred = pfail   -- Same as choose []

Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
These instances are also useful for Read (Either Int Emp), where
we want to be able to parse (Left 3) just fine.
-}

gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
               -> (LHsBinds GhcPs, BagDerivStuff)

gen_Read_binds :: (Name -> Fixity)
-> SrcSpan -> TyCon -> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Read_binds Name -> Fixity
get_fixity SrcSpan
loc TyCon
tycon
  = ([LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)
read_prec, LHsBind (GhcPass 'Parsed)
default_readlist, LHsBind (GhcPass 'Parsed)
default_readlistprec], BagDerivStuff
forall a. Bag a
emptyBag)
  where
    -----------------------------------------------------------------------
    default_readlist :: LHsBind (GhcPass 'Parsed)
default_readlist
        = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
readList_RDR     (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
readListDefault_RDR)

    default_readlistprec :: LHsBind (GhcPass 'Parsed)
default_readlistprec
        = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
readListPrec_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
readListPrecDefault_RDR)
    -----------------------------------------------------------------------

    data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    ([DataCon]
nullary_cons, [DataCon]
non_nullary_cons) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
isNullarySrcDataCon [DataCon]
data_cons

    read_prec :: LHsBind (GhcPass 'Parsed)
read_prec = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
readPrec_RDR LHsExpr (GhcPass 'Parsed)
rhs
      where
        rhs :: LHsExpr (GhcPass 'Parsed)
rhs | [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [DataCon]
data_cons -- See Note [Read for empty data types]
            = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
pfail_RDR
            | Bool
otherwise
            = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
parens_RDR)
                      ((LHsExpr (GhcPass 'Parsed)
 -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
External instance of the constraint type Foldable []
foldr1 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_alt ([LHsExpr (GhcPass 'Parsed)]
read_nullary_cons [LHsExpr (GhcPass 'Parsed)]
-> [LHsExpr (GhcPass 'Parsed)] -> [LHsExpr (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++
                                      [LHsExpr (GhcPass 'Parsed)]
read_non_nullary_cons))

    read_non_nullary_cons :: [LHsExpr (GhcPass 'Parsed)]
read_non_nullary_cons = (DataCon -> LHsExpr (GhcPass 'Parsed))
-> [DataCon] -> [LHsExpr (GhcPass 'Parsed)]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LHsExpr (GhcPass 'Parsed)
read_non_nullary_con [DataCon]
non_nullary_cons

    read_nullary_cons :: [LHsExpr (GhcPass 'Parsed)]
read_nullary_cons
      = case [DataCon]
nullary_cons of
            []    -> []
            [DataCon
con] -> [HsStmtContext GhcRn
-> [ExprLStmt (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlHsDo HsStmtContext GhcRn
forall p. HsStmtContext p
DoExpr (DataCon -> [ExprLStmt (GhcPass 'Parsed)]
forall {a} {idL :: Pass}.
NamedThing a =>
a
-> [Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))]
External instance of the constraint type NamedThing DataCon
match_con DataCon
con [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [StmtLR
  (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (StmtLR
   (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
 -> ExprLStmt (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
External instance of the constraint type IsPass 'Parsed
mkLastStmt (DataCon -> [IdGhcP 'Parsed] -> LHsExpr (GhcPass 'Parsed)
forall {thing} {id :: Pass}.
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
External instance of the constraint type NamedThing DataCon
result_expr DataCon
con [])])]
            [DataCon]
_     -> [LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
choose_RDR)
                              ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList ((DataCon -> LHsExpr (GhcPass 'Parsed))
-> [DataCon] -> [LHsExpr (GhcPass 'Parsed)]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LHsExpr (GhcPass 'Parsed)
forall {thing} {a :: Pass}.
(NamedThing thing, IsPass a, IdGhcP a ~ RdrName) =>
thing -> LHsExpr (GhcPass a)
External instance of the constraint type IsPass 'Parsed
External instance of the constraint type NamedThing DataCon
mk_pair [DataCon]
nullary_cons))]
        -- NB For operators the parens around (:=:) are matched by the
        -- enclosing "parens" call, so here we must match the naked
        -- data_con_str con

    match_con :: a
-> [Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))]
match_con a
con | String -> Bool
isSym String
con_str = [String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
symbol_pat String
con_str]
                  | Bool
otherwise     = String
-> [Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))]
forall {idL :: Pass}.
String
-> [Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))]
ident_h_pat  String
con_str
                  where
                    con_str :: String
con_str = a -> String
forall a. NamedThing a => a -> String
Evidence bound by a type signature of the constraint type NamedThing a
data_con_str a
con
        -- For nullary constructors we must match Ident s for normal constrs
        -- and   Symbol s   for operators

    mk_pair :: thing -> LHsExpr (GhcPass a)
mk_pair thing
con = [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
forall (a :: Pass). [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsTupleExpr [HsLit (GhcPass a) -> LHsExpr (GhcPass a)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass a)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (thing -> String
forall a. NamedThing a => a -> String
Evidence bound by a type signature of the constraint type NamedThing thing
data_con_str thing
con)),
                                  thing -> [IdGhcP a] -> LHsExpr (GhcPass a)
forall {thing} {id :: Pass}.
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
Evidence bound by a type signature of the constraint type IdGhcP a ~ RdrName
Evidence bound by a type signature of the constraint type IsPass a
Evidence bound by a type signature of the constraint type NamedThing thing
result_expr thing
con []]

    read_non_nullary_con :: DataCon -> LHsExpr (GhcPass 'Parsed)
read_non_nullary_con DataCon
data_con
      | Bool
is_infix  = Integer
-> [ExprLStmt (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
mk_parser Integer
infix_prec  [ExprLStmt (GhcPass 'Parsed)]
infix_stmts  LHsExpr (GhcPass 'Parsed)
body
      | Bool
is_record = Integer
-> [ExprLStmt (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
mk_parser Integer
record_prec [ExprLStmt (GhcPass 'Parsed)]
record_stmts LHsExpr (GhcPass 'Parsed)
body
--              Using these two lines instead allows the derived
--              read for infix and record bindings to read the prefix form
--      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
--      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
      | Bool
otherwise = LHsExpr (GhcPass 'Parsed)
prefix_parser
      where
        body :: LHsExpr (GhcPass 'Parsed)
body = DataCon -> [IdGhcP 'Parsed] -> LHsExpr (GhcPass 'Parsed)
forall {thing} {id :: Pass}.
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
External instance of the constraint type NamedThing DataCon
result_expr DataCon
data_con [RdrName]
[IdGhcP 'Parsed]
as_needed
        con_str :: String
con_str = DataCon -> String
forall a. NamedThing a => a -> String
External instance of the constraint type NamedThing DataCon
data_con_str DataCon
data_con

        prefix_parser :: LHsExpr (GhcPass 'Parsed)
prefix_parser = Integer
-> [ExprLStmt (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
mk_parser Integer
prefix_prec [ExprLStmt (GhcPass 'Parsed)]
prefix_stmts LHsExpr (GhcPass 'Parsed)
body

        read_prefix_con :: [ExprLStmt (GhcPass 'Parsed)]
read_prefix_con
            | String -> Bool
isSym String
con_str = [String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
"(", String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
symbol_pat String
con_str, String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
")"]
            | Bool
otherwise     = String -> [ExprLStmt (GhcPass 'Parsed)]
forall {idL :: Pass}.
String
-> [Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))]
ident_h_pat String
con_str

        read_infix_con :: [ExprLStmt (GhcPass 'Parsed)]
read_infix_con
            | String -> Bool
isSym String
con_str = [String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
symbol_pat String
con_str]
            | Bool
otherwise     = [String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
"`"] [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ String -> [ExprLStmt (GhcPass 'Parsed)]
forall {idL :: Pass}.
String
-> [Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))]
ident_h_pat String
con_str [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
"`"]

        prefix_stmts :: [ExprLStmt (GhcPass 'Parsed)]
prefix_stmts            -- T a b c
          = [ExprLStmt (GhcPass 'Parsed)]
read_prefix_con [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [ExprLStmt (GhcPass 'Parsed)]
read_args

        infix_stmts :: [ExprLStmt (GhcPass 'Parsed)]
infix_stmts             -- a %% b, or  a `T` b
          = [ExprLStmt (GhcPass 'Parsed)
read_a1]
            [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [ExprLStmt (GhcPass 'Parsed)]
read_infix_con
            [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [ExprLStmt (GhcPass 'Parsed)
read_a2]

        record_stmts :: [ExprLStmt (GhcPass 'Parsed)]
record_stmts            -- T { f1 = a, f2 = b }
          = [ExprLStmt (GhcPass 'Parsed)]
read_prefix_con
            [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
"{"]
            [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [[ExprLStmt (GhcPass 'Parsed)]] -> [ExprLStmt (GhcPass 'Parsed)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat ([ExprLStmt (GhcPass 'Parsed)]
-> [[ExprLStmt (GhcPass 'Parsed)]]
-> [[ExprLStmt (GhcPass 'Parsed)]]
forall a. a -> [a] -> [a]
intersperse [String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
","] [[ExprLStmt (GhcPass 'Parsed)]]
field_stmts)
            [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [String -> ExprLStmt (GhcPass 'Parsed)
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
"}"]

        field_stmts :: [[ExprLStmt (GhcPass 'Parsed)]]
field_stmts  = String
-> (FastString -> RdrName -> [ExprLStmt (GhcPass 'Parsed)])
-> [FastString]
-> [RdrName]
-> [[ExprLStmt (GhcPass 'Parsed)]]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"lbl_stmts" FastString -> RdrName -> [ExprLStmt (GhcPass 'Parsed)]
read_field [FastString]
labels [RdrName]
as_needed

        con_arity :: Int
con_arity    = DataCon -> Int
dataConSourceArity DataCon
data_con
        labels :: [FastString]
labels       = (FieldLbl Name -> FastString) -> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel ([FieldLbl Name] -> [FastString])
-> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
data_con
        dc_nm :: Name
dc_nm        = DataCon -> Name
forall a. NamedThing a => a -> Name
External instance of the constraint type NamedThing DataCon
getName DataCon
data_con
        is_infix :: Bool
is_infix     = DataCon -> Bool
dataConIsInfix DataCon
data_con
        is_record :: Bool
is_record    = [FastString]
labels [FastString] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
0
        as_needed :: [RdrName]
as_needed    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
        read_args :: [ExprLStmt (GhcPass 'Parsed)]
read_args    = String
-> (RdrName -> Type -> ExprLStmt (GhcPass 'Parsed))
-> [RdrName]
-> [Type]
-> [ExprLStmt (GhcPass 'Parsed)]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Read_binds" RdrName -> Type -> ExprLStmt (GhcPass 'Parsed)
read_arg [RdrName]
as_needed (DataCon -> [Type]
dataConOrigArgTys DataCon
data_con)
        (ExprLStmt (GhcPass 'Parsed)
read_a1:ExprLStmt (GhcPass 'Parsed)
read_a2:[ExprLStmt (GhcPass 'Parsed)]
_) = [ExprLStmt (GhcPass 'Parsed)]
read_args

        prefix_prec :: Integer
prefix_prec = Integer
appPrecedence
        infix_prec :: Integer
infix_prec  = (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
dc_nm
        record_prec :: Integer
record_prec = Integer
appPrecedence Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
External instance of the constraint type Num Integer
+ Integer
1 -- Record construction binds even more tightly
                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})

    ------------------------------------------------------------------------
    --          Helpers
    ------------------------------------------------------------------------
    mk_alt :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_alt LHsExpr (GhcPass 'Parsed)
e1 LHsExpr (GhcPass 'Parsed)
e2       = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
alt_RDR LHsExpr (GhcPass 'Parsed)
e2                         -- e1 +++ e2
    mk_parser :: Integer
-> [ExprLStmt (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
mk_parser Integer
p [ExprLStmt (GhcPass 'Parsed)]
ss LHsExpr (GhcPass 'Parsed)
b   = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
prec_RDR [Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
p                -- prec p (do { ss ; b })
                                           , HsStmtContext GhcRn
-> [ExprLStmt (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlHsDo HsStmtContext GhcRn
forall p. HsStmtContext p
DoExpr ([ExprLStmt (GhcPass 'Parsed)]
ss [ExprLStmt (GhcPass 'Parsed)]
-> [ExprLStmt (GhcPass 'Parsed)] -> [ExprLStmt (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [StmtLR
  (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (StmtLR
   (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
 -> ExprLStmt (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
External instance of the constraint type IsPass 'Parsed
mkLastStmt LHsExpr (GhcPass 'Parsed)
b])]
    con_app :: thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
con_app thing
con [IdGhcP id]
as     = IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps (thing -> RdrName
forall thing. NamedThing thing => thing -> RdrName
Evidence bound by a type signature of the constraint type NamedThing thing
getRdrName thing
con) [IdGhcP id]
[IdP (GhcPass id)]
as                -- con as
    result_expr :: thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
result_expr thing
con [IdGhcP id]
as = LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
Evidence bound by a type signature of the constraint type IsPass id
nlHsApp (IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass id)
returnM_RDR) (thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
forall {thing} {id :: Pass}.
(NamedThing thing, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
Evidence bound by a type signature of the constraint type IdGhcP id ~ RdrName
Evidence bound by a type signature of the constraint type NamedThing thing
con_app thing
con [IdGhcP id]
as) -- return (con as)

    -- For constructors and field labels ending in '#', we hackily
    -- let the lexer generate two tokens, and look for both in sequence
    -- Thus [Ident "I"; Symbol "#"].  See #5041
    ident_h_pat :: String
-> [Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))]
ident_h_pat String
s | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [ String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
ident_pat String
ss, String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
symbol_pat String
"#" ]
                  | Bool
otherwise                    = [ String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall {idL :: Pass}.
String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
ident_pat String
s ]

    bindLex :: LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
bindLex LHsExpr (GhcPass 'Parsed)
pat  = StmtLR (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall e. e -> Located e
noLoc (LHsExpr (GhcPass 'Parsed)
-> StmtLR
     (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (bodyR :: * -> *) (idL :: Pass).
Located (bodyR (GhcPass 'Parsed))
-> StmtLR
     (GhcPass idL) (GhcPass 'Parsed) (Located (bodyR (GhcPass 'Parsed)))
mkBodyStmt (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
expectP_RDR) LHsExpr (GhcPass 'Parsed)
pat))  -- expectP p
                   -- See Note [Use expectP]
    ident_pat :: String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
ident_pat  String
s = LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall {idL :: Pass}.
LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
bindLex (LHsExpr (GhcPass 'Parsed)
 -> Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
ident_RDR  [HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]  -- expectP (Ident "foo")
    symbol_pat :: String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
symbol_pat String
s = LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall {idL :: Pass}.
LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
bindLex (LHsExpr (GhcPass 'Parsed)
 -> Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
symbol_RDR [HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]  -- expectP (Symbol ">>")
    read_punc :: String
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
read_punc String
c  = LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall {idL :: Pass}.
LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
bindLex (LHsExpr (GhcPass 'Parsed)
 -> Located
      (StmtLR
         (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))))
-> LHsExpr (GhcPass 'Parsed)
-> Located
     (StmtLR
        (GhcPass idL) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
punc_RDR   [HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
c)]  -- expectP (Punc "<")

    data_con_str :: a -> String
data_con_str a
con = OccName -> String
occNameString (a -> OccName
forall a. NamedThing a => a -> OccName
Evidence bound by a type signature of the constraint type NamedThing a
getOccName a
con)

    read_arg :: RdrName -> Type -> ExprLStmt (GhcPass 'Parsed)
read_arg RdrName
a Type
ty = ASSERT( not (isUnliftedType ty) )
                    StmtLR
  (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (bodyR :: * -> *).
LPat (GhcPass 'Parsed)
-> Located (bodyR (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (Located (bodyR (GhcPass 'Parsed)))
mkPsBindStmt (IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
a) (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
step_RDR [RdrName
IdP (GhcPass 'Parsed)
readPrec_RDR]))

    -- When reading field labels we might encounter
    --      a  = 3
    --      _a = 3
    -- or   (#) = 4
    -- Note the parens!
    read_field :: FastString -> RdrName -> [ExprLStmt (GhcPass 'Parsed)]
read_field FastString
lbl RdrName
a =
        [StmtLR
  (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
-> ExprLStmt (GhcPass 'Parsed)
forall e. e -> Located e
noLoc
          (LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> StmtLR
     (GhcPass 'Parsed) (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (bodyR :: * -> *).
LPat (GhcPass 'Parsed)
-> Located (bodyR (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (Located (bodyR (GhcPass 'Parsed)))
mkPsBindStmt
            (IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
a)
            (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp
              LHsExpr (GhcPass 'Parsed)
read_field
              (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP (GhcPass 'Parsed)
reset_RDR [RdrName
IdP (GhcPass 'Parsed)
readPrec_RDR])
            )
          )
        ]
        where
          lbl_str :: String
lbl_str = FastString -> String
unpackFS FastString
lbl
          mk_read_field :: IdGhcP id -> String -> LHsExpr (GhcPass id)
mk_read_field IdGhcP id
read_field_rdr String
lbl
              = IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
Evidence bound by a type signature of the constraint type IsPass id
nlHsApps IdGhcP id
IdP (GhcPass id)
read_field_rdr [HsLit (GhcPass id) -> LHsExpr (GhcPass id)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass id)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
lbl)]
          read_field :: LHsExpr (GhcPass 'Parsed)
read_field
              | String -> Bool
isSym String
lbl_str
              = IdGhcP 'Parsed -> String -> LHsExpr (GhcPass 'Parsed)
forall {id :: Pass}.
IsPass id =>
IdGhcP id -> String -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
mk_read_field RdrName
IdGhcP 'Parsed
readSymField_RDR String
lbl_str
              | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
lbl_str -- #14918
              = IdGhcP 'Parsed -> String -> LHsExpr (GhcPass 'Parsed)
forall {id :: Pass}.
IsPass id =>
IdGhcP id -> String -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
mk_read_field RdrName
IdGhcP 'Parsed
readFieldHash_RDR String
ss
              | Bool
otherwise
              = IdGhcP 'Parsed -> String -> LHsExpr (GhcPass 'Parsed)
forall {id :: Pass}.
IsPass id =>
IdGhcP id -> String -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
mk_read_field RdrName
IdGhcP 'Parsed
readField_RDR String
lbl_str

{-
************************************************************************
*                                                                      *
        Show instances
*                                                                      *
************************************************************************

Example

    infixr 5 :^:

    data Tree a =  Leaf a  |  Tree a :^: Tree a

    instance (Show a) => Show (Tree a) where

        showsPrec d (Leaf m) = showParen (d > app_prec) showStr
          where
             showStr = showString "Leaf " . showsPrec (app_prec+1) m

        showsPrec d (u :^: v) = showParen (d > up_prec) showStr
          where
             showStr = showsPrec (up_prec+1) u .
                       showString " :^: "      .
                       showsPrec (up_prec+1) v
                -- Note: right-associativity of :^: ignored

    up_prec  = 5    -- Precedence of :^:
    app_prec = 10   -- Application has precedence one more than
                    -- the most tightly-binding operator
-}

gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
               -> (LHsBinds GhcPs, BagDerivStuff)

gen_Show_binds :: (Name -> Fixity)
-> SrcSpan -> TyCon -> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Show_binds Name -> Fixity
get_fixity SrcSpan
loc TyCon
tycon
  = (LHsBind (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a. a -> Bag a
unitBag LHsBind (GhcPass 'Parsed)
shows_prec, BagDerivStuff
forall a. Bag a
emptyBag)
  where
    data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
    shows_prec :: LHsBind (GhcPass 'Parsed)
shows_prec = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
2 SrcSpan
loc RdrName
showsPrec_RDR LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a. a -> a
id ((DataCon
 -> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
pats_etc [DataCon]
data_cons)
    comma_space :: LHsExpr (GhcPass 'Parsed)
comma_space = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
showCommaSpace_RDR

    pats_etc :: DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
pats_etc DataCon
data_con
      | Bool
nullary_con =  -- skip the showParen junk...
         ASSERT(null bs_needed)
         ([Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
nlWildPat, Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
con_pat], String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
op_con_str)
      | Bool
otherwise   =
         ([Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
a_Pat, Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
con_pat],
          LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
showParen_Expr (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
a_Expr RdrName
ge_RDR (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit
                         (XHsInt (GhcPass 'Parsed) -> IntegralLit -> HsLit (GhcPass 'Parsed)
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt XHsInt (GhcPass 'Parsed)
NoExtField
noExtField (Integer -> IntegralLit
forall a. Integral a => a -> IntegralLit
External instance of the constraint type Integral Integer
mkIntegralLit Integer
con_prec_plus_one))))
                         (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr [LHsExpr (GhcPass 'Parsed)]
show_thingies)))
        where
             data_con_RDR :: RdrName
data_con_RDR  = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con
             con_arity :: Int
con_arity     = DataCon -> Int
dataConSourceArity DataCon
data_con
             bs_needed :: [RdrName]
bs_needed     = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
bs_RDRs
             arg_tys :: [Type]
arg_tys       = DataCon -> [Type]
dataConOrigArgTys DataCon
data_con         -- Correspond 1-1 with bs_needed
             con_pat :: LPat (GhcPass 'Parsed)
con_pat       = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
             nullary_con :: Bool
nullary_con   = Int
con_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
0
             labels :: [FastString]
labels        = (FieldLbl Name -> FastString) -> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel ([FieldLbl Name] -> [FastString])
-> [FieldLbl Name] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
data_con
             lab_fields :: Int
lab_fields    = [FastString] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
External instance of the constraint type Foldable []
length [FastString]
labels
             record_syntax :: Bool
record_syntax = Int
lab_fields Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
> Int
0

             dc_nm :: Name
dc_nm          = DataCon -> Name
forall a. NamedThing a => a -> Name
External instance of the constraint type NamedThing DataCon
getName DataCon
data_con
             dc_occ_nm :: OccName
dc_occ_nm      = DataCon -> OccName
forall a. NamedThing a => a -> OccName
External instance of the constraint type NamedThing DataCon
getOccName DataCon
data_con
             con_str :: String
con_str        = OccName -> String
occNameString OccName
dc_occ_nm
             op_con_str :: String
op_con_str     = String -> String
wrapOpParens String
con_str
             backquote_str :: String
backquote_str  = String -> String
wrapOpBackquotes String
con_str

             show_thingies :: [LHsExpr (GhcPass 'Parsed)]
show_thingies
                | Bool
is_infix      = [LHsExpr (GhcPass 'Parsed)
show_arg1, String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
backquote_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "), LHsExpr (GhcPass 'Parsed)
show_arg2]
                | Bool
record_syntax = String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {") LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> [LHsExpr (GhcPass 'Parsed)]
forall a. a -> [a] -> [a]
:
                                  [LHsExpr (GhcPass 'Parsed)]
show_record_args [LHsExpr (GhcPass 'Parsed)]
-> [LHsExpr (GhcPass 'Parsed)] -> [LHsExpr (GhcPass 'Parsed)]
forall a. [a] -> [a] -> [a]
++ [String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
"}"]
                | Bool
otherwise     = String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> [LHsExpr (GhcPass 'Parsed)]
forall a. a -> [a] -> [a]
: [LHsExpr (GhcPass 'Parsed)]
show_prefix_args

             show_label :: FastString -> LHsExpr (GhcPass 'Parsed)
show_label FastString
l = String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = ")
                        -- Note the spaces around the "=" sign.  If we
                        -- don't have them then we get Foo { x=-1 } and
                        -- the "=-" parses as a single lexeme.  Only the
                        -- space after the '=' is necessary, but it
                        -- seems tidier to have them both sides.
                 where
                   nm :: String
nm       = String -> String
wrapOpParens (FastString -> String
unpackFS FastString
l)

             show_args :: [LHsExpr (GhcPass 'Parsed)]
show_args               = String
-> (RdrName -> Type -> LHsExpr (GhcPass 'Parsed))
-> [RdrName]
-> [Type]
-> [LHsExpr (GhcPass 'Parsed)]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Show_binds" RdrName -> Type -> LHsExpr (GhcPass 'Parsed)
show_arg [RdrName]
bs_needed [Type]
arg_tys
             (LHsExpr (GhcPass 'Parsed)
show_arg1:LHsExpr (GhcPass 'Parsed)
show_arg2:[LHsExpr (GhcPass 'Parsed)]
_) = [LHsExpr (GhcPass 'Parsed)]
show_args
             show_prefix_args :: [LHsExpr (GhcPass 'Parsed)]
show_prefix_args        = LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> [LHsExpr (GhcPass 'Parsed)]
forall a. a -> [a] -> [a]
intersperse (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
showSpace_RDR) [LHsExpr (GhcPass 'Parsed)]
show_args

                -- Assumption for record syntax: no of fields == no of
                -- labelled fields (and in same order)
             show_record_args :: [LHsExpr (GhcPass 'Parsed)]
show_record_args = [[LHsExpr (GhcPass 'Parsed)]] -> [LHsExpr (GhcPass 'Parsed)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
External instance of the constraint type Foldable []
concat ([[LHsExpr (GhcPass 'Parsed)]] -> [LHsExpr (GhcPass 'Parsed)])
-> [[LHsExpr (GhcPass 'Parsed)]] -> [LHsExpr (GhcPass 'Parsed)]
forall a b. (a -> b) -> a -> b
$
                                [LHsExpr (GhcPass 'Parsed)]
-> [[LHsExpr (GhcPass 'Parsed)]] -> [[LHsExpr (GhcPass 'Parsed)]]
forall a. a -> [a] -> [a]
intersperse [LHsExpr (GhcPass 'Parsed)
comma_space] ([[LHsExpr (GhcPass 'Parsed)]] -> [[LHsExpr (GhcPass 'Parsed)]])
-> [[LHsExpr (GhcPass 'Parsed)]] -> [[LHsExpr (GhcPass 'Parsed)]]
forall a b. (a -> b) -> a -> b
$
                                [ [FastString -> LHsExpr (GhcPass 'Parsed)
show_label FastString
lbl, LHsExpr (GhcPass 'Parsed)
arg]
                                | (FastString
lbl,LHsExpr (GhcPass 'Parsed)
arg) <- String
-> [FastString]
-> [LHsExpr (GhcPass 'Parsed)]
-> [(FastString, LHsExpr (GhcPass 'Parsed))]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"gen_Show_binds"
                                                        [FastString]
labels [LHsExpr (GhcPass 'Parsed)]
show_args ]

             show_arg :: RdrName -> Type -> LHsExpr GhcPs
             show_arg :: RdrName -> Type -> LHsExpr (GhcPass 'Parsed)
show_arg RdrName
b Type
arg_ty
                 | HasDebugCallStack => Type -> Bool
Type -> Bool
External instance of the constraint type HasDebugCallStack
isUnliftedType Type
arg_ty
                 -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
                 = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
with_conv (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
                    IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
compose_RDR
                        [LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_shows_app LHsExpr (GhcPass 'Parsed)
boxed_arg, String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
postfixMod]
                 | Bool
otherwise
                 = Integer -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_showsPrec_app Integer
arg_prec LHsExpr (GhcPass 'Parsed)
arg
               where
                 arg :: LHsExpr (GhcPass 'Parsed)
arg        = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b
                 boxed_arg :: LHsExpr (GhcPass 'Parsed)
boxed_arg  = String
-> LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
box String
"Show" LHsExpr (GhcPass 'Parsed)
arg Type
arg_ty
                 postfixMod :: String
postfixMod = String -> [(Type, String)] -> Type -> String
forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
"Show" [(Type, String)]
postfixModTbl Type
arg_ty
                 with_conv :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
with_conv LHsExpr (GhcPass 'Parsed)
expr
                    | (Just String
conv) <- [(Type, String)] -> Type -> Maybe String
forall a. [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, String)]
primConvTbl Type
arg_ty =
                        [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr
                            [ String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
                            , LHsExpr (GhcPass 'Parsed)
expr
                            , String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
")"
                            ]
                    | Bool
otherwise = LHsExpr (GhcPass 'Parsed)
expr

                -- Fixity stuff
             is_infix :: Bool
is_infix = DataCon -> Bool
dataConIsInfix DataCon
data_con
             con_prec_plus_one :: Integer
con_prec_plus_one = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
External instance of the constraint type Num Integer
+ Bool -> (Name -> Fixity) -> Name -> Integer
getPrec Bool
is_infix Name -> Fixity
get_fixity Name
dc_nm
             arg_prec :: Integer
arg_prec | Bool
record_syntax = Integer
0  -- Record fields don't need parens
                      | Bool
otherwise     = Integer
con_prec_plus_one

wrapOpParens :: String -> String
wrapOpParens :: String -> String
wrapOpParens String
s | String -> Bool
isSym String
s   = Char
'(' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
               | Bool
otherwise = String
s

wrapOpBackquotes :: String -> String
wrapOpBackquotes :: String -> String
wrapOpBackquotes String
s | String -> Bool
isSym String
s   = String
s
                   | Bool
otherwise = Char
'`' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`"

isSym :: String -> Bool
isSym :: String -> Bool
isSym String
""      = Bool
False
isSym (Char
c : String
_) = Char -> Bool
startsVarSym Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsConSym Char
c

-- | showString :: String -> ShowS
mk_showString_app :: String -> LHsExpr GhcPs
mk_showString_app :: String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
str = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
showString_RDR) (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
str))

-- | showsPrec :: Show a => Int -> a -> ShowS
mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_showsPrec_app :: Integer -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_showsPrec_app Integer
p LHsExpr (GhcPass 'Parsed)
x
  = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
showsPrec_RDR [HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsInt (GhcPass 'Parsed) -> IntegralLit -> HsLit (GhcPass 'Parsed)
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt XHsInt (GhcPass 'Parsed)
NoExtField
noExtField (Integer -> IntegralLit
forall a. Integral a => a -> IntegralLit
External instance of the constraint type Integral Integer
mkIntegralLit Integer
p)), LHsExpr (GhcPass 'Parsed)
x]

-- | shows :: Show a => a -> ShowS
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_shows_app LHsExpr (GhcPass 'Parsed)
x = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
shows_RDR) LHsExpr (GhcPass 'Parsed)
x

getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
getPrec Bool
is_infix Name -> Fixity
get_fixity Name
nm
  | Bool -> Bool
not Bool
is_infix   = Integer
appPrecedence
  | Bool
otherwise      = (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
nm

appPrecedence :: Integer
appPrecedence :: Integer
appPrecedence = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
External instance of the constraint type Num Integer
External instance of the constraint type Integral Int
fromIntegral Int
maxPrecedence Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
External instance of the constraint type Num Integer
+ Integer
1
  -- One more than the precedence of the most
  -- tightly-binding operator

getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
nm
   = case Name -> Fixity
get_fixity Name
nm of
        Fixity SourceText
_ Int
x FixityDirection
_assoc -> Int -> Integer
forall a b. (Integral a, Num b) => a -> b
External instance of the constraint type Num Integer
External instance of the constraint type Integral Int
fromIntegral Int
x
          -- NB: the Report says that associativity is not taken
          --     into account for either Read or Show; hence we
          --     ignore associativity here

{-
************************************************************************
*                                                                      *
        Data instances
*                                                                      *
************************************************************************

From the data type

  data T a b = T1 a b | T2

we generate

  $cT1 = mkDataCon $dT "T1" Prefix
  $cT2 = mkDataCon $dT "T2" Prefix
  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]
  -- the [] is for field labels.

  instance (Data a, Data b) => Data (T a b) where
    gfoldl k z (T1 a b) = z T `k` a `k` b
    gfoldl k z T2           = z T2
    -- ToDo: add gmapT,Q,M, gfoldr

    gunfold k z c = case conIndex c of
                        I# 1# -> k (k (z T1))
                        I# 2# -> z T2

    toConstr (T1 _ _) = $cT1
    toConstr T2       = $cT2

    dataTypeOf _ = $dT

    dataCast1 = gcast1   -- If T :: * -> *
    dataCast2 = gcast2   -- if T :: * -> * -> *
-}

gen_Data_binds :: SrcSpan
               -> TyCon                 -- For data families, this is the
                                        --  *representation* TyCon
               -> TcM (LHsBinds GhcPs,  -- The method bindings
                       BagDerivStuff)   -- Auxiliary bindings
gen_Data_binds :: SrcSpan -> TyCon -> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Data_binds SrcSpan
loc TyCon
rep_tc
  = do { DynFlags
dflags  <- IOEnv (Env TcGblEnv TcLclEnv) DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
External instance of the constraint type forall env. ContainsDynFlags env => HasDynFlags (IOEnv env)
External instance of the constraint type forall gbl lcl. ContainsDynFlags (Env gbl lcl)
getDynFlags

       -- Make unique names for the data type and constructor
       -- auxiliary bindings.  Start with the name of the TyCon/DataCon
       -- but that might not be unique: see #12245.
       ; OccName
dt_occ  <- (OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc (OccName -> OccSet -> OccName
mkDataTOcc (TyCon -> OccName
forall a. NamedThing a => a -> OccName
External instance of the constraint type NamedThing TyCon
getOccName TyCon
rep_tc))
       ; [OccName]
dc_occs <- (DataCon -> TcM OccName)
-> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) [OccName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM ((OccSet -> OccName) -> TcM OccName
chooseUniqueOccTc ((OccSet -> OccName) -> TcM OccName)
-> (DataCon -> OccSet -> OccName) -> DataCon -> TcM OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> OccSet -> OccName
mkDataCOcc (OccName -> OccSet -> OccName)
-> (DataCon -> OccName) -> DataCon -> OccSet -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> OccName
forall a. NamedThing a => a -> OccName
External instance of the constraint type NamedThing DataCon
getOccName)
                         (TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc)
       ; let dt_rdr :: RdrName
dt_rdr  = OccName -> RdrName
mkRdrUnqual OccName
dt_occ
             dc_rdrs :: [RdrName]
dc_rdrs = (OccName -> RdrName) -> [OccName] -> [RdrName]
forall a b. (a -> b) -> [a] -> [b]
map OccName -> RdrName
mkRdrUnqual [OccName]
dc_occs

       -- OK, now do the work
       ; (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
-> TcM (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return (DynFlags
-> RdrName
-> [RdrName]
-> SrcSpan
-> TyCon
-> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_data DynFlags
dflags RdrName
dt_rdr [RdrName]
dc_rdrs SrcSpan
loc TyCon
rep_tc) }

gen_data :: DynFlags -> RdrName -> [RdrName]
         -> SrcSpan -> TyCon
         -> (LHsBinds GhcPs,      -- The method bindings
             BagDerivStuff)       -- Auxiliary bindings
gen_data :: DynFlags
-> RdrName
-> [RdrName]
-> SrcSpan
-> TyCon
-> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_data DynFlags
dflags RdrName
data_type_name [RdrName]
constr_names SrcSpan
loc TyCon
rep_tc
  = ([LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)
gfoldl_bind, LHsBind (GhcPass 'Parsed)
gunfold_bind, LHsBind (GhcPass 'Parsed)
toCon_bind, LHsBind (GhcPass 'Parsed)
dataTypeOf_bind]
     LHsBinds (GhcPass 'Parsed)
-> LHsBinds (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a. Bag a -> Bag a -> Bag a
`unionBags` LHsBinds (GhcPass 'Parsed)
gcast_binds,
                -- Auxiliary definitions: the data type and constructors
     [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ( DerivStuff
genDataTyCon
               DerivStuff -> [DerivStuff] -> [DerivStuff]
forall a. a -> [a] -> [a]
: (DataCon -> RdrName -> DerivStuff)
-> [DataCon] -> [RdrName] -> [DerivStuff]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith DataCon -> RdrName -> DerivStuff
genDataDataCon [DataCon]
data_cons [RdrName]
constr_names ) )
  where
    data_cons :: [DataCon]
data_cons  = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
    n_cons :: Int
n_cons     = [DataCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
External instance of the constraint type Foldable []
length [DataCon]
data_cons
    one_constr :: Bool
one_constr = Int
n_cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
1
    genDataTyCon :: DerivStuff
    genDataTyCon :: DerivStuff
genDataTyCon        --  $dT
      = (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)) -> DerivStuff
DerivHsBind (SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
data_type_name LHsExpr (GhcPass 'Parsed)
rhs,
                     SrcSpan -> Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTypeSig (GhcPass 'Parsed)
-> [Located (IdP (GhcPass 'Parsed))]
-> LHsSigWcType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig (GhcPass 'Parsed)
NoExtField
noExtField [SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
data_type_name] LHsSigWcType (GhcPass 'Parsed)
sig_ty))

    sig_ty :: LHsSigWcType (GhcPass 'Parsed)
sig_ty = LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
mkLHsSigWcType (IdP (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar RdrName
IdP (GhcPass 'Parsed)
dataType_RDR)
    ctx :: SDocContext
ctx    = DynFlags -> SDocContext
initDefaultSDocContext DynFlags
dflags
    rhs :: LHsExpr (GhcPass 'Parsed)
rhs    = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
mkDataType_RDR
             LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApp` HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable TyCon
ppr TyCon
rep_tc)))
             LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApp` [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList ((RdrName -> LHsExpr (GhcPass 'Parsed))
-> [RdrName] -> [LHsExpr (GhcPass 'Parsed)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [RdrName]
constr_names)

    genDataDataCon :: DataCon -> RdrName -> DerivStuff
    genDataDataCon :: DataCon -> RdrName -> DerivStuff
genDataDataCon DataCon
dc RdrName
constr_name       --  $cT1 etc
      = (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)) -> DerivStuff
DerivHsBind (SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
constr_name LHsExpr (GhcPass 'Parsed)
rhs,
                     SrcSpan -> Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTypeSig (GhcPass 'Parsed)
-> [Located (IdP (GhcPass 'Parsed))]
-> LHsSigWcType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig (GhcPass 'Parsed)
NoExtField
noExtField [SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
constr_name] LHsSigWcType (GhcPass 'Parsed)
sig_ty))
      where
        sig_ty :: LHsSigWcType (GhcPass 'Parsed)
sig_ty   = LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
mkLHsSigWcType (IdP (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar RdrName
IdP (GhcPass 'Parsed)
constr_RDR)
        rhs :: LHsExpr (GhcPass 'Parsed)
rhs      = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApps RdrName
IdP (GhcPass 'Parsed)
mkConstr_RDR [LHsExpr (GhcPass 'Parsed)]
constr_args

        constr_args :: [LHsExpr (GhcPass 'Parsed)]
constr_args
           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag
               IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (RdrName
IdP (GhcPass 'Parsed)
data_type_name)                     -- DataType
             , HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (OccName -> String
occNameString OccName
dc_occ))  -- String name
             , [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList  [LHsExpr (GhcPass 'Parsed)]
labels                               -- Field labels
             , IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
fixity ]                             -- Fixity

        labels :: [LHsExpr (GhcPass 'Parsed)]
labels   = (FieldLbl Name -> LHsExpr (GhcPass 'Parsed))
-> [FieldLbl Name] -> [LHsExpr (GhcPass 'Parsed)]
forall a b. (a -> b) -> [a] -> [b]
map (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (FieldLbl Name -> HsLit (GhcPass 'Parsed))
-> FieldLbl Name
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String -> HsLit (GhcPass 'Parsed))
-> (FieldLbl Name -> String)
-> FieldLbl Name
-> HsLit (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS (FastString -> String)
-> (FieldLbl Name -> FastString) -> FieldLbl Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLbl Name -> FastString
forall a. FieldLbl a -> FastString
flLabel)
                       (DataCon -> [FieldLbl Name]
dataConFieldLabels DataCon
dc)
        dc_occ :: OccName
dc_occ   = DataCon -> OccName
forall a. NamedThing a => a -> OccName
External instance of the constraint type NamedThing DataCon
getOccName DataCon
dc
        is_infix :: Bool
is_infix = OccName -> Bool
isDataSymOcc OccName
dc_occ
        fixity :: RdrName
fixity | Bool
is_infix  = RdrName
infix_RDR
               | Bool
otherwise = RdrName
prefix_RDR

        ------------ gfoldl
    gfoldl_bind :: LHsBind (GhcPass 'Parsed)
gfoldl_bind = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
3 SrcSpan
loc RdrName
gfoldl_RDR LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a. a -> a
id ((DataCon
 -> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
gfoldl_eqn [DataCon]
data_cons)

    gfoldl_eqn :: DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
gfoldl_eqn DataCon
con
      = ([IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
k_RDR, Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
z_Pat, RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
con_name [RdrName]
as_needed],
                   (LHsExpr (GhcPass 'Parsed) -> RdrName -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> [RdrName]
-> LHsExpr (GhcPass 'Parsed)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldl' LHsExpr (GhcPass 'Parsed) -> RdrName -> LHsExpr (GhcPass 'Parsed)
mk_k_app (LHsExpr (GhcPass 'Parsed)
z_Expr LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApp` IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
con_name) [RdrName]
as_needed)
                   where
                     con_name ::  RdrName
                     con_name :: RdrName
con_name = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
con
                     as_needed :: [RdrName]
as_needed = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
con) [RdrName]
as_RDRs
                     mk_k_app :: LHsExpr (GhcPass 'Parsed) -> RdrName -> LHsExpr (GhcPass 'Parsed)
mk_k_app LHsExpr (GhcPass 'Parsed)
e RdrName
v = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp LHsExpr (GhcPass 'Parsed)
e RdrName
IdP (GhcPass 'Parsed)
k_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
v))

        ------------ gunfold
    gunfold_bind :: LHsBind (GhcPass 'Parsed)
gunfold_bind = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc
                     RdrName
gunfold_RDR
                     [LPat (GhcPass 'Parsed)
k_Pat, LPat (GhcPass 'Parsed)
z_Pat, if Bool
one_constr then LPat (GhcPass 'Parsed)
nlWildPat else LPat (GhcPass 'Parsed)
c_Pat]
                     LHsExpr (GhcPass 'Parsed)
gunfold_rhs

    gunfold_rhs :: LHsExpr (GhcPass 'Parsed)
gunfold_rhs
        | Bool
one_constr = DataCon -> LHsExpr (GhcPass 'Parsed)
mk_unfold_rhs ([DataCon] -> DataCon
forall a. [a] -> a
head [DataCon]
data_cons)   -- No need for case
        | Bool
otherwise  = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
conIndex_RDR LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApp` LHsExpr (GhcPass 'Parsed)
c_Expr)
                                ((DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
gunfold_alt [DataCon]
data_cons)

    gunfold_alt :: DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
gunfold_alt DataCon
dc = LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (DataCon -> Located (Pat (GhcPass 'Parsed))
mk_unfold_pat DataCon
dc) (DataCon -> LHsExpr (GhcPass 'Parsed)
mk_unfold_rhs DataCon
dc)
    mk_unfold_rhs :: DataCon -> LHsExpr (GhcPass 'Parsed)
mk_unfold_rhs DataCon
dc = (LHsExpr (GhcPass 'Parsed)
 -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp
                           (LHsExpr (GhcPass 'Parsed)
z_Expr LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApp` IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
dc))
                           (Int -> LHsExpr (GhcPass 'Parsed) -> [LHsExpr (GhcPass 'Parsed)]
forall a. Int -> a -> [a]
replicate (DataCon -> Int
dataConSourceArity DataCon
dc) (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
k_RDR))

    mk_unfold_pat :: DataCon -> Located (Pat (GhcPass 'Parsed))
mk_unfold_pat DataCon
dc    -- Last one is a wild-pat, to avoid
                        -- redundant test, and annoying warning
      | Int
tagInt -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
-Int
fIRST_TAG Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
n_consInt -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
-Int
1 = Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
nlWildPat   -- Last constructor
      | Bool
otherwise = RdrName -> [LPat (GhcPass 'Parsed)] -> LPat (GhcPass 'Parsed)
nlConPat RdrName
intDataCon_RDR
                             [HsLit (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
nlLitPat (XHsIntPrim (GhcPass 'Parsed) -> Integer -> HsLit (GhcPass 'Parsed)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim (GhcPass 'Parsed)
NoSourceText (Int -> Integer
forall a. Integral a => a -> Integer
External instance of the constraint type Integral Int
toInteger Int
tag))]
      where
        tag :: Int
tag = DataCon -> Int
dataConTag DataCon
dc

        ------------ toConstr
    toCon_bind :: LHsBind (GhcPass 'Parsed)
toCon_bind = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
1 SrcSpan
loc RdrName
toConstr_RDR LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a. a -> a
id
                     ((DataCon
 -> RdrName
 -> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [RdrName]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith DataCon
-> RdrName
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
forall {id :: Pass}.
DataCon
-> IdGhcP id
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass id))
to_con_eqn [DataCon]
data_cons [RdrName]
constr_names)
    to_con_eqn :: DataCon
-> IdGhcP id
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass id))
to_con_eqn DataCon
dc IdGhcP id
con_name = ([DataCon -> LPat (GhcPass 'Parsed)
nlWildConPat DataCon
dc], IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar IdGhcP id
IdP (GhcPass id)
con_name)

        ------------ dataTypeOf
    dataTypeOf_bind :: LHsBind (GhcPass 'Parsed)
dataTypeOf_bind = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind
                        SrcSpan
loc
                        RdrName
dataTypeOf_RDR
                        [LPat (GhcPass 'Parsed)
nlWildPat]
                        (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
data_type_name)

        ------------ gcast1/2
        -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *
        --               or    dataCast2 x = gcast2 s  -- if T :: * -> * -> *
        -- (or nothing if T has neither of these two types)

        -- But care is needed for data families:
        -- If we have   data family D a
        --              data instance D (a,b,c) = A | B deriving( Data )
        -- and we want  instance ... => Data (D [(a,b,c)]) where ...
        -- then we need     dataCast1 x = gcast1 x
        -- because D :: * -> *
        -- even though rep_tc has kind * -> * -> * -> *
        -- Hence looking for the kind of fam_tc not rep_tc
        -- See #4896
    tycon_kind :: Type
tycon_kind = case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
rep_tc of
                    Just (TyCon
fam_tc, [Type]
_) -> TyCon -> Type
tyConKind TyCon
fam_tc
                    Maybe (TyCon, [Type])
Nothing          -> TyCon -> Type
tyConKind TyCon
rep_tc
    gcast_binds :: LHsBinds (GhcPass 'Parsed)
gcast_binds | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
External instance of the constraint type HasDebugCallStack
`tcEqKind` Type
kind1 = RdrName -> RdrName -> LHsBinds (GhcPass 'Parsed)
mk_gcast RdrName
dataCast1_RDR RdrName
gcast1_RDR
                | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
External instance of the constraint type HasDebugCallStack
`tcEqKind` Type
kind2 = RdrName -> RdrName -> LHsBinds (GhcPass 'Parsed)
mk_gcast RdrName
dataCast2_RDR RdrName
gcast2_RDR
                | Bool
otherwise                 = LHsBinds (GhcPass 'Parsed)
forall a. Bag a
emptyBag
    mk_gcast :: RdrName -> RdrName -> LHsBinds (GhcPass 'Parsed)
mk_gcast RdrName
dataCast_RDR RdrName
gcast_RDR
      = LHsBind (GhcPass 'Parsed) -> LHsBinds (GhcPass 'Parsed)
forall a. a -> Bag a
unitBag (SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
dataCast_RDR [IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
f_RDR]
                                 (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
gcast_RDR LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApp` IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
f_RDR))


kind1, kind2 :: Kind
kind1 :: Type
kind1 = Type
typeToTypeKind
kind2 :: Type
kind2 = Type
liftedTypeKind Type -> Type -> Type
`mkVisFunTy` Type
kind1

gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
    constr_RDR, dataType_RDR,
    eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,
    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,
    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,
    eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
    eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,
    eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
    eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
    eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,
    eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
    extendWord8_RDR, extendInt8_RDR,
    extendWord16_RDR, extendInt16_RDR :: RdrName
gfoldl_RDR :: RdrName
gfoldl_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"gfoldl")
gunfold_RDR :: RdrName
gunfold_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"gunfold")
toConstr_RDR :: RdrName
toConstr_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"toConstr")
dataTypeOf_RDR :: RdrName
dataTypeOf_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"dataTypeOf")
dataCast1_RDR :: RdrName
dataCast1_RDR  = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"dataCast1")
dataCast2_RDR :: RdrName
dataCast2_RDR  = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"dataCast2")
gcast1_RDR :: RdrName
gcast1_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
tYPEABLE (String -> FastString
fsLit String
"gcast1")
gcast2_RDR :: RdrName
gcast2_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
tYPEABLE (String -> FastString
fsLit String
"gcast2")
mkConstr_RDR :: RdrName
mkConstr_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"mkConstr")
constr_RDR :: RdrName
constr_RDR     = Module -> FastString -> RdrName
tcQual_RDR   Module
gENERICS (String -> FastString
fsLit String
"Constr")
mkDataType_RDR :: RdrName
mkDataType_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"mkDataType")
dataType_RDR :: RdrName
dataType_RDR   = Module -> FastString -> RdrName
tcQual_RDR   Module
gENERICS (String -> FastString
fsLit String
"DataType")
conIndex_RDR :: RdrName
conIndex_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gENERICS (String -> FastString
fsLit String
"constrIndex")
prefix_RDR :: RdrName
prefix_RDR     = Module -> FastString -> RdrName
dataQual_RDR Module
gENERICS (String -> FastString
fsLit String
"Prefix")
infix_RDR :: RdrName
infix_RDR      = Module -> FastString -> RdrName
dataQual_RDR Module
gENERICS (String -> FastString
fsLit String
"Infix")

eqChar_RDR :: RdrName
eqChar_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqChar#")
ltChar_RDR :: RdrName
ltChar_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltChar#")
leChar_RDR :: RdrName
leChar_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leChar#")
gtChar_RDR :: RdrName
gtChar_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtChar#")
geChar_RDR :: RdrName
geChar_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geChar#")

eqInt_RDR :: RdrName
eqInt_RDR      = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"==#")
ltInt_RDR :: RdrName
ltInt_RDR      = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"<#" )
leInt_RDR :: RdrName
leInt_RDR      = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"<=#")
gtInt_RDR :: RdrName
gtInt_RDR      = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
">#" )
geInt_RDR :: RdrName
geInt_RDR      = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
">=#")

eqInt8_RDR :: RdrName
eqInt8_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt8#")
ltInt8_RDR :: RdrName
ltInt8_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt8#" )
leInt8_RDR :: RdrName
leInt8_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leInt8#")
gtInt8_RDR :: RdrName
gtInt8_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt8#" )
geInt8_RDR :: RdrName
geInt8_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geInt8#")

eqInt16_RDR :: RdrName
eqInt16_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt16#")
ltInt16_RDR :: RdrName
ltInt16_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt16#" )
leInt16_RDR :: RdrName
leInt16_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leInt16#")
gtInt16_RDR :: RdrName
gtInt16_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt16#" )
geInt16_RDR :: RdrName
geInt16_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geInt16#")

eqWord_RDR :: RdrName
eqWord_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord#")
ltWord_RDR :: RdrName
ltWord_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord#")
leWord_RDR :: RdrName
leWord_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leWord#")
gtWord_RDR :: RdrName
gtWord_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord#")
geWord_RDR :: RdrName
geWord_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geWord#")

eqWord8_RDR :: RdrName
eqWord8_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord8#")
ltWord8_RDR :: RdrName
ltWord8_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord8#" )
leWord8_RDR :: RdrName
leWord8_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leWord8#")
gtWord8_RDR :: RdrName
gtWord8_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord8#" )
geWord8_RDR :: RdrName
geWord8_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geWord8#")

eqWord16_RDR :: RdrName
eqWord16_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord16#")
ltWord16_RDR :: RdrName
ltWord16_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord16#" )
leWord16_RDR :: RdrName
leWord16_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leWord16#")
gtWord16_RDR :: RdrName
gtWord16_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord16#" )
geWord16_RDR :: RdrName
geWord16_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geWord16#")

eqAddr_RDR :: RdrName
eqAddr_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqAddr#")
ltAddr_RDR :: RdrName
ltAddr_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltAddr#")
leAddr_RDR :: RdrName
leAddr_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leAddr#")
gtAddr_RDR :: RdrName
gtAddr_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtAddr#")
geAddr_RDR :: RdrName
geAddr_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geAddr#")

eqFloat_RDR :: RdrName
eqFloat_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqFloat#")
ltFloat_RDR :: RdrName
ltFloat_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltFloat#")
leFloat_RDR :: RdrName
leFloat_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leFloat#")
gtFloat_RDR :: RdrName
gtFloat_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtFloat#")
geFloat_RDR :: RdrName
geFloat_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geFloat#")

eqDouble_RDR :: RdrName
eqDouble_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"==##")
ltDouble_RDR :: RdrName
ltDouble_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"<##" )
leDouble_RDR :: RdrName
leDouble_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"<=##")
gtDouble_RDR :: RdrName
gtDouble_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
">##" )
geDouble_RDR :: RdrName
geDouble_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
">=##")

extendWord8_RDR :: RdrName
extendWord8_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"extendWord8#")
extendInt8_RDR :: RdrName
extendInt8_RDR  = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"extendInt8#")

extendWord16_RDR :: RdrName
extendWord16_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"extendWord16#")
extendInt16_RDR :: RdrName
extendInt16_RDR  = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"extendInt16#")


{-
************************************************************************
*                                                                      *
                        Lift instances
*                                                                      *
************************************************************************

Example:

    data Foo a = Foo a | a :^: a deriving Lift

    ==>

    instance (Lift a) => Lift (Foo a) where
        lift (Foo a) = [| Foo a |]
        lift ((:^:) u v) = [| (:^:) u v |]

        liftTyped (Foo a) = [|| Foo a ||]
        liftTyped ((:^:) u v) = [|| (:^:) u v ||]
-}


gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds (GhcPass 'Parsed), BagDerivStuff)
gen_Lift_binds SrcSpan
loc TyCon
tycon = ([LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)
lift_bind, LHsBind (GhcPass 'Parsed)
liftTyped_bind], BagDerivStuff
forall a. Bag a
emptyBag)
  where
    lift_bind :: LHsBind (GhcPass 'Parsed)
lift_bind      = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
1 SrcSpan
loc RdrName
lift_RDR (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp LHsExpr (GhcPass 'Parsed)
pure_Expr)
                                 ((DataCon
 -> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map ((LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed))
-> DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
forall {id :: Pass} {p}.
(IsPass id, XBracket p ~ NoExtField, IdGhcP id ~ RdrName) =>
(LHsExpr (GhcPass id) -> HsBracket p)
-> DataCon
-> ([Located (Pat (GhcPass 'Parsed))], Located (HsExpr p))
External instance of the constraint type IsPass 'Parsed
pats_etc LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed)
mk_exp) [DataCon]
data_cons)
    liftTyped_bind :: LHsBind (GhcPass 'Parsed)
liftTyped_bind = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
1 SrcSpan
loc RdrName
liftTyped_RDR (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp LHsExpr (GhcPass 'Parsed)
pure_Expr)
                                 ((DataCon
 -> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map ((LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed))
-> DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
forall {id :: Pass} {p}.
(IsPass id, XBracket p ~ NoExtField, IdGhcP id ~ RdrName) =>
(LHsExpr (GhcPass id) -> HsBracket p)
-> DataCon
-> ([Located (Pat (GhcPass 'Parsed))], Located (HsExpr p))
External instance of the constraint type IsPass 'Parsed
pats_etc LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed)
mk_texp) [DataCon]
data_cons)

    mk_exp :: LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed)
mk_exp = XExpBr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed)
forall p. XExpBr p -> LHsExpr p -> HsBracket p
ExpBr XExpBr (GhcPass 'Parsed)
NoExtField
noExtField
    mk_texp :: LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed)
mk_texp = XTExpBr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsBracket (GhcPass 'Parsed)
forall p. XTExpBr p -> LHsExpr p -> HsBracket p
TExpBr XTExpBr (GhcPass 'Parsed)
NoExtField
noExtField
    data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon

    pats_etc :: (LHsExpr (GhcPass id) -> HsBracket p)
-> DataCon
-> ([Located (Pat (GhcPass 'Parsed))], Located (HsExpr p))
pats_etc LHsExpr (GhcPass id) -> HsBracket p
mk_bracket DataCon
data_con
      = ([Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
con_pat], Located (HsExpr p)
lift_Expr)
       where
            con_pat :: LPat (GhcPass 'Parsed)
con_pat      = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
            data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
data_con
            con_arity :: Int
con_arity    = DataCon -> Int
dataConSourceArity DataCon
data_con
            as_needed :: [RdrName]
as_needed    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
            lift_Expr :: Located (HsExpr p)
lift_Expr    = HsExpr p -> Located (HsExpr p)
forall e. e -> Located e
noLoc (XBracket p -> HsBracket p -> HsExpr p
forall p. XBracket p -> HsBracket p -> HsExpr p
HsBracket XBracket p
NoExtField
noExtField (LHsExpr (GhcPass id) -> HsBracket p
mk_bracket LHsExpr (GhcPass id)
br_body))
            br_body :: LHsExpr (GhcPass id)
br_body      = IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
Evidence bound by a type signature of the constraint type IsPass id
nlHsApps (Name -> RdrName
Exact (DataCon -> Name
dataConName DataCon
data_con))
                                    ((RdrName -> LHsExpr (GhcPass id))
-> [RdrName] -> [LHsExpr (GhcPass id)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [RdrName]
as_needed)

{-
************************************************************************
*                                                                      *
                     Newtype-deriving instances
*                                                                      *
************************************************************************

Note [Newtype-deriving instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We take every method in the original instance and `coerce` it to fit
into the derived instance. We need type applications on the argument
to `coerce` to make it obvious what instantiation of the method we're
coercing from.  So from, say,

  class C a b where
    op :: forall c. a -> [b] -> c -> Int

  newtype T x = MkT <rep-ty>

  instance C a <rep-ty> => C a (T x) where
    op :: forall c. a -> [T x] -> c -> Int
    op = coerce @(a -> [<rep-ty>] -> c -> Int)
                @(a -> [T x]      -> c -> Int)
                op

In addition to the type applications, we also have an explicit
type signature on the entire RHS. This brings the method-bound variable
`c` into scope over the two type applications.
See Note [GND and QuantifiedConstraints] for more information on why this
is important.

Giving 'coerce' two explicitly-visible type arguments grants us finer control
over how it should be instantiated. Recall

  coerce :: Coercible a b => a -> b

By giving it explicit type arguments we deal with the case where
'op' has a higher rank type, and so we must instantiate 'coerce' with
a polytype.  E.g.

   class C a where op :: a -> forall b. b -> b
   newtype T x = MkT <rep-ty>
   instance C <rep-ty> => C (T x) where
     op :: T x -> forall b. b -> b
     op = coerce @(<rep-ty> -> forall b. b -> b)
                 @(T x      -> forall b. b -> b)
                op

The use of type applications is crucial here. If we had tried using only
explicit type signatures, like so:

   instance C <rep-ty> => C (T x) where
     op :: T x -> forall b. b -> b
     op = coerce (op :: <rep-ty> -> forall b. b -> b)

Then GHC will attempt to deeply skolemize the two type signatures, which will
wreak havoc with the Coercible solver. Therefore, we instead use type
applications, which do not deeply skolemize and thus avoid this issue.
The downside is that we currently require -XImpredicativeTypes to permit this
polymorphic type instantiation, so we have to switch that flag on locally in
GHC.Tc.Deriv.genInst. See #8503 for more discussion.

Note [Newtype-deriving trickiness]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider (#12768):
  class C a where { op :: D a => a -> a }

  instance C a  => C [a] where { op = opList }

  opList :: (C a, D [a]) => [a] -> [a]
  opList = ...

Now suppose we try GND on this:
  newtype N a = MkN [a] deriving( C )

The GND is expecting to get an implementation of op for N by
coercing opList, thus:

  instance C a => C (N a) where { op = opN }

  opN :: (C a, D (N a)) => N a -> N a
  opN = coerce @([a]   -> [a])
               @([N a] -> [N a]
               opList :: D (N a) => [N a] -> [N a]

But there is no reason to suppose that (D [a]) and (D (N a))
are inter-coercible; these instances might completely different.
So GHC rightly rejects this code.

Note [GND and QuantifiedConstraints]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider the following example from #15290:

  class C m where
    join :: m (m a) -> m a

  newtype T m a = MkT (m a)

  deriving instance
    (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
    C (T m)

The code that GHC used to generate for this was:

  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
      C (T m) where
    join = coerce @(forall a.   m   (m a) ->   m a)
                  @(forall a. T m (T m a) -> T m a)
                  join

This instantiates `coerce` at a polymorphic type, a form of impredicative
polymorphism, so we're already on thin ice. And in fact the ice breaks,
as we'll explain:

The call to `coerce` gives rise to:

  Coercible (forall a.   m   (m a) ->   m a)
            (forall a. T m (T m a) -> T m a)

And that simplified to the following implication constraint:

  forall a <no-ev>. m (T m a) ~R# m (m a)

But because this constraint is under a `forall`, inside a type, we have to
prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
*must* generate a term-level evidence binding in order to instantiate the
quantified constraint! In response, GHC currently chooses not to use such
a quantified constraint.
See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Interact.

But this isn't the death knell for combining QuantifiedConstraints with GND.
On the contrary, if we generate GND bindings in a slightly different way, then
we can avoid this situation altogether. Instead of applying `coerce` to two
polymorphic types, we instead let an instance signature do the polymorphic
instantiation, and omit the `forall`s in the type applications.
More concretely, we generate the following code instead:

  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
      C (T m) where
    join :: forall a. T m (T m a) -> T m a
    join = coerce @(  m   (m a) ->   m a)
                  @(T m (T m a) -> T m a)
                  join

Now the visible type arguments are both monotypes, so we don't need any of this
funny quantified constraint instantiation business. While this particular
example no longer uses impredicative instantiation, we still need to enable
ImpredicativeTypes to typecheck GND-generated code for class methods with
higher-rank types. See Note [Newtype-deriving instances].

You might think that that second @(T m (T m a) -> T m a) argument is redundant
in the presence of the instance signature, but in fact leaving it off will
break this example (from the T15290d test case):

  class C a where
    c :: Int -> forall b. b -> a

  instance C Int

  instance C Age where
    c :: Int -> forall b. b -> Age
    c = coerce @(Int -> forall b. b -> Int)
               c

That is because the instance signature deeply skolemizes the forall-bound
`b`, which wreaks havoc with the `Coercible` solver. An additional visible type
argument of @(Int -> forall b. b -> Age) is enough to prevent this.

Be aware that the use of an instance signature doesn't /solve/ this
problem; it just makes it less likely to occur. For example, if a class has
a truly higher-rank type like so:

  class CProblem m where
    op :: (forall b. ... (m b) ...) -> Int

Then the same situation will arise again. But at least it won't arise for the
common case of methods with ordinary, prenex-quantified types.

Note [GND and ambiguity]
~~~~~~~~~~~~~~~~~~~~~~~~
We make an effort to make the code generated through GND be robust w.r.t.
ambiguous type variables. As one example, consider the following example
(from #15637):

  class C a where f :: String
  instance C () where f = "foo"
  newtype T = T () deriving C

A naïve attempt and generating a C T instance would be:

  instance C T where
    f :: String
    f = coerce @String @String f

This isn't going to typecheck, however, since GHC doesn't know what to
instantiate the type variable `a` with in the call to `f` in the method body.
(Note that `f :: forall a. String`!) To compensate for the possibility of
ambiguity here, we explicitly instantiate `a` like so:

  instance C T where
    f :: String
    f = coerce @String @String (f @())

All better now.
-}

gen_Newtype_binds :: SrcSpan
                  -> Class   -- the class being derived
                  -> [TyVar] -- the tvs in the instance head (this includes
                             -- the tvs from both the class types and the
                             -- newtype itself)
                  -> [Type]  -- instance head parameters (incl. newtype)
                  -> Type    -- the representation type
                  -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
-- See Note [Newtype-deriving instances]
gen_Newtype_binds :: SrcSpan
-> Class
-> [Id]
-> [Type]
-> Type
-> TcM
     (LHsBinds (GhcPass 'Parsed), [LSig (GhcPass 'Parsed)],
      BagDerivStuff)
gen_Newtype_binds SrcSpan
loc Class
cls [Id]
inst_tvs [Type]
inst_tys Type
rhs_ty
  = do let ats :: [TyCon]
ats = Class -> [TyCon]
classATs Class
cls
           ([LHsBind (GhcPass 'Parsed)]
binds, [LSig (GhcPass 'Parsed)]
sigs) = (Id -> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)))
-> [Id] -> ([LHsBind (GhcPass 'Parsed)], [LSig (GhcPass 'Parsed)])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip Id -> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
mk_bind_and_sig (Class -> [Id]
classMethods Class
cls)
       [FamInst]
atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
                    (TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst)
-> [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
External instance of the constraint type forall m. Monad (IOEnv m)
External instance of the constraint type Traversable []
mapM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst
mk_atf_inst [TyCon]
ats
       (LHsBinds (GhcPass 'Parsed), [LSig (GhcPass 'Parsed)],
 BagDerivStuff)
-> TcM
     (LHsBinds (GhcPass 'Parsed), [LSig (GhcPass 'Parsed)],
      BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
External instance of the constraint type forall m. Monad (IOEnv m)
return ( [LHsBind (GhcPass 'Parsed)] -> LHsBinds (GhcPass 'Parsed)
forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)]
binds
              , [LSig (GhcPass 'Parsed)]
sigs
              , [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ([DerivStuff] -> BagDerivStuff) -> [DerivStuff] -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ (FamInst -> DerivStuff) -> [FamInst] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> DerivStuff
DerivFamInst [FamInst]
atf_insts )
  where
    -- For each class method, generate its derived binding and instance
    -- signature. Using the first example from
    -- Note [Newtype-deriving instances]:
    --
    --   class C a b where
    --     op :: forall c. a -> [b] -> c -> Int
    --
    --   newtype T x = MkT <rep-ty>
    --
    -- Then we would generate <derived-op-impl> below:
    --
    --   instance C a <rep-ty> => C a (T x) where
    --     <derived-op-impl>
    mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)
    mk_bind_and_sig :: Id -> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
mk_bind_and_sig Id
meth_id
      = ( -- The derived binding, e.g.,
          --
          --   op = coerce @(a -> [<rep-ty>] -> c -> Int)
          --               @(a -> [T x]      -> c -> Int)
          --               op
          Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind Located RdrName
loc_meth_RDR [HsMatchContext (NoGhcTc (GhcPass 'Parsed))
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch
                                        (Located (IdP (GhcPass 'Parsed)) -> HsMatchContext (GhcPass 'Parsed)
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
Located (IdP (GhcPass 'Parsed))
loc_meth_RDR)
                                        [] LHsExpr (GhcPass 'Parsed)
rhs_expr]
        , -- The derived instance signature, e.g.,
          --
          --   op :: forall c. a -> [T x] -> c -> Int
          SrcSpan -> Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed))
-> Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ XClassOpSig (GhcPass 'Parsed)
-> Bool
-> [Located (IdP (GhcPass 'Parsed))]
-> LHsSigType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XClassOpSig pass
-> Bool -> [Located (IdP pass)] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig (GhcPass 'Parsed)
NoExtField
noExtField Bool
False [Located RdrName
Located (IdP (GhcPass 'Parsed))
loc_meth_RDR]
                (LHsSigType (GhcPass 'Parsed) -> Sig (GhcPass 'Parsed))
-> LHsSigType (GhcPass 'Parsed) -> Sig (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsType (GhcPass 'Parsed) -> LHsSigType (GhcPass 'Parsed)
mkLHsSigType (LHsType (GhcPass 'Parsed) -> LHsSigType (GhcPass 'Parsed))
-> LHsType (GhcPass 'Parsed) -> LHsSigType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ Type -> LHsType (GhcPass 'Parsed)
typeToLHsType Type
to_ty
        )
      where
        Pair Type
from_ty Type
to_ty = Class -> [Id] -> [Type] -> Type -> Id -> Pair Type
mkCoerceClassMethEqn Class
cls [Id]
inst_tvs [Type]
inst_tys Type
rhs_ty Id
meth_id
        ([Id]
_, [Type]
_, Type
from_tau) = Type -> ([Id], [Type], Type)
tcSplitSigmaTy Type
from_ty
        ([Id]
_, [Type]
_, Type
to_tau)   = Type -> ([Id], [Type], Type)
tcSplitSigmaTy Type
to_ty

        meth_RDR :: RdrName
meth_RDR = Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing Id
getRdrName Id
meth_id
        loc_meth_RDR :: Located RdrName
loc_meth_RDR = SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
meth_RDR

        rhs_expr :: LHsExpr (GhcPass 'Parsed)
rhs_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing Id
getRdrName Id
coerceId)
                                      LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
`nlHsAppType`     Type
from_tau
                                      LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
`nlHsAppType`     Type
to_tau
                                      LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApp`         LHsExpr (GhcPass 'Parsed)
meth_app

        -- The class method, applied to all of the class instance types
        -- (including the representation type) to avoid potential ambiguity.
        -- See Note [GND and ambiguity]
        meth_app :: LHsExpr (GhcPass 'Parsed)
meth_app = (LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> [Type] -> LHsExpr (GhcPass 'Parsed)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldl' LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
nlHsAppType (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
meth_RDR) ([Type] -> LHsExpr (GhcPass 'Parsed))
-> [Type] -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
                   TyCon -> [Type] -> [Type]
filterOutInferredTypes (Class -> TyCon
classTyCon Class
cls) [Type]
underlying_inst_tys
                     -- Filter out any inferred arguments, since they can't be
                     -- applied with visible type application.

    mk_atf_inst :: TyCon -> TcM FamInst
    mk_atf_inst :: TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst
mk_atf_inst TyCon
fam_tc = do
        Name
rep_tc_name <- Located Name -> [Type] -> TcM Name
newFamInstTyConName (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (TyCon -> Name
tyConName TyCon
fam_tc))
                                           [Type]
rep_lhs_tys
        let axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [Id]
-> [Id]
-> [Id]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_tc_name [Id]
rep_tvs' [] [Id]
rep_cvs'
                                    TyCon
fam_tc [Type]
rep_lhs_tys Type
rep_rhs_ty
        -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv
        TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch TyCon
fam_tc (CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
axiom)
        FamFlavor
-> CoAxiom Unbranched -> IOEnv (Env TcGblEnv TcLclEnv) FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
axiom
      where
        cls_tvs :: [Id]
cls_tvs     = Class -> [Id]
classTyVars Class
cls
        in_scope :: InScopeSet
in_scope    = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [Id] -> VarSet
mkVarSet [Id]
inst_tvs
        lhs_env :: TvSubstEnv
lhs_env     = [Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
External instance of the constraint type HasDebugCallStack
zipTyEnv [Id]
cls_tvs [Type]
inst_tys
        lhs_subst :: TCvSubst
lhs_subst   = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
lhs_env
        rhs_env :: TvSubstEnv
rhs_env     = [Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
External instance of the constraint type HasDebugCallStack
zipTyEnv [Id]
cls_tvs [Type]
underlying_inst_tys
        rhs_subst :: TCvSubst
rhs_subst   = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
rhs_env
        fam_tvs :: [Id]
fam_tvs     = TyCon -> [Id]
tyConTyVars TyCon
fam_tc
        rep_lhs_tys :: [Type]
rep_lhs_tys = TCvSubst -> [Id] -> [Type]
substTyVars TCvSubst
lhs_subst [Id]
fam_tvs
        rep_rhs_tys :: [Type]
rep_rhs_tys = TCvSubst -> [Id] -> [Type]
substTyVars TCvSubst
rhs_subst [Id]
fam_tvs
        rep_rhs_ty :: Type
rep_rhs_ty  = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
rep_rhs_tys
        rep_tcvs :: [Id]
rep_tcvs    = [Type] -> [Id]
tyCoVarsOfTypesList [Type]
rep_lhs_tys
        ([Id]
rep_tvs, [Id]
rep_cvs) = (Id -> Bool) -> [Id] -> ([Id], [Id])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Id -> Bool
isTyVar [Id]
rep_tcvs
        rep_tvs' :: [Id]
rep_tvs'    = [Id] -> [Id]
scopedSort [Id]
rep_tvs
        rep_cvs' :: [Id]
rep_cvs'    = [Id] -> [Id]
scopedSort [Id]
rep_cvs

    -- Same as inst_tys, but with the last argument type replaced by the
    -- representation type.
    underlying_inst_tys :: [Type]
    underlying_inst_tys :: [Type]
underlying_inst_tys = [Type] -> Type -> [Type]
forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty

nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType :: LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
nlHsAppType LHsExpr (GhcPass 'Parsed)
e Type
s = HsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (XAppTypeE (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsWcType (NoGhcTc (GhcPass 'Parsed))
-> HsExpr (GhcPass 'Parsed)
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE (GhcPass 'Parsed)
NoExtField
noExtField LHsExpr (GhcPass 'Parsed)
e LHsWcType (NoGhcTc (GhcPass 'Parsed))
HsWildCardBndrs (GhcPass 'Parsed) (LHsType (GhcPass 'Parsed))
hs_ty)
  where
    hs_ty :: HsWildCardBndrs (GhcPass 'Parsed) (LHsType (GhcPass 'Parsed))
hs_ty = LHsType (GhcPass 'Parsed)
-> HsWildCardBndrs (GhcPass 'Parsed) (LHsType (GhcPass 'Parsed))
forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs (LHsType (GhcPass 'Parsed)
 -> HsWildCardBndrs (GhcPass 'Parsed) (LHsType (GhcPass 'Parsed)))
-> LHsType (GhcPass 'Parsed)
-> HsWildCardBndrs (GhcPass 'Parsed) (LHsType (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ PprPrec -> LHsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec (Type -> LHsType (GhcPass 'Parsed)
typeToLHsType Type
s)

nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlExprWithTySig :: LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
nlExprWithTySig LHsExpr (GhcPass 'Parsed)
e Type
s = HsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall e. e -> Located e
noLoc (HsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> HsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ XExprWithTySig (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsSigWcType (NoGhcTc (GhcPass 'Parsed))
-> HsExpr (GhcPass 'Parsed)
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig (GhcPass 'Parsed)
NoExtField
noExtField (PprPrec -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
External instance of the constraint type IsPass 'Parsed
parenthesizeHsExpr PprPrec
sigPrec LHsExpr (GhcPass 'Parsed)
e) LHsSigWcType (NoGhcTc (GhcPass 'Parsed))
LHsSigWcType (GhcPass 'Parsed)
hs_ty
  where
    hs_ty :: LHsSigWcType (GhcPass 'Parsed)
hs_ty = LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
mkLHsSigWcType (Type -> LHsType (GhcPass 'Parsed)
typeToLHsType Type
s)

mkCoerceClassMethEqn :: Class   -- the class being derived
                     -> [TyVar] -- the tvs in the instance head (this includes
                                -- the tvs from both the class types and the
                                -- newtype itself)
                     -> [Type]  -- instance head parameters (incl. newtype)
                     -> Type    -- the representation type
                     -> Id      -- the method to look at
                     -> Pair Type
-- See Note [Newtype-deriving instances]
-- See also Note [Newtype-deriving trickiness]
-- The pair is the (from_type, to_type), where to_type is
-- the type of the method we are trying to get
mkCoerceClassMethEqn :: Class -> [Id] -> [Type] -> Type -> Id -> Pair Type
mkCoerceClassMethEqn Class
cls [Id]
inst_tvs [Type]
inst_tys Type
rhs_ty Id
id
  = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
rhs_subst Type
user_meth_ty)
         (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
lhs_subst Type
user_meth_ty)
  where
    cls_tvs :: [Id]
cls_tvs = Class -> [Id]
classTyVars Class
cls
    in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [Id] -> VarSet
mkVarSet [Id]
inst_tvs
    lhs_subst :: TCvSubst
lhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope ([Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
External instance of the constraint type HasDebugCallStack
zipTyEnv [Id]
cls_tvs [Type]
inst_tys)
    rhs_subst :: TCvSubst
rhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope ([Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
External instance of the constraint type HasDebugCallStack
zipTyEnv [Id]
cls_tvs ([Type] -> Type -> [Type]
forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty))
    ([Id]
_class_tvs, Type
_class_constraint, Type
user_meth_ty)
      = Type -> ([Id], Type, Type)
tcSplitMethodTy (Id -> Type
varType Id
id)

{-
************************************************************************
*                                                                      *
\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
*                                                                      *
************************************************************************

\begin{verbatim}
data Foo ... = ...

con2tag_Foo :: Foo ... -> Int#
tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#
maxtag_Foo  :: Int              -- ditto (NB: not unlifted)
\end{verbatim}

The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
-}

genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
                  -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpec :: DynFlags
-> SrcSpan
-> AuxBindSpec
-> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBindSpec DynFlags
dflags SrcSpan
loc (DerivCon2Tag TyCon
tycon)
  = (Int
-> SrcSpan
-> RdrName
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindSE Int
0 SrcSpan
loc RdrName
rdr_name [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
[([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
eqns,
     SrcSpan -> Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTypeSig (GhcPass 'Parsed)
-> [Located (IdP (GhcPass 'Parsed))]
-> LHsSigWcType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig (GhcPass 'Parsed)
NoExtField
noExtField [SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
rdr_name] LHsSigWcType (GhcPass 'Parsed)
sig_ty))
  where
    rdr_name :: RdrName
rdr_name = DynFlags -> TyCon -> RdrName
con2tag_RDR DynFlags
dflags TyCon
tycon

    sig_ty :: LHsSigWcType (GhcPass 'Parsed)
sig_ty = LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
mkLHsSigWcType (LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed))
-> LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed))
-> HsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed)
forall pass. XXType pass -> HsType pass
XHsType (XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed))
-> XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ Type -> NewHsTypeX
NHsCoreTy (Type -> NewHsTypeX) -> Type -> NewHsTypeX
forall a b. (a -> b) -> a -> b
$
             [Id] -> [Type] -> Type -> Type
mkSpecSigmaTy (TyCon -> [Id]
tyConTyVars TyCon
tycon) (TyCon -> [Type]
tyConStupidTheta TyCon
tycon) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
             TyCon -> Type
mkParentType TyCon
tycon Type -> Type -> Type
`mkVisFunTy` Type
intPrimTy

    lots_of_constructors :: Bool
lots_of_constructors = TyCon -> Int
tyConFamilySize TyCon
tycon Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
> Int
8
                        -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
                        -- but we don't do vectored returns any more.

    eqns :: [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
eqns | Bool
lots_of_constructors = [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
get_tag_eqn]
         | Bool
otherwise = (DataCon
 -> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
DataCon -> ([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))
mk_eqn (TyCon -> [DataCon]
tyConDataCons TyCon
tycon)

    get_tag_eqn :: ([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))
get_tag_eqn = ([IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
a_RDR], LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
getTag_RDR) LHsExpr (GhcPass 'Parsed)
a_Expr)

    mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
    mk_eqn :: DataCon -> ([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))
mk_eqn DataCon
con = ([DataCon -> LPat (GhcPass 'Parsed)
nlWildConPat DataCon
con],
                  HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsIntPrim (GhcPass 'Parsed) -> Integer -> HsLit (GhcPass 'Parsed)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim (GhcPass 'Parsed)
NoSourceText
                                    (Int -> Integer
forall a. Integral a => a -> Integer
External instance of the constraint type Integral Int
toInteger ((DataCon -> Int
dataConTag DataCon
con) Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
fIRST_TAG))))

genAuxBindSpec DynFlags
dflags SrcSpan
loc (DerivTag2Con TyCon
tycon)
  = (Int
-> SrcSpan
-> RdrName
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindSE Int
0 SrcSpan
loc RdrName
rdr_name
        [([RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
intDataCon_RDR [RdrName
a_RDR]],
           LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
tagToEnum_RDR) LHsExpr (GhcPass 'Parsed)
a_Expr)],
     SrcSpan -> Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTypeSig (GhcPass 'Parsed)
-> [Located (IdP (GhcPass 'Parsed))]
-> LHsSigWcType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig (GhcPass 'Parsed)
NoExtField
noExtField [SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
rdr_name] LHsSigWcType (GhcPass 'Parsed)
sig_ty))
  where
    sig_ty :: LHsSigWcType (GhcPass 'Parsed)
sig_ty = LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
mkLHsSigWcType (LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed))
-> LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed))
-> HsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
             XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed)
forall pass. XXType pass -> HsType pass
XHsType (XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed))
-> XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ Type -> NewHsTypeX
NHsCoreTy (Type -> NewHsTypeX) -> Type -> NewHsTypeX
forall a b. (a -> b) -> a -> b
$ [Id] -> Type -> Type
mkSpecForAllTys (TyCon -> [Id]
tyConTyVars TyCon
tycon) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
             Type
intTy Type -> Type -> Type
`mkVisFunTy` TyCon -> Type
mkParentType TyCon
tycon

    rdr_name :: RdrName
rdr_name = DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon

genAuxBindSpec DynFlags
dflags SrcSpan
loc (DerivMaxTag TyCon
tycon)
  = (SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
rdr_name LHsExpr (GhcPass 'Parsed)
rhs,
     SrcSpan -> Sig (GhcPass 'Parsed) -> LSig (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTypeSig (GhcPass 'Parsed)
-> [Located (IdP (GhcPass 'Parsed))]
-> LHsSigWcType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XTypeSig pass
-> [Located (IdP pass)] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig (GhcPass 'Parsed)
NoExtField
noExtField [SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
rdr_name] LHsSigWcType (GhcPass 'Parsed)
sig_ty))
  where
    rdr_name :: RdrName
rdr_name = DynFlags -> TyCon -> RdrName
maxtag_RDR DynFlags
dflags TyCon
tycon
    sig_ty :: LHsSigWcType (GhcPass 'Parsed)
sig_ty = LHsType (GhcPass 'Parsed) -> LHsSigWcType (GhcPass 'Parsed)
mkLHsSigWcType (SrcSpan -> HsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed)
forall pass. XXType pass -> HsType pass
XHsType (Type -> NewHsTypeX
NHsCoreTy Type
intTy)))
    rhs :: LHsExpr (GhcPass 'Parsed)
rhs = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
intDataCon_RDR)
                  (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsIntPrim (GhcPass 'Parsed) -> Integer -> HsLit (GhcPass 'Parsed)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim (GhcPass 'Parsed)
NoSourceText Integer
max_tag))
    max_tag :: Integer
max_tag =  case (TyCon -> [DataCon]
tyConDataCons TyCon
tycon) of
                 [DataCon]
data_cons -> Int -> Integer
forall a. Integral a => a -> Integer
External instance of the constraint type Integral Int
toInteger (([DataCon] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
External instance of the constraint type Foldable []
length [DataCon]
data_cons) Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
fIRST_TAG)

type SeparateBagsDerivStuff =
  -- AuxBinds and SYB bindings
  ( Bag (LHsBind GhcPs, LSig GhcPs)
  -- Extra family instances (used by Generic and DeriveAnyClass)
  , Bag (FamInst) )

genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds DynFlags
dflags SrcSpan
loc BagDerivStuff
b = BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds' BagDerivStuff
b2 where
  (Bag AuxBindSpec
b1,BagDerivStuff
b2) = (DerivStuff -> Either AuxBindSpec DerivStuff)
-> BagDerivStuff -> (Bag AuxBindSpec, BagDerivStuff)
forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
partitionBagWith DerivStuff -> Either AuxBindSpec DerivStuff
splitDerivAuxBind BagDerivStuff
b
  splitDerivAuxBind :: DerivStuff -> Either AuxBindSpec DerivStuff
splitDerivAuxBind (DerivAuxBind AuxBindSpec
x) = AuxBindSpec -> Either AuxBindSpec DerivStuff
forall a b. a -> Either a b
Left AuxBindSpec
x
  splitDerivAuxBind  DerivStuff
x               = DerivStuff -> Either AuxBindSpec DerivStuff
forall a b. b -> Either a b
Right DerivStuff
x

  rm_dups :: Bag AuxBindSpec -> Bag AuxBindSpec
rm_dups = (AuxBindSpec -> Bag AuxBindSpec -> Bag AuxBindSpec)
-> Bag AuxBindSpec -> Bag AuxBindSpec -> Bag AuxBindSpec
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable Bag
foldr AuxBindSpec -> Bag AuxBindSpec -> Bag AuxBindSpec
forall {a}. Eq a => a -> Bag a -> Bag a
Instance of class: Eq of the constraint type Eq AuxBindSpec
dup_check Bag AuxBindSpec
forall a. Bag a
emptyBag
  dup_check :: a -> Bag a -> Bag a
dup_check a
a Bag a
b = if (a -> Bool) -> Bag a -> Bool
forall a. (a -> Bool) -> Bag a -> Bool
anyBag (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
Evidence bound by a type signature of the constraint type Eq a
== a
a) Bag a
b then Bag a
b else a -> Bag a -> Bag a
forall a. a -> Bag a -> Bag a
consBag a
a Bag a
b

  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds' = (DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff)
-> SeparateBagsDerivStuff
-> BagDerivStuff
-> SeparateBagsDerivStuff
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable Bag
foldr DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
f ( (AuxBindSpec
 -> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)))
-> Bag AuxBindSpec
-> Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
forall a b. (a -> b) -> Bag a -> Bag b
mapBag (DynFlags
-> SrcSpan
-> AuxBindSpec
-> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBindSpec DynFlags
dflags SrcSpan
loc) (Bag AuxBindSpec -> Bag AuxBindSpec
rm_dups Bag AuxBindSpec
b1)
                            , Bag FamInst
forall a. Bag a
emptyBag )
  f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
  f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
f (DerivAuxBind AuxBindSpec
_) = String -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
forall a. String -> a
panic String
"genAuxBinds'" -- We have removed these before
  f (DerivHsBind  (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
b) = (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
-> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
forall {a} {b}. a -> (Bag a, b) -> (Bag a, b)
add1 (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
b
  f (DerivFamInst FamInst
t) = FamInst -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
forall {a} {a}. a -> (a, Bag a) -> (a, Bag a)
add2 FamInst
t

  add1 :: a -> (Bag a, b) -> (Bag a, b)
add1 a
x (Bag a
a,b
b) = (a
x a -> Bag a -> Bag a
forall a. a -> Bag a -> Bag a
`consBag` Bag a
a,b
b)
  add2 :: a -> (a, Bag a) -> (a, Bag a)
add2 a
x (a
a,Bag a
b) = (a
a,a
x a -> Bag a -> Bag a
forall a. a -> Bag a -> Bag a
`consBag` Bag a
b)

mkParentType :: TyCon -> Type
-- Turn the representation tycon of a family into
-- a use of its family constructor
mkParentType :: TyCon -> Type
mkParentType TyCon
tc
  = case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tc of
       Maybe (TyCon, [Type])
Nothing  -> TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Id] -> [Type]
mkTyVarTys (TyCon -> [Id]
tyConTyVars TyCon
tc))
       Just (TyCon
fam_tc,[Type]
tys) -> TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
tys

{-
************************************************************************
*                                                                      *
\subsection{Utility bits for generating bindings}
*                                                                      *
************************************************************************
-}

-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that produces a stock error.
mkFunBindSE :: Arity -> SrcSpan -> RdrName
             -> [([LPat GhcPs], LHsExpr GhcPs)]
             -> LHsBind GhcPs
mkFunBindSE :: Int
-> SrcSpan
-> RdrName
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindSE Int
arity SrcSpan
loc RdrName
fun [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs
  = Int
-> Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindSE Int
arity (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
  where
    matches :: [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches = [HsMatchContext (NoGhcTc (GhcPass 'Parsed))
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
External instance of the constraint type IsPass 'Parsed
mkMatch (Located (IdP (GhcPass 'Parsed)) -> HsMatchContext (GhcPass 'Parsed)
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun))
                               ((Located (Pat (GhcPass 'Parsed))
 -> Located (Pat (GhcPass 'Parsed)))
-> [Located (Pat (GhcPass 'Parsed))]
-> [Located (Pat (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
External instance of the constraint type IsPass 'Parsed
parenthesizePat PprPrec
appPrec) [Located (Pat (GhcPass 'Parsed))]
p) LHsExpr (GhcPass 'Parsed)
e
                               (HsLocalBinds (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
forall e. e -> Located e
noLoc HsLocalBinds (GhcPass 'Parsed)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
              | ([Located (Pat (GhcPass 'Parsed))]
p,LHsExpr (GhcPass 'Parsed)
e) <-[([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
[([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs]

mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> LHsBind GhcPs
mkRdrFunBind :: Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind fun :: Located RdrName
fun@(L SrcSpan
loc RdrName
_fun_rdr) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
  = SrcSpan -> HsBind (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Origin
-> Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBind (GhcPass 'Parsed)
mkFunBind Origin
Generated Located RdrName
fun [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches)

-- | Make a function binding. If no equations are given, produce a function
-- with the given arity that uses an empty case expression for the last
-- argument that is passes to the given function to produce the right-hand
-- side.
mkFunBindEC :: Arity -> SrcSpan -> RdrName
            -> (LHsExpr GhcPs -> LHsExpr GhcPs)
            -> [([LPat GhcPs], LHsExpr GhcPs)]
            -> LHsBind GhcPs
mkFunBindEC :: Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
arity SrcSpan
loc RdrName
fun LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs
  = Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
arity LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
  where
    matches :: [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches = [ HsMatchContext (NoGhcTc (GhcPass 'Parsed))
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
External instance of the constraint type IsPass 'Parsed
mkMatch (Located (IdP (GhcPass 'Parsed)) -> HsMatchContext (GhcPass 'Parsed)
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun))
                                ((Located (Pat (GhcPass 'Parsed))
 -> Located (Pat (GhcPass 'Parsed)))
-> [Located (Pat (GhcPass 'Parsed))]
-> [Located (Pat (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
External instance of the constraint type IsPass 'Parsed
parenthesizePat PprPrec
appPrec) [Located (Pat (GhcPass 'Parsed))]
p) LHsExpr (GhcPass 'Parsed)
e
                                (HsLocalBinds (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
forall e. e -> Located e
noLoc HsLocalBinds (GhcPass 'Parsed)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
              | ([Located (Pat (GhcPass 'Parsed))]
p,LHsExpr (GhcPass 'Parsed)
e) <- [([Located (Pat (GhcPass 'Parsed))], LHsExpr (GhcPass 'Parsed))]
[([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs ]

-- | Produces a function binding. When no equations are given, it generates
-- a binding of the given arity and an empty case expression
-- for the last argument that it passes to the given function to produce
-- the right-hand side.
mkRdrFunBindEC :: Arity
               -> (LHsExpr GhcPs -> LHsExpr GhcPs)
               -> Located RdrName
               -> [LMatch GhcPs (LHsExpr GhcPs)]
               -> LHsBind GhcPs
mkRdrFunBindEC :: Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
arity LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all
                 fun :: Located RdrName
fun@(L SrcSpan
loc RdrName
_fun_rdr) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches = SrcSpan -> HsBind (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Origin
-> Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBind (GhcPass 'Parsed)
mkFunBind Origin
Generated Located RdrName
fun [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches')
 where
   -- Catch-all eqn looks like
   --     fmap _ z = case z of {}
   -- or
   --     traverse _ z = pure (case z of)
   -- or
   --     foldMap _ z = mempty
   -- It's needed if there no data cons at all,
   -- which can happen with -XEmptyDataDecls
   -- See #4302
   matches' :: [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches' = if [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
              then [HsMatchContext (NoGhcTc (GhcPass 'Parsed))
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
External instance of the constraint type IsPass 'Parsed
mkMatch (Located (IdP (GhcPass 'Parsed)) -> HsMatchContext (GhcPass 'Parsed)
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
Located (IdP (GhcPass 'Parsed))
fun)
                            (Int
-> Located (Pat (GhcPass 'Parsed))
-> [Located (Pat (GhcPass 'Parsed))]
forall a. Int -> a -> [a]
replicate (Int
arity Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
1) Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
nlWildPat [Located (Pat (GhcPass 'Parsed))]
-> [Located (Pat (GhcPass 'Parsed))]
-> [Located (Pat (GhcPass 'Parsed))]
forall a. [a] -> [a] -> [a]
++ [Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
z_Pat])
                            (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase LHsExpr (GhcPass 'Parsed)
z_Expr [])
                            (HsLocalBinds (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
forall e. e -> Located e
noLoc HsLocalBinds (GhcPass 'Parsed)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)]
              else [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches

-- | Produces a function binding. When there are no equations, it generates
-- a binding with the given arity that produces an error based on the name of
-- the type of the last argument.
mkRdrFunBindSE :: Arity -> Located RdrName ->
                    [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE :: Int
-> Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindSE Int
arity
                 fun :: Located RdrName
fun@(L SrcSpan
loc RdrName
fun_rdr) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches = SrcSpan -> HsBind (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Origin
-> Located RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBind (GhcPass 'Parsed)
mkFunBind Origin
Generated Located RdrName
fun [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches')
 where
   -- Catch-all eqn looks like
   --     compare _ _ = error "Void compare"
   -- It's needed if there no data cons at all,
   -- which can happen with -XEmptyDataDecls
   -- See #4302
   matches' :: [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches' = if [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
External instance of the constraint type Foldable []
null [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
              then [HsMatchContext (NoGhcTc (GhcPass 'Parsed))
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
External instance of the constraint type IsPass 'Parsed
mkMatch (Located (IdP (GhcPass 'Parsed)) -> HsMatchContext (GhcPass 'Parsed)
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
Located (IdP (GhcPass 'Parsed))
fun)
                            (Int
-> Located (Pat (GhcPass 'Parsed))
-> [Located (Pat (GhcPass 'Parsed))]
forall a. Int -> a -> [a]
replicate Int
arity Located (Pat (GhcPass 'Parsed))
LPat (GhcPass 'Parsed)
nlWildPat)
                            (String -> LHsExpr (GhcPass 'Parsed)
error_Expr String
str) (HsLocalBinds (GhcPass 'Parsed)
-> Located (HsLocalBinds (GhcPass 'Parsed))
forall e. e -> Located e
noLoc HsLocalBinds (GhcPass 'Parsed)
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)]
              else [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
   str :: String
str = String
"Void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
fun_rdr)


box ::         String           -- The class involved
            -> LHsExpr GhcPs    -- The argument
            -> Type             -- The argument type
            -> LHsExpr GhcPs    -- Boxed version of the arg
-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
box :: String
-> LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
box String
cls_str LHsExpr (GhcPass 'Parsed)
arg Type
arg_ty = String
-> [(Type, LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))]
-> Type
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
cls_str [(Type, LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))]
boxConTbl Type
arg_ty LHsExpr (GhcPass 'Parsed)
arg

---------------------
primOrdOps :: String    -- The class involved
           -> Type      -- The type
           -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)
-- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
primOrdOps :: String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
str Type
ty = String
-> [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
-> Type
-> (RdrName, RdrName, RdrName, RdrName, RdrName)
forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
str [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl Type
ty

ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
 =  [(Type
charPrimTy  , (RdrName
ltChar_RDR  , RdrName
leChar_RDR
     , RdrName
eqChar_RDR  , RdrName
geChar_RDR  , RdrName
gtChar_RDR  ))
    ,(Type
intPrimTy   , (RdrName
ltInt_RDR   , RdrName
leInt_RDR
     , RdrName
eqInt_RDR   , RdrName
geInt_RDR   , RdrName
gtInt_RDR   ))
    ,(Type
int8PrimTy  , (RdrName
ltInt8_RDR  , RdrName
leInt8_RDR
     , RdrName
eqInt8_RDR  , RdrName
geInt8_RDR  , RdrName
gtInt8_RDR   ))
    ,(Type
int16PrimTy , (RdrName
ltInt16_RDR , RdrName
leInt16_RDR
     , RdrName
eqInt16_RDR , RdrName
geInt16_RDR , RdrName
gtInt16_RDR   ))
    ,(Type
wordPrimTy  , (RdrName
ltWord_RDR  , RdrName
leWord_RDR
     , RdrName
eqWord_RDR  , RdrName
geWord_RDR  , RdrName
gtWord_RDR  ))
    ,(Type
word8PrimTy , (RdrName
ltWord8_RDR , RdrName
leWord8_RDR
     , RdrName
eqWord8_RDR , RdrName
geWord8_RDR , RdrName
gtWord8_RDR   ))
    ,(Type
word16PrimTy, (RdrName
ltWord16_RDR, RdrName
leWord16_RDR
     , RdrName
eqWord16_RDR, RdrName
geWord16_RDR, RdrName
gtWord16_RDR  ))
    ,(Type
addrPrimTy  , (RdrName
ltAddr_RDR  , RdrName
leAddr_RDR
     , RdrName
eqAddr_RDR  , RdrName
geAddr_RDR  , RdrName
gtAddr_RDR  ))
    ,(Type
floatPrimTy , (RdrName
ltFloat_RDR , RdrName
leFloat_RDR
     , RdrName
eqFloat_RDR , RdrName
geFloat_RDR , RdrName
gtFloat_RDR ))
    ,(Type
doublePrimTy, (RdrName
ltDouble_RDR, RdrName
leDouble_RDR
     , RdrName
eqDouble_RDR, RdrName
geDouble_RDR, RdrName
gtDouble_RDR)) ]

-- A mapping from a primitive type to a function that constructs its boxed
-- version.
-- NOTE: Int8#/Word8# will become Int/Word.
boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
boxConTbl :: [(Type, LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))]
boxConTbl =
    [ (Type
charPrimTy  , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
charDataCon))
    , (Type
intPrimTy   , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
intDataCon))
    , (Type
wordPrimTy  , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
wordDataCon ))
    , (Type
floatPrimTy , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
floatDataCon ))
    , (Type
doublePrimTy, LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
doubleDataCon))
    , (Type
int8PrimTy,
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
intDataCon)
        (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
extendInt8_RDR))
    , (Type
word8PrimTy,
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
wordDataCon)
        (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
extendWord8_RDR))
    , (Type
int16PrimTy,
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
intDataCon)
        (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
extendInt16_RDR))
    , (Type
word16PrimTy,
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing DataCon
getRdrName DataCon
wordDataCon)
        (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.  LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
extendWord16_RDR))
    ]


-- | A table of postfix modifiers for unboxed values.
postfixModTbl :: [(Type, String)]
postfixModTbl :: [(Type, String)]
postfixModTbl
  = [(Type
charPrimTy  , String
"#" )
    ,(Type
intPrimTy   , String
"#" )
    ,(Type
wordPrimTy  , String
"##")
    ,(Type
floatPrimTy , String
"#" )
    ,(Type
doublePrimTy, String
"##")
    ,(Type
int8PrimTy, String
"#")
    ,(Type
word8PrimTy, String
"##")
    ,(Type
int16PrimTy, String
"#")
    ,(Type
word16PrimTy, String
"##")
    ]

primConvTbl :: [(Type, String)]
primConvTbl :: [(Type, String)]
primConvTbl =
    [ (Type
int8PrimTy, String
"narrowInt8#")
    , (Type
word8PrimTy, String
"narrowWord8#")
    , (Type
int16PrimTy, String
"narrowInt16#")
    , (Type
word16PrimTy, String
"narrowWord16#")
    ]

litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl :: [(Type, LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))]
litConTbl
  = [(Type
charPrimTy  , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
charPrimL_RDR))
    ,(Type
intPrimTy   , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
intPrimL_RDR)
                      (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
toInteger_RDR))
    ,(Type
wordPrimTy  , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
wordPrimL_RDR)
                      (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
toInteger_RDR))
    ,(Type
addrPrimTy  , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
stringPrimL_RDR)
                      (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp
                          (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
map_RDR)
                          (RdrName
IdP (GhcPass 'Parsed)
compose_RDR IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
`nlHsApps`
                            [ IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
fromIntegral_RDR
                            , IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
fromEnum_RDR
                            ])))
    ,(Type
floatPrimTy , LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
floatPrimL_RDR)
                      (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
toRational_RDR))
    ,(Type
doublePrimTy, LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
doublePrimL_RDR)
                      (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
toRational_RDR))
    ]

-- | Lookup `Type` in an association list.
assoc_ty_id :: HasCallStack => String           -- The class involved
            -> [(Type,a)]       -- The table
            -> Type             -- The type
            -> a                -- The result of the lookup
assoc_ty_id :: String -> [(Type, a)] -> Type -> a
assoc_ty_id String
cls_str [(Type, a)]
tbl Type
ty
  | Just a
a <- [(Type, a)] -> Type -> Maybe a
forall a. [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, a)]
tbl Type
ty = a
a
  | Bool
otherwise =
      String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
Evidence bound by a type signature of the constraint type HasCallStack
pprPanic String
"Error in deriving:"
          (String -> SDoc
text String
"Can't derive" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
cls_str SDoc -> SDoc -> SDoc
<+>
           String -> SDoc
text String
"for primitive type" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
External instance of the constraint type Outputable Type
ppr Type
ty)

-- | Lookup `Type` in an association list.
assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, a)]
tbl Type
ty = (Type, a) -> a
forall a b. (a, b) -> b
snd ((Type, a) -> a) -> Maybe (Type, a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
External instance of the constraint type Functor Maybe
<$> ((Type, a) -> Bool) -> [(Type, a)] -> Maybe (Type, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
External instance of the constraint type Foldable []
find (\(Type
t, a
_) -> Type
t Type -> Type -> Bool
`eqType` Type
ty) [(Type, a)]
tbl

-----------------------------------------------------------------------

and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
and_Expr LHsExpr (GhcPass 'Parsed)
a LHsExpr (GhcPass 'Parsed)
b = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
a RdrName
and_RDR    LHsExpr (GhcPass 'Parsed)
b

-----------------------------------------------------------------------

eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr :: Type
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
eq_Expr Type
ty LHsExpr (GhcPass 'Parsed)
a LHsExpr (GhcPass 'Parsed)
b
    | Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
External instance of the constraint type HasDebugCallStack
isUnliftedType Type
ty) = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
a RdrName
eq_RDR LHsExpr (GhcPass 'Parsed)
b
    | Bool
otherwise               = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a RdrName
prim_eq LHsExpr (GhcPass 'Parsed)
b
 where
   (RdrName
_, RdrName
_, RdrName
prim_eq, RdrName
_, RdrName
_) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Eq" Type
ty

untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]
              -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr :: DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
_ TyCon
_ [] LHsExpr (GhcPass 'Parsed)
expr = LHsExpr (GhcPass 'Parsed)
expr
untag_Expr DynFlags
dflags TyCon
tycon ((RdrName
untag_this, RdrName
put_tag_here) : [(RdrName, RdrName)]
more) LHsExpr (GhcPass 'Parsed)
expr
  = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps (DynFlags -> TyCon -> RdrName
con2tag_RDR DynFlags
dflags TyCon
tycon)
                                   [RdrName
IdP (GhcPass 'Parsed)
untag_this])) {-of-}
      [LPat (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
put_tag_here) (DynFlags
-> TyCon
-> [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
untag_Expr DynFlags
dflags TyCon
tycon [(RdrName, RdrName)]
more LHsExpr (GhcPass 'Parsed)
expr)]

enum_from_to_Expr
        :: LHsExpr GhcPs -> LHsExpr GhcPs
        -> LHsExpr GhcPs
enum_from_then_to_Expr
        :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
        -> LHsExpr GhcPs

enum_from_to_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
enum_from_to_Expr      LHsExpr (GhcPass 'Parsed)
f   LHsExpr (GhcPass 'Parsed)
t2 = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
enumFromTo_RDR) LHsExpr (GhcPass 'Parsed)
f) LHsExpr (GhcPass 'Parsed)
t2
enum_from_then_to_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
enum_from_then_to_Expr LHsExpr (GhcPass 'Parsed)
f LHsExpr (GhcPass 'Parsed)
t LHsExpr (GhcPass 'Parsed)
t2 = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
enumFromThenTo_RDR) LHsExpr (GhcPass 'Parsed)
f) LHsExpr (GhcPass 'Parsed)
t) LHsExpr (GhcPass 'Parsed)
t2

showParen_Expr
        :: LHsExpr GhcPs -> LHsExpr GhcPs
        -> LHsExpr GhcPs

showParen_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
showParen_Expr LHsExpr (GhcPass 'Parsed)
e1 LHsExpr (GhcPass 'Parsed)
e2 = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
showParen_RDR) LHsExpr (GhcPass 'Parsed)
e1) LHsExpr (GhcPass 'Parsed)
e2

nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs

nested_compose_Expr :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr []  = String -> LHsExpr (GhcPass 'Parsed)
forall a. String -> a
panic String
"nested_compose_expr"   -- Arg is always non-empty
nested_compose_Expr [LHsExpr (GhcPass 'Parsed)
e] = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
parenify LHsExpr (GhcPass 'Parsed)
e
nested_compose_Expr (LHsExpr (GhcPass 'Parsed)
e:[LHsExpr (GhcPass 'Parsed)]
es)
  = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
compose_RDR) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
parenify LHsExpr (GhcPass 'Parsed)
e)) ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr [LHsExpr (GhcPass 'Parsed)]
es)

-- impossible_Expr is used in case RHSs that should never happen.
-- We generate these to keep the desugarer from complaining that they *might* happen!
error_Expr :: String -> LHsExpr GhcPs
error_Expr :: String -> LHsExpr (GhcPass 'Parsed)
error_Expr String
string = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
error_RDR) (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
string))

-- illegal_Expr is used when signalling error conditions in the RHS of a derived
-- method. It is currently only used by Enum.{succ,pred}
illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
illegal_Expr :: String -> String -> String -> LHsExpr (GhcPass 'Parsed)
illegal_Expr String
meth String
tp String
msg =
   LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
error_RDR) (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String
meth String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'{'Char -> String -> String
forall a. a -> [a] -> [a]
:String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)))

-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
-- to include the value of a_RDR in the error string.
illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
illegal_toEnum_tag :: String -> RdrName -> LHsExpr (GhcPass 'Parsed)
illegal_toEnum_tag String
tp RdrName
maxtag =
   LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
error_RDR)
           (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
append_RDR)
                       (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String
"toEnum{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}: tag ("))))
                    (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp
                           (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
showsPrec_RDR)
                           (Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
                           (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a_RDR))
                           (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp
                               (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
append_RDR)
                               (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
") is outside of enumeration's range (0,")))
                               (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp
                                        (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
showsPrec_RDR)
                                        (Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
                                        (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
maxtag))
                                        (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
")"))))))

parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
parenify :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
parenify e :: LHsExpr (GhcPass 'Parsed)
e@(L SrcSpan
_ (HsVar XVar (GhcPass 'Parsed)
_ Located (IdP (GhcPass 'Parsed))
_)) = LHsExpr (GhcPass 'Parsed)
e
parenify LHsExpr (GhcPass 'Parsed)
e                   = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar LHsExpr (GhcPass 'Parsed)
e

-- genOpApp wraps brackets round the operator application, so that the
-- renamer won't subsequently try to re-associate it.
genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp :: LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
op LHsExpr (GhcPass 'Parsed)
e2 = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
IdP (GhcPass 'Parsed)
op LHsExpr (GhcPass 'Parsed)
e2)

genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp :: LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
op LHsExpr (GhcPass 'Parsed)
e2 = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
External instance of the constraint type IsPass 'Parsed
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
tagToEnum_RDR) (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
IdP (GhcPass 'Parsed)
op LHsExpr (GhcPass 'Parsed)
e2))

a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
    :: RdrName
a_RDR :: RdrName
a_RDR           = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"a")
b_RDR :: RdrName
b_RDR           = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"b")
c_RDR :: RdrName
c_RDR           = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"c")
d_RDR :: RdrName
d_RDR           = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"d")
f_RDR :: RdrName
f_RDR           = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"f")
k_RDR :: RdrName
k_RDR           = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"k")
z_RDR :: RdrName
z_RDR           = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"z")
ah_RDR :: RdrName
ah_RDR          = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"a#")
bh_RDR :: RdrName
bh_RDR          = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"b#")
ch_RDR :: RdrName
ch_RDR          = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"c#")
dh_RDR :: RdrName
dh_RDR          = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"d#")

as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
as_RDRs :: [RdrName]
as_RDRs         = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
External instance of the constraint type Show Int
show Int
i)) | Int
i <- [(Int
1::Int) .. ] ]
bs_RDRs :: [RdrName]
bs_RDRs         = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"b"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
External instance of the constraint type Show Int
show Int
i)) | Int
i <- [(Int
1::Int) .. ] ]
cs_RDRs :: [RdrName]
cs_RDRs         = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"c"String -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String
forall a. Show a => a -> String
External instance of the constraint type Show Int
show Int
i)) | Int
i <- [(Int
1::Int) .. ] ]

a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
    true_Expr, pure_Expr :: LHsExpr GhcPs
a_Expr :: LHsExpr (GhcPass 'Parsed)
a_Expr          = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
a_RDR
b_Expr :: LHsExpr (GhcPass 'Parsed)
b_Expr          = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
b_RDR
c_Expr :: LHsExpr (GhcPass 'Parsed)
c_Expr          = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
c_RDR
z_Expr :: LHsExpr (GhcPass 'Parsed)
z_Expr          = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
z_RDR
ltTag_Expr :: LHsExpr (GhcPass 'Parsed)
ltTag_Expr      = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
ltTag_RDR
eqTag_Expr :: LHsExpr (GhcPass 'Parsed)
eqTag_Expr      = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
eqTag_RDR
gtTag_Expr :: LHsExpr (GhcPass 'Parsed)
gtTag_Expr      = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
gtTag_RDR
false_Expr :: LHsExpr (GhcPass 'Parsed)
false_Expr      = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
false_RDR
true_Expr :: LHsExpr (GhcPass 'Parsed)
true_Expr       = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
true_RDR
pure_Expr :: LHsExpr (GhcPass 'Parsed)
pure_Expr       = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass 'Parsed)
pure_RDR

a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
a_Pat :: LPat (GhcPass 'Parsed)
a_Pat           = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
a_RDR
b_Pat :: LPat (GhcPass 'Parsed)
b_Pat           = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
b_RDR
c_Pat :: LPat (GhcPass 'Parsed)
c_Pat           = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
c_RDR
d_Pat :: LPat (GhcPass 'Parsed)
d_Pat           = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
d_RDR
k_Pat :: LPat (GhcPass 'Parsed)
k_Pat           = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
k_RDR
z_Pat :: LPat (GhcPass 'Parsed)
z_Pat           = IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP (GhcPass 'Parsed)
z_RDR

minusInt_RDR, tagToEnum_RDR :: RdrName
minusInt_RDR :: RdrName
minusInt_RDR  = Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing Id
getRdrName (PrimOp -> Id
primOpId PrimOp
IntSubOp   )
tagToEnum_RDR :: RdrName
tagToEnum_RDR = Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
External instance of the constraint type NamedThing Id
getRdrName (PrimOp -> Id
primOpId PrimOp
TagToEnumOp)

con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
-- Generates Orig s RdrName, for the binding positions
con2tag_RDR :: DynFlags -> TyCon -> RdrName
con2tag_RDR DynFlags
dflags TyCon
tycon = DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
mk_tc_deriv_name DynFlags
dflags TyCon
tycon OccName -> OccName
mkCon2TagOcc
tag2con_RDR :: DynFlags -> TyCon -> RdrName
tag2con_RDR DynFlags
dflags TyCon
tycon = DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
mk_tc_deriv_name DynFlags
dflags TyCon
tycon OccName -> OccName
mkTag2ConOcc
maxtag_RDR :: DynFlags -> TyCon -> RdrName
maxtag_RDR  DynFlags
dflags TyCon
tycon = DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
mk_tc_deriv_name DynFlags
dflags TyCon
tycon OccName -> OccName
mkMaxTagOcc

mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
mk_tc_deriv_name DynFlags
dflags TyCon
tycon OccName -> OccName
occ_fun =
   DynFlags -> Name -> (OccName -> OccName) -> RdrName
mkAuxBinderName DynFlags
dflags (TyCon -> Name
tyConName TyCon
tycon) OccName -> OccName
occ_fun

mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
-- ^ Make a top-level binder name for an auxiliary binding for a parent name
-- See Note [Auxiliary binders]
mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
mkAuxBinderName DynFlags
dflags Name
parent OccName -> OccName
occ_fun
  = OccName -> RdrName
mkRdrUnqual (OccName -> OccName
occ_fun OccName
stable_parent_occ)
  where
    stable_parent_occ :: OccName
stable_parent_occ = NameSpace -> String -> OccName
mkOccName (OccName -> NameSpace
occNameSpace OccName
parent_occ) String
stable_string
    stable_string :: String
stable_string
      | DynFlags -> Bool
hasPprDebug DynFlags
dflags = String
parent_stable
      | Bool
otherwise          = String
parent_stable_hash
    parent_stable :: String
parent_stable = Name -> String
nameStableString Name
parent
    parent_stable_hash :: String
parent_stable_hash =
      let Fingerprint Word64
high Word64
low = String -> Fingerprint
fingerprintString String
parent_stable
      in Word64 -> String
toBase62 Word64
high String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word64 -> String
toBase62Padded Word64
low
      -- See Note [Base 62 encoding 128-bit integers] in GHC.Utils.Encoding
    parent_occ :: OccName
parent_occ  = Name -> OccName
nameOccName Name
parent


{-
Note [Auxiliary binders]
~~~~~~~~~~~~~~~~~~~~~~~~
We often want to make a top-level auxiliary binding.  E.g. for comparison we have

  instance Ord T where
    compare a b = $con2tag a `compare` $con2tag b

  $con2tag :: T -> Int
  $con2tag = ...code....

Of course these top-level bindings should all have distinct name, and we are
generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish
because with standalone deriving two imported TyCons might both be called T!
(See #7947.)

So we use package name, module name and the name of the parent
(T in this example) as part of the OccName we generate for the new binding.
To make the symbol names short we take a base62 hash of the full name.

In the past we used the *unique* from the parent, but that's not stable across
recompilations as uniques are nondeterministic.
-}