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

-}

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}

{-# 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 (
        AuxBindSpec(..),

        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,
        gen_Newtype_fam_insts,
        mkCoerceClassMethEqn,
        genAuxBinds,
        ordOpTbl, boxConTbl, litConTbl,
        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,

        getPossibleDataCons,
        DerivInstTys(..), buildDataConInstArgEnv,
        derivDataConInstArgTys, substDerivInstTys, zonkDerivInstTys
    ) where

import GHC.Prelude

import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.SourceText

import GHC.Driver.Session
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.Builtin.PrimOps.Ids (primOpId)
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Zonk
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.Unique.FM ( lookupUFM, listToUFM )
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.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Lexeme
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Bag

import Data.List  ( find, partition, intersperse )
import GHC.Data.Maybe ( expectJust )
import GHC.Unit.Module

-- | A declarative description of an auxiliary binding that should be
-- generated. See @Note [Auxiliary binders]@ for a more detailed description
-- of how these are used.
data AuxBindSpec
  -- DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord,
  -- Enum, and Ix instances.
  -- All these generate ZERO-BASED tag operations
  -- I.e first constructor has tag 0

    -- | @$tag2con@: Given a tag, computes the corresponding data constructor
  = DerivTag2Con
      TyCon   -- The type constructor of the data type to which the
              -- constructors belong
      RdrName -- The to-be-generated $tag2con binding's RdrName

    -- | @$maxtag@: The maximum possible tag value among a data type's
    -- constructors
  | DerivMaxTag
      TyCon   -- The type constructor of the data type to which the
              -- constructors belong
      RdrName -- The to-be-generated $maxtag binding's RdrName

  -- DerivDataDataType and DerivDataConstr are only used in derived Data
  -- instances

    -- | @$t@: The @DataType@ representation for a @Data@ instance
  | DerivDataDataType
      TyCon     -- The type constructor of the data type to be represented
      RdrName   -- The to-be-generated $t binding's RdrName
      [RdrName] -- The RdrNames of the to-be-generated $c bindings for each
                -- data constructor. These are only used on the RHS of the
                -- to-be-generated $t binding.

    -- | @$c@: The @Constr@ representation for a @Data@ instance
  | DerivDataConstr
      DataCon -- The data constructor to be represented
      RdrName -- The to-be-generated $c binding's RdrName
      RdrName -- The RdrName of the to-be-generated $t binding for the parent
              -- data type. This is only used on the RHS of the
              -- to-be-generated $c binding.

-- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec'
-- describes.
auxBindSpecRdrName :: AuxBindSpec -> RdrName
auxBindSpecRdrName :: AuxBindSpec -> RdrName
auxBindSpecRdrName (DerivTag2Con      TyCon
_ RdrName
tag2con_RDR) = RdrName
tag2con_RDR
auxBindSpecRdrName (DerivMaxTag       TyCon
_ RdrName
maxtag_RDR)  = RdrName
maxtag_RDR
auxBindSpecRdrName (DerivDataDataType TyCon
_ RdrName
dataT_RDR [RdrName]
_) = RdrName
dataT_RDR
auxBindSpecRdrName (DerivDataConstr   DataCon
_ RdrName
dataC_RDR RdrName
_) = RdrName
dataC_RDR

{-
************************************************************************
*                                                                      *
                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 | ...

* We first attempt to compare the constructor tags. If tags don't
  match - we immediately bail out. Otherwise, we then generate one
  branch per constructor comparing only the fields as we already
  know that the tags match. Note that it only makes sense to check
  the tag if there is more than one data constructor.

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

* For nullary constructors, we emit a catch-all clause that always
  returns True since we already know that the tags match.

* So, given this data type:

    data T = A | B Int | C Char

  We roughly get:

    (==) a b =
      case dataToTag# a /= dataToTag# b of
        True -> False
        False -> case a of       -- Here we already know that tags match
            B a1 -> case b of
                B b1 -> a1 == b1 -- Only one branch
            C a1 -> case b of
                C b1 -> a1 == b1 -- Only one branch
            _ -> True            -- catch-all to match all nullary ctors

  An older approach preferred regular pattern matches in some cases
  but with dataToTag# forcing it's argument, and work on improving
  join points, this seems no longer necessary.

* 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 @dataToTag#@, 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 -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Eq_binds SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                  , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args }) = do
    (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
method_binds, Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    all_cons :: [DataCon]
all_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
    non_nullary_cons :: [DataCon]
non_nullary_cons = (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (DataCon -> Bool) -> DataCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Bool
isNullarySrcDataCon) [DataCon]
all_cons

    -- Generate tag check. See #17240
    eq_expr_with_tag_check :: LHsExpr GhcPs
eq_expr_with_tag_check = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase
      (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar ([(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR,RdrName
ah_RDR), (RdrName
b_RDR,RdrName
bh_RDR)]
                    (LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
ah_RDR) IdP GhcPs
RdrName
neInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
bh_RDR))))
      [ LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (HsLit GhcPs -> LPat GhcPs
nlLitPat (XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim GhcPs
SourceText
NoSourceText Integer
1)) LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
false_Expr
      , LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (
          LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase
            (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a_RDR)
            -- Only one branch to match all nullary constructors
            -- as we already know the tags match but do not emit
            -- the branch if there are no nullary constructors
            (let non_nullary_pats :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
non_nullary_pats = (DataCon
 -> GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs))))
-> [DataCon]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LMatch GhcPs (LocatedA (HsExpr GhcPs))
DataCon
-> GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))
pats_etc [DataCon]
non_nullary_cons
             in if [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons
                then [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
non_nullary_pats
                else [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
non_nullary_pats [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
true_Expr]))
      ]

    method_binds :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
method_binds = GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
eq_bind
    eq_bind :: LHsBind GhcPs
eq_bind = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
2 SrcSpan
loc RdrName
eq_RDR (LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
forall a b. a -> b -> a
const LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
true_Expr) [([LPat GhcPs], LHsExpr GhcPs)]
[([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))]
binds
      where
        binds :: [([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))]
binds
          | [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
all_cons = []
          -- Tag checking is redundant when there is only one data constructor
          | [DataCon
data_con] <- [DataCon]
all_cons
          , ([RdrName]
as_needed, [RdrName]
bs_needed, [Type]
tys_needed) <- DataCon -> ([RdrName], [RdrName], [Type])
gen_con_fields_and_tys DataCon
data_con
          , RdrName
data_con_RDR <- DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
          , LPat GhcPs
con1_pat <- LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
          , LPat GhcPs
con2_pat <- LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
          , LocatedA (HsExpr GhcPs)
eq_expr <- [Type] -> [RdrName] -> [RdrName] -> LocatedA (HsExpr GhcPs)
nested_eq_expr [Type]
tys_needed [RdrName]
as_needed [RdrName]
bs_needed
          = [([LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
con1_pat, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
con2_pat], LocatedA (HsExpr GhcPs)
eq_expr)]
          -- This is an enum (all constructors are nullary) - just do a simple tag check
          | (DataCon -> Bool) -> [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DataCon -> Bool
isNullarySrcDataCon [DataCon]
all_cons
          = [([LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
a_Pat, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
b_Pat], [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR,RdrName
ah_RDR), (RdrName
b_RDR,RdrName
bh_RDR)]
                    (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
ah_RDR) RdrName
eqInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
bh_RDR)))]
          | Bool
otherwise
          = [([LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
a_Pat, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
b_Pat], LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
eq_expr_with_tag_check)]

    ------------------------------------------------------------------
    nested_eq_expr :: [Type] -> [RdrName] -> [RdrName] -> LocatedA (HsExpr GhcPs)
nested_eq_expr []  [] [] = LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
true_Expr
    nested_eq_expr [Type]
tys [RdrName]
as [RdrName]
bs
      = (LocatedA (HsExpr GhcPs)
 -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> [LocatedA (HsExpr GhcPs)] -> LocatedA (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
and_Expr (String
-> (Type -> RdrName -> RdrName -> LocatedA (HsExpr GhcPs))
-> [Type]
-> [RdrName]
-> [RdrName]
-> [LocatedA (HsExpr GhcPs)]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"nested_eq" Type -> RdrName -> RdrName -> LocatedA (HsExpr GhcPs)
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 GhcPs
nested_eq Type
ty RdrName
a RdrName
b = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr Type
ty (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a) (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b))

    gen_con_fields_and_tys :: DataCon -> ([RdrName], [RdrName], [Type])
gen_con_fields_and_tys DataCon
data_con
      | [Type]
tys_needed <- DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit
      , Arity
con_arity <- [Type] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tys_needed
      , [RdrName]
as_needed <- Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
as_RDRs
      , [RdrName]
bs_needed <- Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
bs_RDRs
      = ([RdrName]
as_needed, [RdrName]
bs_needed, [Type]
tys_needed)

    pats_etc :: DataCon -> LMatch GhcPs (LocatedA (HsExpr GhcPs))
pats_etc DataCon
data_con
      | ([RdrName]
as_needed, [RdrName]
bs_needed, [Type]
tys_needed) <- DataCon -> ([RdrName], [RdrName], [Type])
gen_con_fields_and_tys DataCon
data_con
      , RdrName
data_con_RDR <- DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
      , LPat GhcPs
con1_pat <- LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
      , LPat GhcPs
con2_pat <- LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
      , LocatedA (HsExpr GhcPs)
fields_eq_expr <- [Type] -> [RdrName] -> [RdrName] -> LocatedA (HsExpr GhcPs)
nested_eq_expr [Type]
tys_needed [RdrName]
as_needed [RdrName]
bs_needed
      = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
con1_pat (LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
con2_pat LocatedA (HsExpr GhcPs)
fields_eq_expr])

{-
************************************************************************
*                                                                      *
        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 dataToTag# a of a# ->
     case dataToTag# 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 GhcPs
ltResult OrdOp
OrdCompare = LHsExpr GhcPs
ltTag_Expr
ltResult OrdOp
OrdLT      = LHsExpr GhcPs
true_Expr
ltResult OrdOp
OrdLE      = LHsExpr GhcPs
true_Expr
ltResult OrdOp
OrdGE      = LHsExpr GhcPs
false_Expr
ltResult OrdOp
OrdGT      = LHsExpr GhcPs
false_Expr

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

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

------------
gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Ord_binds SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                   , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args }) = do
    (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
  Bag AuxBindSpec)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       Bag AuxBindSpec))
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
forall a b. (a -> b) -> a -> b
$ if [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
tycon_data_cons -- No data-cons => invoke bale-out case
      then ( GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
 -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)))
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a b. (a -> b) -> a -> b
$ Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
2 SrcSpan
loc RdrName
compare_RDR (LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
forall a b. a -> b -> a
const LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
eqTag_Expr) []
           , Bag AuxBindSpec
forall a. Bag a
emptyBag)
      else ( GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag (OrdOp -> LHsBind GhcPs
mkOrdOp OrdOp
OrdCompare)
             Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
other_ops
           , Bag AuxBindSpec
forall a. Bag a
aux_binds)
  where
    aux_binds :: Bag a
aux_binds = Bag a
forall a. Bag a
emptyBag

        -- Note [Game plan for deriving Ord]
    other_ops :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
other_ops
      | (Arity
last_tag Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
first_tag) Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
2     -- 1-3 constructors
        Bool -> Bool -> Bool
|| [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons        -- Or it's an enumeration
      = [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [OrdOp -> LHsBind GhcPs
mkOrdOp OrdOp
OrdLT, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
lE, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
gT, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
gE]
      | Bool
otherwise
      = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. Bag a
emptyBag

    negate_expr :: LHsExpr GhcPs -> LHsExpr GhcPs
negate_expr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
not_RDR)
    lE :: LHsBind GhcPs
lE = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
le_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
        LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
negate_expr (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
lt_RDR) LHsExpr GhcPs
b_Expr) LHsExpr GhcPs
a_Expr)
    gT :: LHsBind GhcPs
gT = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
gt_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
lt_RDR) LHsExpr GhcPs
b_Expr) LHsExpr GhcPs
a_Expr
    gE :: LHsBind GhcPs
gE = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
ge_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
        LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
negate_expr (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
lt_RDR) LHsExpr GhcPs
a_Expr) LHsExpr GhcPs
b_Expr)

    get_tag :: DataCon -> Arity
get_tag DataCon
con = DataCon -> Arity
dataConTag DataCon
con Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
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 -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
    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 :: Arity
first_tag       = DataCon -> Arity
get_tag DataCon
first_con
    last_tag :: Arity
last_tag        = DataCon -> Arity
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 :: OrdOp -> LHsBind GhcPs
    -- Returns a binding   op a b = ... compares a and b according to op ....
    mkOrdOp :: OrdOp -> LHsBind GhcPs
mkOrdOp OrdOp
op
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc (OrdOp -> RdrName
ordMethRdr OrdOp
op) [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat]
                        (OrdOp -> LHsExpr GhcPs
mkOrdOpRhs OrdOp
op)

    mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
    mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
mkOrdOpRhs OrdOp
op -- RHS for comparing 'a' and 'b' according to op
      | [DataCon]
nullary_cons [DataCon] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthAtMost` Arity
2 -- Two nullary or fewer, so use cases
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a_RDR) ([LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        (DataCon
 -> GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs))))
-> [DataCon]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt 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
null [DataCon]
non_nullary_cons    -- All nullary, so go straight to comparing tags
      = OrdOp -> LHsExpr GhcPs
mkTagCmp OrdOp
op

      | Bool
otherwise                -- Mixed nullary and non-nullary
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a_RDR) ([LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        ((DataCon
 -> GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs))))
-> [DataCon]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt OrdOp
op) [DataCon]
non_nullary_cons
         [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
mkTagCmp OrdOp
op)])


    mkOrdOpAlt :: OrdOp -> DataCon
               -> LMatch GhcPs (LHsExpr GhcPs)
    -- Make the alternative  (Ki a1 a2 .. av ->
    mkOrdOpAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt OrdOp
op DataCon
data_con
      = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed)
                    (OrdOp -> DataCon -> LocatedA (HsExpr GhcPs)
mkInnerRhs OrdOp
op DataCon
data_con)
      where
        as_needed :: [RdrName]
as_needed    = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
data_con) [RdrName]
as_RDRs
        data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con

    mkInnerRhs :: OrdOp -> DataCon -> LocatedA (HsExpr GhcPs)
mkInnerRhs OrdOp
op DataCon
data_con
      | Bool
single_con_type
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con ]

      | Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
first_tag
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) ]
      | Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
last_tag
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) ]

      | Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
first_tag Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [ LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat GhcPs
nlConWildPat DataCon
first_con)
                                             (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op)
                                 , OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) ]
      | Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
last_tag Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [ LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat GhcPs
nlConWildPat DataCon
last_con)
                                             (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op)
                                 , OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) ]

      | Arity
tag Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
last_tag Arity -> Arity -> Arity
forall a. Integral a => a -> a -> a
`div` Arity
2  -- lower range is larger
      = [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
bh_RDR) RdrName
ltInt_RDR LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
tag_lit)
               (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$  -- Definitely GT
        LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) ]

      | Bool
otherwise               -- upper range is larger
      = [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
bh_RDR) RdrName
gtInt_RDR LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
tag_lit)
               (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$  -- Definitely LT
        LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) ]
      where
        tag :: Arity
tag     = DataCon -> Arity
get_tag DataCon
data_con
        tag_lit :: LocatedA (HsExpr GhcPs)
tag_lit
             = HsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE GhcPs
EpAnnCO
noComments (XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim GhcPs
SourceText
NoSourceText (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger Arity
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 GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
      = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed) (LocatedA (HsExpr GhcPs) -> LMatch GhcPs (LocatedA (HsExpr GhcPs)))
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
        OrdOp -> [Type] -> LHsExpr GhcPs
mkCompareFields OrdOp
op (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit)
      where
        data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
        bs_needed :: [RdrName]
bs_needed    = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
data_con) [RdrName]
bs_RDRs

    mkTagCmp :: OrdOp -> LHsExpr GhcPs
    -- Both constructors known to be nullary
    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
    mkTagCmp :: OrdOp -> LHsExpr GhcPs
mkTagCmp OrdOp
op =
      [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR),(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
        Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
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 GhcPs
mkCompareFields OrdOp
op [Type]
tys
  = [Type] -> [RdrName] -> [RdrName] -> LocatedA (HsExpr GhcPs)
go [Type]
tys [RdrName]
as_RDRs [RdrName]
bs_RDRs
  where
    go :: [Type] -> [RdrName] -> [RdrName] -> LocatedA (HsExpr GhcPs)
go []   [RdrName]
_      [RdrName]
_          = OrdOp -> LHsExpr GhcPs
eqResult OrdOp
op
    go [Type
ty] (RdrName
a:[RdrName]
_)  (RdrName
b:[RdrName]
_)
      | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty     = Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
      | Bool
otherwise             = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a) (OrdOp -> RdrName
ordMethRdr OrdOp
op) (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b)
    go (Type
ty:[Type]
tys) (RdrName
a:[RdrName]
as) (RdrName
b:[RdrName]
bs) = Type
-> RdrName
-> RdrName
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
mk_compare Type
ty RdrName
a RdrName
b
                                  (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op)
                                  ([Type] -> [RdrName] -> [RdrName] -> LocatedA (HsExpr GhcPs)
go [Type]
tys [RdrName]
as [RdrName]
bs)
                                  (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op)
    go [Type]
_ [RdrName]
_ [RdrName]
_ = String -> LocatedA (HsExpr GhcPs)
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
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
mk_compare Type
ty RdrName
a RdrName
b LocatedA (HsExpr GhcPs)
lt LocatedA (HsExpr GhcPs)
eq LocatedA (HsExpr GhcPs)
gt
      | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty
      = RdrName
-> RdrName
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr GhcPs
a_expr LHsExpr GhcPs
b_expr LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
lt LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
eq LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
gt
      | Bool
otherwise
      = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
compare_RDR) LHsExpr GhcPs
a_expr) LHsExpr GhcPs
b_expr))
          [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
ltTag_RDR) LocatedA (HsExpr GhcPs)
lt,
           LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
eqTag_RDR) LocatedA (HsExpr GhcPs)
eq,
           LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
gtTag_RDR) LocatedA (HsExpr GhcPs)
gt]
      where
        a_expr :: LHsExpr GhcPs
a_expr = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a
        b_expr :: LHsExpr GhcPs
b_expr = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
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 GhcPs
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
  = case OrdOp
op of
       OrdOp
OrdCompare -> RdrName
-> RdrName
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr GhcPs
a_expr LHsExpr GhcPs
b_expr
                                     LHsExpr GhcPs
ltTag_Expr LHsExpr GhcPs
eqTag_Expr LHsExpr GhcPs
gtTag_Expr
       OrdOp
OrdLT      -> RdrName -> LHsExpr GhcPs
wrap RdrName
lt_op
       OrdOp
OrdLE      -> RdrName -> LHsExpr GhcPs
wrap RdrName
le_op
       OrdOp
OrdGE      -> RdrName -> LHsExpr GhcPs
wrap RdrName
ge_op
       OrdOp
OrdGT      -> RdrName -> LHsExpr GhcPs
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 GhcPs
wrap RdrName
prim_op = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a_expr RdrName
prim_op LHsExpr GhcPs
b_expr
   a_expr :: LHsExpr GhcPs
a_expr = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a
   b_expr :: LHsExpr GhcPs
b_expr = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
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 GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr GhcPs
a_expr LHsExpr GhcPs
b_expr LHsExpr GhcPs
lt LHsExpr GhcPs
eq LHsExpr GhcPs
gt
  = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall p a an.
(XExprWithTySig p ~ EpAnn a,
 XRec (NoGhcTc p) (HsSigType (NoGhcTc p))
 ~ GenLocated SrcSpanAnnA (HsSigType GhcPs),
 NoGhcTc p ~ GhcPs) =>
XRec p (HsExpr p) -> LocatedAn an (HsExpr p)
ascribeBool (LHsExpr GhcPs -> LocatedA (HsExpr GhcPs))
-> LHsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a_expr RdrName
lt_op LHsExpr GhcPs
b_expr) LHsExpr GhcPs
lt (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
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 GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall p a an.
(XExprWithTySig p ~ EpAnn a,
 XRec (NoGhcTc p) (HsSigType (NoGhcTc p))
 ~ GenLocated SrcSpanAnnA (HsSigType GhcPs),
 NoGhcTc p ~ GhcPs) =>
XRec p (HsExpr p) -> LocatedAn an (HsExpr p)
ascribeBool (LHsExpr GhcPs -> LocatedA (HsExpr GhcPs))
-> LHsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a_expr RdrName
eq_op LHsExpr GhcPs
b_expr) LHsExpr GhcPs
eq LHsExpr GhcPs
gt
  where
    ascribeBool :: XRec p (HsExpr p) -> LocatedAn an (HsExpr p)
ascribeBool XRec p (HsExpr p)
e = HsExpr p -> LocatedAn an (HsExpr p)
forall a an. a -> LocatedAn an a
noLocA (HsExpr p -> LocatedAn an (HsExpr p))
-> HsExpr p -> LocatedAn an (HsExpr p)
forall a b. (a -> b) -> a -> b
$ XExprWithTySig p
-> XRec p (HsExpr p) -> LHsSigWcType (NoGhcTc p) -> HsExpr p
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig XExprWithTySig p
forall a. EpAnn a
noAnn XRec p (HsExpr p)
e
                           (LHsSigWcType (NoGhcTc p) -> HsExpr p)
-> LHsSigWcType (NoGhcTc p) -> HsExpr p
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (GenLocated SrcSpanAnnA (HsSigType GhcPs)
 -> HsWildCardBndrs
      GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
-> GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType
                           (LHsType GhcPs -> HsSigType GhcPs)
-> LHsType GhcPs -> HsSigType GhcPs
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar IdP GhcPs
RdrName
boolTyCon_RDR

nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
nlConWildPat :: DataCon -> LPat GhcPs
nlConWildPat DataCon
con = Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a an. a -> LocatedAn an a
noLocA (Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
  { pat_con_ext :: XConPat GhcPs
pat_con_ext = XConPat GhcPs
forall a. EpAnn a
noAnn
  , pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = RdrName -> LocatedAn NameAnn RdrName
forall a an. a -> LocatedAn an a
noLocA (RdrName -> LocatedAn NameAnn RdrName)
-> RdrName -> LocatedAn NameAnn RdrName
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
  , pat_args :: HsConPatDetails GhcPs
pat_args = HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))
-> HsConDetails
     (HsPatSigType GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))
 -> HsConDetails
      (HsPatSigType GhcPs)
      (GenLocated SrcSpanAnnA (Pat GhcPs))
      (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))))
-> HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))
-> HsConDetails
     (HsPatSigType GhcPs)
     (GenLocated SrcSpanAnnA (Pat GhcPs))
     (HsRecFields GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs)))
forall a b. (a -> b) -> a -> b
$ HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Arity) -> HsRecFields p arg
HsRecFields
      { rec_flds :: [LHsRecField GhcPs (GenLocated SrcSpanAnnA (Pat GhcPs))]
rec_flds = []
      , rec_dotdot :: Maybe (Located Arity)
rec_dotdot = Maybe (Located Arity)
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 dataToTag# and @tag2con_Foo@ functions, as well as a
@maxtag_Foo@ variable, the later 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 [dataToTag# a .. maxtag_Foo]

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

   enumFromThen a b
     = map tag2con_Foo [dataToTag# a, dataToTag# b .. maxtag_Foo]

    -- or, really...
    enumFromThen a b
      = case dataToTag# a of { a# ->
        case dataToTag# 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 -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Enum_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon}) = do
    -- See Note [Auxiliary binders]
    RdrName
tag2con_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
loc TyCon
tycon
    RdrName
maxtag_RDR  <- SrcSpan -> TyCon -> TcM RdrName
new_maxtag_rdr_name  SrcSpan
loc TyCon
tycon

    (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return ( RdrName
-> RdrName -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
method_binds RdrName
tag2con_RDR RdrName
maxtag_RDR
           , RdrName -> RdrName -> Bag AuxBindSpec
aux_binds    RdrName
tag2con_RDR RdrName
maxtag_RDR )
  where
    method_binds :: RdrName
-> RdrName -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
method_binds RdrName
tag2con_RDR RdrName
maxtag_RDR = [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag
      [ RdrName -> RdrName -> LHsBind GhcPs
succ_enum      RdrName
tag2con_RDR RdrName
maxtag_RDR
      , RdrName -> LHsBind GhcPs
pred_enum      RdrName
tag2con_RDR
      , RdrName -> RdrName -> LHsBind GhcPs
to_enum        RdrName
tag2con_RDR RdrName
maxtag_RDR
      , RdrName -> RdrName -> LHsBind GhcPs
enum_from      RdrName
tag2con_RDR RdrName
maxtag_RDR -- [0 ..]
      , RdrName -> RdrName -> LHsBind GhcPs
enum_from_then RdrName
tag2con_RDR RdrName
maxtag_RDR -- [0, 1 ..]
      , LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
from_enum
      ]
    aux_binds :: RdrName -> RdrName -> Bag AuxBindSpec
aux_binds RdrName
tag2con_RDR RdrName
maxtag_RDR = [AuxBindSpec] -> Bag AuxBindSpec
forall a. [a] -> Bag a
listToBag
      [ TyCon -> RdrName -> AuxBindSpec
DerivTag2Con TyCon
tycon RdrName
tag2con_RDR
      , TyCon -> RdrName -> AuxBindSpec
DerivMaxTag  TyCon
tycon RdrName
maxtag_RDR
      ]

    occ_nm :: String
occ_nm = TyCon -> String
forall a. NamedThing a => a -> String
getOccString TyCon
tycon

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

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

    to_enum :: RdrName -> RdrName -> LHsBind GhcPs
to_enum RdrName
tag2con_RDR RdrName
maxtag_RDR
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
toEnum_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
and_RDR
                [IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
ge_RDR [IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a_RDR, Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0],
                 IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
le_RDR [ IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a_RDR
                                 , IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
maxtag_RDR]])
             (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
tag2con_RDR [IdP GhcPs
RdrName
a_RDR])
             (String -> RdrName -> LHsExpr GhcPs
illegal_toEnum_tag String
occ_nm RdrName
maxtag_RDR)

    enum_from :: RdrName -> RdrName -> LHsBind GhcPs
enum_from RdrName
tag2con_RDR RdrName
maxtag_RDR
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFrom_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
          IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
map_RDR
                [IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
tag2con_RDR,
                 LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_to_Expr
                            (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
ah_RDR])
                            (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
maxtag_RDR))]

    enum_from_then :: RdrName -> RdrName -> LHsBind GhcPs
enum_from_then RdrName
tag2con_RDR RdrName
maxtag_RDR
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFromThen_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR), (RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
          LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
map_RDR [IdP GhcPs
RdrName
tag2con_RDR]) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
            LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_then_to_Expr
                    (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
ah_RDR])
                    (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
bh_RDR])
                    (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf  (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
gt_RDR [IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
ah_RDR],
                                               IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
bh_RDR]])
                           (Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0)
                           (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
maxtag_RDR)
                           ))

    from_enum :: LHsBind GhcPs
from_enum
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
fromEnum_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
          (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
ah_RDR])

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

gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Bounded_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon})
  | TyCon -> Bool
isEnumerationTyCon TyCon
tycon
  = ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [ LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
min_bound_enum, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
max_bound_enum ], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  | Bool
otherwise
  = Bool
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
forall a. HasCallStack => Bool -> a -> a
assert ([DataCon] -> Bool
forall a. [a] -> Bool
isSingleton [DataCon]
data_cons)
    ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [ LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
min_bound_1con, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
max_bound_1con ], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon

    ----- enum-flavored: ---------------------------
    min_bound_enum :: LHsBind GhcPs
min_bound_enum = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
data_con_1_RDR)
    max_bound_enum :: LHsBind GhcPs
max_bound_enum = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
maxBound_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
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
getRdrName DataCon
data_con_1
    data_con_N_RDR :: RdrName
data_con_N_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con_N

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

    min_bound_1con :: LHsBind GhcPs
min_bound_1con = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
                     IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
data_con_1_RDR (Arity -> RdrName -> [RdrName]
forall a. Arity -> a -> [a]
replicate Arity
arity RdrName
minBound_RDR)
    max_bound_1con :: LHsBind GhcPs
max_bound_1con = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
maxBound_RDR (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
                     IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
data_con_1_RDR (Arity -> RdrName -> [RdrName]
forall a. Arity -> a -> [a]
replicate Arity
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 [dataToTag# a .. dataToTag# b]

    -- or, really...
    range (a, b)
      = case (dataToTag# a) of { a# ->
        case (dataToTag# 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 (dataToTag# d -# dataToTag# a) of
               r# -> I# r#

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

    -- or, really...
    inRange (a, b) c
      = case (dataToTag# a)   of { a_tag ->
        case (dataToTag# b)   of { b_tag ->
        case (dataToTag# 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 -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)

gen_Ix_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Ix_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon}) = do
    -- See Note [Auxiliary binders]
    RdrName
tag2con_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
loc TyCon
tycon

    (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
  Bag AuxBindSpec)
 -> IOEnv
      (Env TcGblEnv TcLclEnv)
      (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
       Bag AuxBindSpec))
-> (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
    Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
forall a b. (a -> b) -> a -> b
$ if TyCon -> Bool
isEnumerationTyCon TyCon
tycon
      then (RdrName -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
enum_ixes RdrName
tag2con_RDR, [AuxBindSpec] -> Bag AuxBindSpec
forall a. [a] -> Bag a
listToBag
                   [ TyCon -> RdrName -> AuxBindSpec
DerivTag2Con TyCon
tycon RdrName
tag2con_RDR
                   ])
      else (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
single_con_ixes, Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    --------------------------------------------------------------
    enum_ixes :: RdrName -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
enum_ixes RdrName
tag2con_RDR = [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag
      [ RdrName -> LHsBind GhcPs
enum_range   RdrName
tag2con_RDR
      , LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
enum_index
      , LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
enum_inRange
      ]

    enum_range :: RdrName -> LHsBind GhcPs
enum_range RdrName
tag2con_RDR
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR [[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] Boxity
Boxed] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
          LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
map_RDR [IdP GhcPs
RdrName
tag2con_RDR]) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
              LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_to_Expr
                        (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
ah_RDR])
                        (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
bh_RDR]))

    enum_index :: LHsBind GhcPs
enum_index
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
                [Pat GhcPs -> GenLocated SrcSpanAnnA (Pat GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XAsPat GhcPs -> LIdP GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat XAsPat GhcPs
forall a. EpAnn a
noAnn (RdrName -> LocatedAn NameAnn RdrName
forall a an. a -> LocatedAn an a
noLocA RdrName
c_RDR)
                           ([LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [LPat GhcPs
a_Pat, LPat GhcPs
nlWildPat] Boxity
Boxed)),
                                LPat GhcPs
d_Pat] (
           [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (
           [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
d_RDR, RdrName
dh_RDR)] (
           let
                rhs :: LHsExpr GhcPs
rhs = IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
intDataCon_RDR [IdP GhcPs
RdrName
c_RDR]
           in
           LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase
             (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
dh_RDR) RdrName
minusInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
ah_RDR))
             [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
c_RDR) LocatedA (HsExpr GhcPs)
rhs]
           ))
        )

    -- This produces something like `(ch >= ah) && (ch <= bh)`
    enum_inRange :: LHsBind GhcPs
enum_inRange
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR [[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] Boxity
Boxed, LPat GhcPs
c_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (
          [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
c_RDR, RdrName
ch_RDR)] (
          -- This used to use `if`, which interacts badly with RebindableSyntax.
          -- See #11396.
          IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
and_RDR
              [ LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
ch_RDR) RdrName
geInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
ah_RDR)
              , LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
ch_RDR) RdrName
leInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
bh_RDR)
              ]
          )))

    --------------------------------------------------------------
    single_con_ixes :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
single_con_ixes
      = [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
single_con_range, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
single_con_index, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
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 :: Arity
con_arity    = DataCon -> Arity
dataConSourceArity DataCon
data_con
    data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con

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

    con_pat :: [RdrName] -> LPat GhcPs
con_pat  [RdrName]
xs  = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
xs
    con_expr :: LHsExpr GhcPs
con_expr     = IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
data_con_RDR [IdP GhcPs]
[RdrName]
cs_needed

    --------------------------------------------------------------
    single_con_range :: LHsBind GhcPs
single_con_range
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR
          [[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [[RdrName] -> LPat GhcPs
con_pat [RdrName]
as_needed, [RdrName] -> LPat GhcPs
con_pat [RdrName]
bs_needed] Boxity
Boxed] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
        HsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsComp HsDoFlavour
ListComp [ExprLStmt GhcPs]
[LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
stmts LHsExpr GhcPs
con_expr)
      where
        stmts :: [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
stmts = String
-> (RdrName
    -> RdrName
    -> RdrName
    -> LocatedAn
         AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_range" RdrName
-> RdrName
-> RdrName
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an.
RdrName
-> RdrName
-> RdrName
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
mk_qual [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed

        mk_qual :: RdrName
-> RdrName
-> RdrName
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
mk_qual RdrName
a RdrName
b RdrName
c = StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
 -> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
mkPsBindStmt EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn (IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
c)
                                 (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
range_RDR)
                                          ([IdP GhcPs] -> XExplicitTuple GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [IdP GhcPs
RdrName
a,IdP GhcPs
RdrName
b] XExplicitTuple GhcPs
forall a. EpAnn a
noAnn))

    ----------------
    single_con_index :: LHsBind GhcPs
single_con_index
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
                [[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [[RdrName] -> LPat GhcPs
con_pat [RdrName]
as_needed, [RdrName] -> LPat GhcPs
con_pat [RdrName]
bs_needed] Boxity
Boxed,
                 [RdrName] -> LPat GhcPs
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)] -> LocatedA (HsExpr GhcPs)
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)] -> LocatedA (HsExpr GhcPs)
mk_index []        = Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0
        mk_index [(RdrName
l,RdrName
u,RdrName
i)] = RdrName -> RdrName -> RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
(IsPass p, IdGhcP p ~ RdrName,
 Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn),
 XExplicitTuple (GhcPass p) ~ EpAnn a) =>
RdrName
-> RdrName
-> RdrName
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_one RdrName
l RdrName
u RdrName
i
        mk_index ((RdrName
l,RdrName
u,RdrName
i) : [(RdrName, RdrName, RdrName)]
rest)
          = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (
                RdrName -> RdrName -> RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
(IsPass p, IdGhcP p ~ RdrName,
 Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn),
 XExplicitTuple (GhcPass p) ~ EpAnn a) =>
RdrName
-> RdrName
-> RdrName
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_one RdrName
l RdrName
u RdrName
i
            ) RdrName
plus_RDR (
                LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (
                    (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
unsafeRangeSize_RDR)
                             ([IdP GhcPs] -> XExplicitTuple GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [IdP GhcPs
RdrName
l,IdP GhcPs
RdrName
u] XExplicitTuple GhcPs
forall a. EpAnn a
noAnn))
                ) RdrName
times_RDR ([(RdrName, RdrName, RdrName)] -> LocatedA (HsExpr GhcPs)
mk_index [(RdrName, RdrName, RdrName)]
rest)
           )
        mk_one :: RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass p)
mk_one RdrName
l RdrName
u RdrName
i
          = IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass p)
RdrName
unsafeIndex_RDR [[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [IdP (GhcPass p)
RdrName
l,IdP (GhcPass p)
RdrName
u] XExplicitTuple (GhcPass p)
forall a. EpAnn a
noAnn, IdP (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass p)
RdrName
i]

    ------------------
    single_con_inRange :: LHsBind GhcPs
single_con_inRange
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR
                [[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [[RdrName] -> LPat GhcPs
con_pat [RdrName]
as_needed, [RdrName] -> LPat GhcPs
con_pat [RdrName]
bs_needed] Boxity
Boxed,
                 [RdrName] -> LPat GhcPs
con_pat [RdrName]
cs_needed] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
          if Arity
con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
             -- If the product type has no fields, inRange is trivially true
             -- (see #12853).
             then LHsExpr GhcPs
true_Expr
             else (LocatedA (HsExpr GhcPs)
 -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> [LocatedA (HsExpr GhcPs)] -> LocatedA (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
and_Expr (String
-> (RdrName -> RdrName -> RdrName -> LocatedA (HsExpr GhcPs))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [LocatedA (HsExpr GhcPs)]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_inRange" RdrName -> RdrName -> RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
(IsPass p, IdGhcP p ~ RdrName,
 Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn),
 XExplicitTuple (GhcPass p) ~ EpAnn a) =>
RdrName
-> RdrName
-> RdrName
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
in_range
                    [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed)
      where
        in_range :: RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass p)
in_range RdrName
a RdrName
b RdrName
c
          = IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass p)
RdrName
inRange_RDR [[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [IdP (GhcPass p)
RdrName
a,IdP (GhcPass p)
RdrName
b] XExplicitTuple (GhcPass p)
forall a. EpAnn a
noAnn, IdP (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass p)
RdrName
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 -> DerivInstTys
               -> (LHsBinds GhcPs, Bag AuxBindSpec)

gen_Read_binds :: (Name -> Fixity)
-> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Read_binds Name -> Fixity
get_fixity SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon})
  = ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
read_prec, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
default_readlist, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
default_readlistprec], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    -----------------------------------------------------------------------
    default_readlist :: LHsBind GhcPs
default_readlist
        = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
readList_RDR     (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
readListDefault_RDR)

    default_readlistprec :: LHsBind GhcPs
default_readlistprec
        = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
readListPrec_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
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 GhcPs
read_prec = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
readPrec_RDR LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
rhs
      where
        rhs :: LocatedA (HsExpr GhcPs)
rhs | [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons -- See Note [Read for empty data types]
            = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
pfail_RDR
            | Bool
otherwise
            = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
parens_RDR)
                      ((LocatedA (HsExpr GhcPs)
 -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> [LocatedA (HsExpr GhcPs)] -> LocatedA (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
mk_alt ([LocatedA (HsExpr GhcPs)]
read_nullary_cons [LocatedA (HsExpr GhcPs)]
-> [LocatedA (HsExpr GhcPs)] -> [LocatedA (HsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++
                                      [LocatedA (HsExpr GhcPs)]
read_non_nullary_cons))

    read_non_nullary_cons :: [LocatedA (HsExpr GhcPs)]
read_non_nullary_cons = (DataCon -> LocatedA (HsExpr GhcPs))
-> [DataCon] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LocatedA (HsExpr GhcPs)
read_non_nullary_con [DataCon]
non_nullary_cons

    read_nullary_cons :: [LocatedA (HsExpr GhcPs)]
read_nullary_cons
      = case [DataCon]
nullary_cons of
            []    -> []
            [DataCon
con] -> [HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
nlHsDo (Maybe ModuleName -> HsDoFlavour
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing) (DataCon
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a an (idL :: Pass).
NamedThing a =>
a
-> [LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))]
match_con DataCon
con [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
 -> LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt (DataCon -> [IdGhcP 'Parsed] -> LocatedA (HsExpr GhcPs)
forall thing (id :: Pass).
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName,
 Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn)) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr DataCon
con [])])]
            [DataCon]
_     -> [LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
choose_RDR)
                              ([LHsExpr GhcPs] -> LHsExpr GhcPs
nlList ((DataCon -> LocatedA (HsExpr GhcPs))
-> [DataCon] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LocatedA (HsExpr GhcPs)
forall thing (p :: Pass) a.
(NamedThing thing, IsPass p, IdGhcP p ~ RdrName,
 Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn),
 XExplicitTuple (GhcPass p) ~ EpAnn a) =>
thing -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
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
-> [LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))]
match_con a
con | String -> Bool
isSym String
con_str = [String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
symbol_pat String
con_str]
                  | Bool
otherwise     = String
-> [LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))]
forall an (idL :: Pass).
String
-> [LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))]
ident_h_pat  String
con_str
                  where
                    con_str :: String
con_str = a -> String
forall a. NamedThing a => a -> String
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 p)
mk_pair thing
con = [LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass).
[LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsTupleExpr [HsLit (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass p)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (thing -> String
forall a. NamedThing a => a -> String
data_con_str thing
con)),
                                  thing -> [IdGhcP p] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall thing (id :: Pass).
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName,
 Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn)) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr thing
con []] XExplicitTuple (GhcPass p)
forall a. EpAnn a
noAnn

    read_non_nullary_con :: DataCon -> LocatedA (HsExpr GhcPs)
read_non_nullary_con DataCon
data_con
      | Bool
is_infix  = Integer
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
mk_parser Integer
infix_prec  [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
infix_stmts  LocatedA (HsExpr GhcPs)
body
      | Bool
is_record = Integer
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
mk_parser Integer
record_prec [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
record_stmts LocatedA (HsExpr GhcPs)
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 = LocatedA (HsExpr GhcPs)
prefix_parser
      where
        body :: LocatedA (HsExpr GhcPs)
body = DataCon -> [IdGhcP 'Parsed] -> LocatedA (HsExpr GhcPs)
forall thing (id :: Pass).
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName,
 Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn)) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr DataCon
data_con [IdGhcP 'Parsed]
[RdrName]
as_needed
        con_str :: String
con_str = DataCon -> String
forall a. NamedThing a => a -> String
data_con_str DataCon
data_con

        prefix_parser :: LocatedA (HsExpr GhcPs)
prefix_parser = Integer
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
mk_parser Integer
prefix_prec [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
prefix_stmts LocatedA (HsExpr GhcPs)
body

        read_prefix_con :: [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_prefix_con
            | String -> Bool
isSym String
con_str = [String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
"(", String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
symbol_pat String
con_str, String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
")"]
            | Bool
otherwise     = String
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall an (idL :: Pass).
String
-> [LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))]
ident_h_pat String
con_str

        read_infix_con :: [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_infix_con
            | String -> Bool
isSym String
con_str = [String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
symbol_pat String
con_str]
            | Bool
otherwise     = [String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
"`"] [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ String
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall an (idL :: Pass).
String
-> [LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))]
ident_h_pat String
con_str [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
"`"]

        prefix_stmts :: [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
prefix_stmts            -- T a b c
          = [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_prefix_con [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_args

        infix_stmts :: [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
infix_stmts             -- a %% b, or  a `T` b
          = [LocatedAn
  AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
read_a1]
            [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_infix_con
            [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [LocatedAn
  AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
read_a2]

        record_stmts :: [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
record_stmts            -- T { f1 = a, f2 = b }
          = [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_prefix_con
            [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
"{"]
            [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [[LocatedAn
    AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [[LocatedAn
       AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]]
-> [[LocatedAn
       AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]]
forall a. a -> [a] -> [a]
intersperse [String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
","] [[LocatedAn
    AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]]
field_stmts)
            [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [String
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
"}"]

        field_stmts :: [[LocatedAn
    AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]]
field_stmts  = String
-> (FastString
    -> RdrName
    -> [LocatedAn
          AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))])
-> [FastString]
-> [RdrName]
-> [[LocatedAn
       AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"lbl_stmts" FastString
-> RdrName
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall an.
FastString
-> RdrName
-> [LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_field [FastString]
labels [RdrName]
as_needed

        con_arity :: Arity
con_arity    = DataCon -> Arity
dataConSourceArity DataCon
data_con
        labels :: [FastString]
labels       = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel ([FieldLabel] -> [FastString]) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
        dc_nm :: Name
dc_nm        = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con
        is_infix :: Bool
is_infix     = DataCon -> Bool
dataConIsInfix DataCon
data_con
        is_record :: Bool
is_record    = [FastString]
labels [FastString] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthExceeds` Arity
0
        as_needed :: [RdrName]
as_needed    = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
as_RDRs
        read_args :: [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_args    = String
-> (RdrName
    -> Type
    -> LocatedAn
         AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
-> [RdrName]
-> [Type]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Read_binds" RdrName
-> Type
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall an.
RdrName
-> Type
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
read_arg [RdrName]
as_needed (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit)
        (LocatedAn
  AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
read_a1:LocatedAn
  AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
read_a2:[LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
_) = [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
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
+ Integer
1 -- Record construction binds even more tightly
                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})

    ------------------------------------------------------------------------
    --          Helpers
    ------------------------------------------------------------------------
    mk_alt :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs) -> LHsExpr GhcPs
mk_alt LocatedA (HsExpr GhcPs)
e1 LocatedA (HsExpr GhcPs)
e2       = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
e1 RdrName
alt_RDR LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
e2                         -- e1 +++ e2
    mk_parser :: Integer
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> LocatedA (HsExpr GhcPs)
-> LHsExpr GhcPs
mk_parser Integer
p [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
ss LocatedA (HsExpr GhcPs)
b   = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
prec_RDR [Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
p                -- prec p (do { ss ; b })
                                           , HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
nlHsDo (Maybe ModuleName -> HsDoFlavour
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing) ([LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
ss [LocatedAn
   AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
-> [LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
 -> LocatedAn
      AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn
     AnnListItem (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt LocatedA (HsExpr GhcPs)
b])]
    con_app :: thing -> [IdGhcP p] -> LHsExpr (GhcPass p)
con_app thing
con [IdGhcP p]
as     = IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps (thing -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName thing
con) [IdGhcP p]
[IdP (GhcPass p)]
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)
nlHsApp (IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass id)
RdrName
returnM_RDR) (thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
forall thing (id :: Pass).
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName,
 Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn)) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
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
-> [LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))]
ident_h_pat String
s | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [ String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
ident_pat String
ss, String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
symbol_pat String
"#" ]
                  | Bool
otherwise                    = [ String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
ident_pat String
s ]

    bindLex :: LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
bindLex LocatedA (HsExpr GhcPs)
pat  = StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (LocatedA (HsExpr GhcPs)
-> StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs))
forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))
mkBodyStmt (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
expectP_RDR) LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
pat)) -- expectP p
                   -- See Note [Use expectP]
    ident_pat :: String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
ident_pat  String
s = LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
bindLex (LocatedA (HsExpr GhcPs)
 -> LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs))))
-> LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
ident_RDR  [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]  -- expectP (Ident "foo")
    symbol_pat :: String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
symbol_pat String
s = LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
bindLex (LocatedA (HsExpr GhcPs)
 -> LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs))))
-> LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
symbol_RDR [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]  -- expectP (Symbol ">>")
    read_punc :: String
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
read_punc String
c  = LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall an (idL :: Pass).
LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
bindLex (LocatedA (HsExpr GhcPs)
 -> LocatedAn
      an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs))))
-> LocatedA (HsExpr GhcPs)
-> LocatedAn
     an (StmtLR (GhcPass idL) GhcPs (LocatedA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
punc_RDR   [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
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
getOccName a
con)

    read_arg :: RdrName
-> Type
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
read_arg RdrName
a Type
ty = Bool
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty)) (LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
 -> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))))
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$
                    StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA (EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
mkPsBindStmt EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn (IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
a) (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
step_RDR [IdP GhcPs
RdrName
readPrec_RDR]))

    -- When reading field labels we might encounter
    --      a  = 3
    --      _a = 3
    -- or   (#) = 4
    -- Note the parens!
    read_field :: FastString
-> RdrName
-> [LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]
read_field FastString
lbl RdrName
a =
        [StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
-> LocatedAn an (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))
forall a an. a -> LocatedAn an a
noLocA
          (EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs))
forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat GhcPs
-> LocatedA (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
mkPsBindStmt EpAnn [AddEpAnn]
forall a. EpAnn a
noAnn
            (IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
a)
            (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
              LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
read_field
              (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
reset_RDR [IdP GhcPs
RdrName
readPrec_RDR])
            )
          )
        ]
        where
          lbl_str :: String
lbl_str = FastString -> String
unpackFS FastString
lbl
          mk_read_field :: IdGhcP p -> String -> LHsExpr (GhcPass p)
mk_read_field IdGhcP p
read_field_rdr String
lbl
              = IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdGhcP p
IdP (GhcPass p)
read_field_rdr [HsLit (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass p)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
lbl)]
          read_field :: LocatedA (HsExpr GhcPs)
read_field
              | String -> Bool
isSym String
lbl_str
              = IdGhcP 'Parsed -> String -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
(IsPass p, Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a)) =>
IdGhcP p -> String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field IdGhcP 'Parsed
RdrName
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 -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
(IsPass p, Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a)) =>
IdGhcP p -> String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field IdGhcP 'Parsed
RdrName
readFieldHash_RDR String
ss
              | Bool
otherwise
              = IdGhcP 'Parsed -> String -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
(IsPass p, Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a)) =>
IdGhcP p -> String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field IdGhcP 'Parsed
RdrName
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 -> DerivInstTys
               -> (LHsBinds GhcPs, Bag AuxBindSpec)

gen_Show_binds :: (Name -> Fixity)
-> SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Show_binds Name -> Fixity
get_fixity SrcSpan
loc dit :: DerivInstTys
dit@(DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                               , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args })
  = (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
shows_prec, Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
    shows_prec :: LHsBind GhcPs
shows_prec = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
2 SrcSpan
loc RdrName
showsPrec_RDR LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id ((DataCon
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs)))
-> [DataCon]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     LocatedA (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
pats_etc [DataCon]
data_cons)
    comma_space :: LHsExpr GhcPs
comma_space = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
showCommaSpace_RDR

    pats_etc :: DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
pats_etc DataCon
data_con
      | Bool
nullary_con =  -- skip the showParen junk...
         Bool
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
forall a. HasCallStack => Bool -> a -> a
assert ([RdrName] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RdrName]
bs_needed)
         ([LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
nlWildPat, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
con_pat], String -> LHsExpr GhcPs
mk_showString_app String
op_con_str)
      | Bool
otherwise   =
         ([LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
a_Pat, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
con_pat],
          LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
showParen_Expr (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
a_Expr RdrName
ge_RDR (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit
                         (XHsInt GhcPs -> IntegralLit -> HsLit GhcPs
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
XHsInt GhcPs
noExtField (Integer -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
con_prec_plus_one))))
                         (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar ([LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr [LHsExpr GhcPs]
[LocatedA (HsExpr GhcPs)]
show_thingies)))
        where
             data_con_RDR :: RdrName
data_con_RDR  = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
             con_arity :: Arity
con_arity     = DataCon -> Arity
dataConSourceArity DataCon
data_con
             bs_needed :: [RdrName]
bs_needed     = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
bs_RDRs
             arg_tys :: [Type]
arg_tys       = DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit -- Correspond 1-1 with bs_needed
             con_pat :: LPat GhcPs
con_pat       = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
             nullary_con :: Bool
nullary_con   = Arity
con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
             labels :: [FastString]
labels        = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel ([FieldLabel] -> [FastString]) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
             lab_fields :: Arity
lab_fields    = [FastString] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [FastString]
labels
             record_syntax :: Bool
record_syntax = Arity
lab_fields Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
0

             dc_nm :: Name
dc_nm          = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con
             dc_occ_nm :: OccName
dc_occ_nm      = DataCon -> OccName
forall a. NamedThing a => a -> OccName
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 :: [LocatedA (HsExpr GhcPs)]
show_thingies
                | Bool
is_infix      = [LocatedA (HsExpr GhcPs)
show_arg1, String -> LHsExpr GhcPs
mk_showString_app (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
backquote_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "), LocatedA (HsExpr GhcPs)
show_arg2]
                | Bool
record_syntax = String -> LHsExpr GhcPs
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {") LocatedA (HsExpr GhcPs)
-> [LocatedA (HsExpr GhcPs)] -> [LocatedA (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
:
                                  [LocatedA (HsExpr GhcPs)]
show_record_args [LocatedA (HsExpr GhcPs)]
-> [LocatedA (HsExpr GhcPs)] -> [LocatedA (HsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [String -> LHsExpr GhcPs
mk_showString_app String
"}"]
                | Bool
otherwise     = String -> LHsExpr GhcPs
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") LocatedA (HsExpr GhcPs)
-> [LocatedA (HsExpr GhcPs)] -> [LocatedA (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
: [LocatedA (HsExpr GhcPs)]
show_prefix_args

             show_label :: FastString -> LHsExpr GhcPs
show_label FastString
l = String -> LHsExpr GhcPs
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 :: [LocatedA (HsExpr GhcPs)]
show_args               = String
-> (RdrName -> Type -> LocatedA (HsExpr GhcPs))
-> [RdrName]
-> [Type]
-> [LocatedA (HsExpr GhcPs)]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Show_binds" RdrName -> Type -> LHsExpr GhcPs
RdrName -> Type -> LocatedA (HsExpr GhcPs)
show_arg [RdrName]
bs_needed [Type]
arg_tys
             (LocatedA (HsExpr GhcPs)
show_arg1:LocatedA (HsExpr GhcPs)
show_arg2:[LocatedA (HsExpr GhcPs)]
_) = [LocatedA (HsExpr GhcPs)]
show_args
             show_prefix_args :: [LocatedA (HsExpr GhcPs)]
show_prefix_args        = LocatedA (HsExpr GhcPs)
-> [LocatedA (HsExpr GhcPs)] -> [LocatedA (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
intersperse (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
showSpace_RDR) [LocatedA (HsExpr GhcPs)]
show_args

                -- Assumption for record syntax: no of fields == no of
                -- labelled fields (and in same order)
             show_record_args :: [LocatedA (HsExpr GhcPs)]
show_record_args = [[LocatedA (HsExpr GhcPs)]] -> [LocatedA (HsExpr GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[LocatedA (HsExpr GhcPs)]] -> [LocatedA (HsExpr GhcPs)])
-> [[LocatedA (HsExpr GhcPs)]] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$
                                [LocatedA (HsExpr GhcPs)]
-> [[LocatedA (HsExpr GhcPs)]] -> [[LocatedA (HsExpr GhcPs)]]
forall a. a -> [a] -> [a]
intersperse [LocatedA (HsExpr GhcPs)
comma_space] ([[LocatedA (HsExpr GhcPs)]] -> [[LocatedA (HsExpr GhcPs)]])
-> [[LocatedA (HsExpr GhcPs)]] -> [[LocatedA (HsExpr GhcPs)]]
forall a b. (a -> b) -> a -> b
$
                                [ [FastString -> LocatedA (HsExpr GhcPs)
show_label FastString
lbl, LocatedA (HsExpr GhcPs)
arg]
                                | (FastString
lbl,LocatedA (HsExpr GhcPs)
arg) <- String
-> [FastString]
-> [LocatedA (HsExpr GhcPs)]
-> [(FastString, LocatedA (HsExpr GhcPs))]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"gen_Show_binds"
                                                        [FastString]
labels [LocatedA (HsExpr GhcPs)]
show_args ]

             show_arg :: RdrName -> Type -> LHsExpr GhcPs
             show_arg :: RdrName -> Type -> LHsExpr GhcPs
show_arg RdrName
b Type
arg_ty
                 | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
                 -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
                 = LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
with_conv (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
                    IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
compose_RDR
                        [LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app LHsExpr GhcPs
boxed_arg, String -> LHsExpr GhcPs
mk_showString_app String
postfixMod]
                 | Bool
otherwise
                 = Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_showsPrec_app Integer
arg_prec LHsExpr GhcPs
arg
               where
                 arg :: LHsExpr GhcPs
arg        = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
b
                 boxed_arg :: LHsExpr GhcPs
boxed_arg  = String -> LHsExpr GhcPs -> Type -> LHsExpr GhcPs
box String
"Show" LHsExpr GhcPs
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 :: LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
with_conv LocatedA (HsExpr GhcPs)
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 GhcPs] -> LHsExpr GhcPs
nested_compose_Expr
                            [ String -> LHsExpr GhcPs
mk_showString_app (String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
                            , LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
expr
                            , String -> LHsExpr GhcPs
mk_showString_app String
")"
                            ]
                    | Bool
otherwise = LocatedA (HsExpr GhcPs)
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
+ 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 GhcPs
mk_showString_app String
str = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
showString_RDR) (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
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 GhcPs -> LHsExpr GhcPs
mk_showsPrec_app Integer
p LHsExpr GhcPs
x
  = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
showsPrec_RDR [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsInt GhcPs -> IntegralLit -> HsLit GhcPs
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
XHsInt GhcPs
noExtField (Integer -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
p)), LHsExpr GhcPs
x]

-- | shows :: Show a => a -> ShowS
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app LHsExpr GhcPs
x = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
shows_RDR) LHsExpr GhcPs
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 = Arity -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Arity
maxPrecedence Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 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
_ Arity
x FixityDirection
_assoc -> Arity -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Arity
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
               -> DerivInstTys
               -> TcM (LHsBinds GhcPs,  -- The method bindings
                       Bag AuxBindSpec) -- Auxiliary bindings
gen_Data_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Data_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
  = do { -- See Note [Auxiliary binders]
         RdrName
dataT_RDR  <- SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name SrcSpan
loc TyCon
rep_tc
       ; [RdrName]
dataC_RDRs <- (DataCon -> TcM RdrName)
-> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) [RdrName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name SrcSpan
loc) [DataCon]
data_cons

       ; (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
 Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     (Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)),
      Bag AuxBindSpec)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [ LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
gfoldl_bind, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
gunfold_bind
                          , [RdrName] -> LHsBind GhcPs
toCon_bind [RdrName]
dataC_RDRs, RdrName -> LHsBind GhcPs
dataTypeOf_bind RdrName
dataT_RDR ]
                Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
gcast_binds
                          -- Auxiliary definitions: the data type and constructors
              , [AuxBindSpec] -> Bag AuxBindSpec
forall a. [a] -> Bag a
listToBag
                  ( TyCon -> RdrName -> [RdrName] -> AuxBindSpec
DerivDataDataType TyCon
rep_tc RdrName
dataT_RDR [RdrName]
dataC_RDRs
                  AuxBindSpec -> [AuxBindSpec] -> [AuxBindSpec]
forall a. a -> [a] -> [a]
: (DataCon -> RdrName -> AuxBindSpec)
-> [DataCon] -> [RdrName] -> [AuxBindSpec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\DataCon
data_con RdrName
dataC_RDR ->
                               DataCon -> RdrName -> RdrName -> AuxBindSpec
DerivDataConstr DataCon
data_con RdrName
dataC_RDR RdrName
dataT_RDR)
                            [DataCon]
data_cons [RdrName]
dataC_RDRs )
              ) }
  where
    data_cons :: [DataCon]
data_cons  = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
    n_cons :: Arity
n_cons     = [DataCon] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [DataCon]
data_cons
    one_constr :: Bool
one_constr = Arity
n_cons Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1

        ------------ gfoldl
    gfoldl_bind :: LHsBind GhcPs
gfoldl_bind = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
3 SrcSpan
loc RdrName
gfoldl_RDR LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id ((DataCon
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs)))
-> [DataCon]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     LocatedA (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
gfoldl_eqn [DataCon]
data_cons)

    gfoldl_eqn :: DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
gfoldl_eqn DataCon
con
      = ([IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
k_RDR, LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
z_Pat, RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
con_name [RdrName]
as_needed],
                   (LocatedA (HsExpr GhcPs) -> RdrName -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs) -> [RdrName] -> LocatedA (HsExpr GhcPs)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LocatedA (HsExpr GhcPs) -> RdrName -> LocatedA (HsExpr GhcPs)
mk_k_app (LHsExpr GhcPs
z_Expr LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> LocatedA (HsExpr GhcPs)
forall (p :: Pass).
(IsPass p, IdGhcP p ~ RdrName,
 Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn),
 XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
 ~ NoExtField) =>
DataCon -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
eta_expand_data_con DataCon
con)) [RdrName]
as_needed)
                   where
                     con_name ::  RdrName
                     con_name :: RdrName
con_name = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
                     as_needed :: [RdrName]
as_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
con) [RdrName]
as_RDRs
                     mk_k_app :: LocatedA (HsExpr GhcPs) -> RdrName -> LHsExpr GhcPs
mk_k_app LocatedA (HsExpr GhcPs)
e RdrName
v = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
e IdP GhcPs
RdrName
k_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
v))

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

    gunfold_rhs :: LocatedA (HsExpr GhcPs)
gunfold_rhs
        | Bool
one_constr = DataCon -> LocatedA (HsExpr GhcPs)
mk_unfold_rhs ([DataCon] -> DataCon
forall a. [a] -> a
head [DataCon]
data_cons)   -- No need for case
        | Bool
otherwise  = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
conIndex_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
c_Expr)
                                ((DataCon
 -> GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs))))
-> [DataCon]
-> [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LMatch GhcPs (LocatedA (HsExpr GhcPs))
DataCon
-> GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))
gunfold_alt [DataCon]
data_cons)

    gunfold_alt :: DataCon -> LMatch GhcPs (LocatedA (HsExpr GhcPs))
gunfold_alt DataCon
dc = LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (DataCon -> GenLocated SrcSpanAnnA (Pat GhcPs)
mk_unfold_pat DataCon
dc) (DataCon -> LocatedA (HsExpr GhcPs)
mk_unfold_rhs DataCon
dc)
    mk_unfold_rhs :: DataCon -> LocatedA (HsExpr GhcPs)
mk_unfold_rhs DataCon
dc = (LocatedA (HsExpr GhcPs)
 -> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> [LocatedA (HsExpr GhcPs)]
-> LocatedA (HsExpr GhcPs)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
                           (LHsExpr GhcPs
z_Expr LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> LocatedA (HsExpr GhcPs)
forall (p :: Pass).
(IsPass p, IdGhcP p ~ RdrName,
 Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn),
 XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
 ~ NoExtField) =>
DataCon -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
eta_expand_data_con DataCon
dc))
                           (Arity -> LocatedA (HsExpr GhcPs) -> [LocatedA (HsExpr GhcPs)]
forall a. Arity -> a -> [a]
replicate (DataCon -> Arity
dataConSourceArity DataCon
dc) (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
k_RDR))

    eta_expand_data_con :: DataCon -> LHsExpr (GhcPass p)
eta_expand_data_con DataCon
dc =
        [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [LPat (GhcPass p)]
[GenLocated SrcSpanAnnA (Pat (GhcPass p))]
eta_expand_pats
          ((GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
 -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> [GenLocated SrcSpanAnnA (HsExpr (GhcPass p))]
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
dc)) [GenLocated SrcSpanAnnA (HsExpr (GhcPass p))]
eta_expand_hsvars)
      where
        eta_expand_pats :: [GenLocated SrcSpanAnnA (Pat (GhcPass p))]
eta_expand_pats = (RdrName -> GenLocated SrcSpanAnnA (Pat (GhcPass p)))
-> [RdrName] -> [GenLocated SrcSpanAnnA (Pat (GhcPass p))]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> GenLocated SrcSpanAnnA (Pat (GhcPass p))
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat [RdrName]
eta_expand_vars
        eta_expand_hsvars :: [GenLocated SrcSpanAnnA (HsExpr (GhcPass p))]
eta_expand_hsvars = (RdrName -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> [RdrName] -> [GenLocated SrcSpanAnnA (HsExpr (GhcPass p))]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar [RdrName]
eta_expand_vars
        eta_expand_vars :: [RdrName]
eta_expand_vars = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
dc) [RdrName]
as_RDRs


    mk_unfold_pat :: DataCon -> GenLocated SrcSpanAnnA (Pat GhcPs)
mk_unfold_pat DataCon
dc    -- Last one is a wild-pat, to avoid
                        -- redundant test, and annoying warning
      | Arity
tagArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
fIRST_TAG Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
n_consArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1 = LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
nlWildPat   -- Last constructor
      | Bool
otherwise = RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat RdrName
intDataCon_RDR
                             [HsLit GhcPs -> LPat GhcPs
nlLitPat (XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim GhcPs
SourceText
NoSourceText (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger Arity
tag))]
      where
        tag :: Arity
tag = DataCon -> Arity
dataConTag DataCon
dc

        ------------ toConstr
    toCon_bind :: [RdrName] -> LHsBind GhcPs
toCon_bind [RdrName]
dataC_RDRs
      = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
1 SrcSpan
loc RdrName
toConstr_RDR LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id
            ((DataCon
 -> RdrName
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs)))
-> [DataCon]
-> [RdrName]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     LocatedA (HsExpr GhcPs))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith DataCon
-> RdrName
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
forall (p :: Pass) a.
(IsPass p, Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a)) =>
DataCon
-> IdGhcP p
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
to_con_eqn [DataCon]
data_cons [RdrName]
dataC_RDRs)
    to_con_eqn :: DataCon
-> IdGhcP p
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)],
    GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
to_con_eqn DataCon
dc IdGhcP p
con_name = ([DataCon -> LPat GhcPs
nlWildConPat DataCon
dc], IdP (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdGhcP p
IdP (GhcPass p)
con_name)

        ------------ dataTypeOf
    dataTypeOf_bind :: RdrName -> LHsBind GhcPs
dataTypeOf_bind RdrName
dataT_RDR
      = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind
          SrcSpan
loc
          RdrName
dataTypeOf_RDR
          [LPat GhcPs
nlWildPat]
          (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
dataT_RDR)

        ------------ 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 :: Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
gcast_binds | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqKind` Type
kind1 = RdrName
-> RdrName -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
mk_gcast RdrName
dataCast1_RDR RdrName
gcast1_RDR
                | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqKind` Type
kind2 = RdrName
-> RdrName -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
mk_gcast RdrName
dataCast2_RDR RdrName
gcast2_RDR
                | Bool
otherwise                 = Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. Bag a
emptyBag
    mk_gcast :: RdrName
-> RdrName -> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
mk_gcast RdrName
dataCast_RDR RdrName
gcast_RDR
      = GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag (SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
dataCast_RDR [IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
f_RDR]
                                 (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
gcast_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
f_RDR))


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

gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_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   , neInt_RDR ,
    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,
    eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
    eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,
    eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_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,
    eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR,
    eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_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,
    word8ToWord_RDR , int8ToInt_RDR ,
    word16ToWord_RDR, int16ToInt_RDR,
    word32ToWord_RDR, int32ToInt_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")
mkConstrTag_RDR :: RdrName
mkConstrTag_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"mkConstrTag")
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
"==#")
neInt_RDR :: RdrName
neInt_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#")

eqInt32_RDR :: RdrName
eqInt32_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt32#")
ltInt32_RDR :: RdrName
ltInt32_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt32#" )
leInt32_RDR :: RdrName
leInt32_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leInt32#")
gtInt32_RDR :: RdrName
gtInt32_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt32#" )
geInt32_RDR :: RdrName
geInt32_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geInt32#")

eqInt64_RDR :: RdrName
eqInt64_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt64#")
ltInt64_RDR :: RdrName
ltInt64_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt64#" )
leInt64_RDR :: RdrName
leInt64_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leInt64#")
gtInt64_RDR :: RdrName
gtInt64_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt64#" )
geInt64_RDR :: RdrName
geInt64_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geInt64#")

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

eqWord32_RDR :: RdrName
eqWord32_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord32#")
ltWord32_RDR :: RdrName
ltWord32_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord32#" )
leWord32_RDR :: RdrName
leWord32_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leWord32#")
gtWord32_RDR :: RdrName
gtWord32_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord32#" )
geWord32_RDR :: RdrName
geWord32_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geWord32#")

eqWord64_RDR :: RdrName
eqWord64_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord64#")
ltWord64_RDR :: RdrName
ltWord64_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord64#" )
leWord64_RDR :: RdrName
leWord64_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"leWord64#")
gtWord64_RDR :: RdrName
gtWord64_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord64#" )
geWord64_RDR :: RdrName
geWord64_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"geWord64#")

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
">=##")

word8ToWord_RDR :: RdrName
word8ToWord_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"word8ToWord#")
int8ToInt_RDR :: RdrName
int8ToInt_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"int8ToInt#")

word16ToWord_RDR :: RdrName
word16ToWord_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"word16ToWord#")
int16ToInt_RDR :: RdrName
int16ToInt_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"int16ToInt#")

word32ToWord_RDR :: RdrName
word32ToWord_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"word32ToWord#")
int32ToInt_RDR :: RdrName
int32ToInt_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_PRIM (String -> FastString
fsLit String
"int32ToInt#")

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

Example:

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

    ==>

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

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

Note that we use explicit splices here in order to not trigger the implicit
lifting warning in derived code. (See #20688)
-}


gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Lift_binds SrcSpan
loc (DerivInstTys{ dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon
                                , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
tycon_args }) =
  ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
lift_bind, LHsBind GhcPs
GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
liftTyped_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    lift_bind :: LHsBind GhcPs
lift_bind      = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
1 SrcSpan
loc RdrName
lift_RDR (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
pure_Expr)
                                 ((DataCon
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs)))
-> [DataCon]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     LocatedA (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map ((LocatedA (HsExpr GhcPs) -> HsExpr GhcPs)
-> (RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs)
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
forall a an.
(LocatedA (HsExpr GhcPs) -> a)
-> (RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs)
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedAn an a)
pats_etc LHsExpr GhcPs -> HsExpr GhcPs
LocatedA (HsExpr GhcPs) -> HsExpr GhcPs
mk_untyped_bracket IdP GhcPs -> LHsExpr GhcPs -> HsSplice GhcPs
RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs
mk_usplice Name
liftName) [DataCon]
data_cons)
    liftTyped_bind :: LHsBind GhcPs
liftTyped_bind = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
1 SrcSpan
loc RdrName
liftTyped_RDR (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
unsafeCodeCoerce_Expr (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
pure_Expr)
                                 ((DataCon
 -> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs)))
-> [DataCon]
-> [([GenLocated SrcSpanAnnA (Pat GhcPs)],
     LocatedA (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map ((LocatedA (HsExpr GhcPs) -> HsExpr GhcPs)
-> (RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs)
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))
forall a an.
(LocatedA (HsExpr GhcPs) -> a)
-> (RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs)
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedAn an a)
pats_etc LHsExpr GhcPs -> HsExpr GhcPs
LocatedA (HsExpr GhcPs) -> HsExpr GhcPs
mk_typed_bracket IdP GhcPs -> LHsExpr GhcPs -> HsSplice GhcPs
RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs
mk_tsplice Name
liftTypedName) [DataCon]
data_cons)

    mk_untyped_bracket :: LHsExpr GhcPs -> HsExpr GhcPs
mk_untyped_bracket = XUntypedBracket GhcPs -> HsQuote GhcPs -> HsExpr GhcPs
forall p. XUntypedBracket p -> HsQuote p -> HsExpr p
HsUntypedBracket XUntypedBracket GhcPs
forall a. EpAnn a
noAnn (HsQuote GhcPs -> HsExpr GhcPs)
-> (LHsExpr GhcPs -> HsQuote GhcPs)
-> LHsExpr GhcPs
-> HsExpr GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XExpBr GhcPs -> LHsExpr GhcPs -> HsQuote GhcPs
forall p. XExpBr p -> LHsExpr p -> HsQuote p
ExpBr NoExtField
XExpBr GhcPs
noExtField
    mk_typed_bracket :: LHsExpr GhcPs -> HsExpr GhcPs
mk_typed_bracket = XTypedBracket GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
forall p. XTypedBracket p -> LHsExpr p -> HsExpr p
HsTypedBracket XTypedBracket GhcPs
forall a. EpAnn a
noAnn

    mk_usplice :: IdP GhcPs -> LHsExpr GhcPs -> HsSplice GhcPs
mk_usplice = XUntypedSplice GhcPs
-> SpliceDecoration -> IdP GhcPs -> LHsExpr GhcPs -> HsSplice GhcPs
forall id.
XUntypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsUntypedSplice XUntypedSplice GhcPs
forall a. EpAnn a
EpAnnNotUsed SpliceDecoration
DollarSplice
    mk_tsplice :: IdP GhcPs -> LHsExpr GhcPs -> HsSplice GhcPs
mk_tsplice = XTypedSplice GhcPs
-> SpliceDecoration -> IdP GhcPs -> LHsExpr GhcPs -> HsSplice GhcPs
forall id.
XTypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsTypedSplice XTypedSplice GhcPs
forall a. EpAnn a
EpAnnNotUsed SpliceDecoration
DollarSplice
    data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args

    pats_etc :: (LocatedA (HsExpr GhcPs) -> a)
-> (RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs)
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedAn an a)
pats_etc LocatedA (HsExpr GhcPs) -> a
mk_bracket RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs
mk_splice Name
lift_name DataCon
data_con
      = ([LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
con_pat], LocatedAn an a
lift_Expr)
       where
            con_pat :: LPat GhcPs
con_pat      = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
            data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
            con_arity :: Arity
con_arity    = DataCon -> Arity
dataConSourceArity DataCon
data_con
            as_needed :: [RdrName]
as_needed    = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
as_RDRs
            lift_Expr :: LocatedAn an a
lift_Expr    = a -> LocatedAn an a
forall a an. a -> LocatedAn an a
noLocA (LocatedA (HsExpr GhcPs) -> a
mk_bracket LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
br_body)
            br_body :: LHsExpr GhcPs
br_body      = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps (Name -> RdrName
Exact (DataCon -> Name
dataConName DataCon
data_con))
                                    ((RdrName -> LocatedA (HsExpr GhcPs))
-> [RdrName] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> LHsExpr GhcPs
RdrName -> LocatedA (HsExpr GhcPs)
lift_var [RdrName]
as_needed)

            lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
            lift_var :: RdrName -> LHsExpr GhcPs
lift_var RdrName
x   = HsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XSpliceE GhcPs -> HsSplice GhcPs -> HsExpr GhcPs
forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE XSpliceE GhcPs
forall a. EpAnn a
EpAnnNotUsed (RdrName -> LocatedA (HsExpr GhcPs) -> HsSplice GhcPs
mk_splice RdrName
x (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (RdrName -> LHsExpr GhcPs
mk_lift_expr RdrName
x))))

            mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)
            mk_lift_expr :: RdrName -> LHsExpr GhcPs
mk_lift_expr RdrName
x = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps (Name -> RdrName
Exact Name
lift_name) [IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
x]

{-
************************************************************************
*                                                                      *
                     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. We have to instantiate
both type args of (coerce :: Coercible a b => a -> b) to polytypes,
and we can only do that with VTA or Quick Look. Here VTA seems more
appropriate for machine generated code: it's simple and robust.

However, to allow VTA with polytypes we must switch on
-XImpredicativeTypes 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 we still need to instantiate the second argument of
coerce with a polytype, and we can only do that with VTA or QuickLook.

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.

-----
-- Wrinkle: Use HsOuterExplicit
-----

One minor complication with the plan above is that we need to ensure that the
type variables from a method's instance signature properly scope over the body
of the method. For example, recall:

  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

In the example above, it is imperative that the `a` in the instance signature
for `join` scope over the body of `join` by way of ScopedTypeVariables.
This might sound obvious, but note that in gen_Newtype_binds, which is
responsible for generating the code above, the type in `join`'s instance
signature is given as a Core type, whereas gen_Newtype_binds will eventually
produce HsBinds (i.e., source Haskell) that is renamed and typechecked. We
must ensure that `a` is in scope over the body of `join` during renaming
or else the generated code will be rejected.

In short, we need to convert the instance signature from a Core type to an
HsType (i.e., a source Haskell type). Two possible options are:

1. Convert the Core type entirely to an HsType (i.e., a source Haskell type).
2. Embed the entire Core type using HsCoreTy.

Neither option is quite satisfactory:

1. Converting a Core type to an HsType in full generality is surprisingly
   complicated. Previous versions of GHCs did this, but it was the source of
   numerous bugs (see #14579 and #16518, for instance).
2. While HsCoreTy is much less complicated that option (1), it's not quite
   what we want. In order for `a` to be in scope over the body of `join` during
   renaming, the `forall` must be contained in an HsOuterExplicit.
   (See Note [Lexically scoped type variables] in GHC.Hs.Type.) HsCoreTy
   bypasses HsOuterExplicit, so this won't work either.

As a compromise, we adopt a combination of the two options above:

* Split apart the top-level ForAllTys in the instance signature's Core type,
* Convert the top-level ForAllTys to an HsOuterExplicit, and
* Embed the remainder of the Core type in an HsCoreTy.

This retains most of the simplicity of option (2) while still ensuring that
the type variables are correctly scoped.

Note that splitting apart top-level ForAllTys will expand any type synonyms
in the Core type itself. This ends up being important to fix a corner case
observed in #18914. Consider this example:

  type T f = forall a. f a

  class C f where
    m :: T f

  newtype N f a = MkN (f a)
    deriving C

What code should `deriving C` generate? It will have roughly the following
shape:

  instance C f => C (N f) where
    m :: T (N f)
    m = coerce @(...) (...) (m @f)

At a minimum, we must instantiate `coerce` with `@(T f)` and `@(T (N f))`, but
with the `forall`s removed in order to make them monotypes. However, the
`forall` is hidden underneath the `T` type synonym, so we must first expand `T`
before we can strip of the `forall`. Expanding `T`, we get
`coerce @(forall a. f a) @(forall a. N f a)`, and after omitting the `forall`s,
we get `coerce @(f a) @(N f a)`.

We can't stop there, however, or else we would end up with this code:

  instance C f => C (N f) where
    m :: T (N f)
    m = coerce @(f a) @(N f a) (m @f)

Notice that the type variable `a` is completely unbound. In order to make sure
that `a` is in scope, we must /also/ expand the `T` in `m :: T (N f)` to get
`m :: forall a. N f a`. Fortunately, we will do just that in the plan outlined
above, since when we split off the top-level ForAllTys in the instance
signature, we must first expand the T type synonym.

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
                  -> (LHsBinds GhcPs, [LSig GhcPs])
-- See Note [Newtype-deriving instances]
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> (LHsBinds GhcPs, [LSig GhcPs])
gen_Newtype_binds SrcSpan
loc' Class
cls [TyVar]
inst_tvs [Type]
inst_tys Type
rhs_ty
  = ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
-> Bag (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds, [LSig GhcPs]
[GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs)
  where
    ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)]
binds, [GenLocated SrcSpanAnnA (Sig GhcPs)]
sigs) = (TyVar
 -> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
     GenLocated SrcSpanAnnA (Sig GhcPs)))
-> [TyVar]
-> ([GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)],
    [GenLocated SrcSpanAnnA (Sig GhcPs)])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip TyVar -> (LHsBind GhcPs, LSig GhcPs)
TyVar
-> (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
    GenLocated SrcSpanAnnA (Sig GhcPs))
mk_bind_and_sig (Class -> [TyVar]
classMethods Class
cls)

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

    locn :: SrcSpanAnn' (EpAnn NameAnn)
locn = SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
    loca :: SrcSpanAnnA
loca = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
    -- 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 :: TyVar -> (LHsBind GhcPs, LSig GhcPs)
mk_bind_and_sig TyVar
meth_id
      = ( -- The derived binding, e.g.,
          --
          --   op = coerce @(a -> [<rep-ty>] -> c -> Int)
          --               @(a -> [T x]      -> c -> Int)
          --               op
          LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind LocatedAn NameAnn RdrName
loc_meth_RDR [HsMatchContext GhcPs
-> [LPat GhcPs]
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
                                        (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcPs
LocatedAn NameAnn RdrName
loc_meth_RDR)
                                        [] LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
rhs_expr]
        , -- The derived instance signature, e.g.,
          --
          --   op :: forall c. a -> [T x] -> c -> Int
          --
          -- Make sure that `forall c` is in an HsOuterExplicit so that it
          -- scopes over the body of `op`. See "Wrinkle: Use HsOuterExplicit" in
          -- Note [GND and QuantifiedConstraints].
          SrcSpanAnnA -> Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs))
-> Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$ XClassOpSig GhcPs
-> Bool -> [LIdP GhcPs] -> LHsSigType GhcPs -> Sig GhcPs
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig GhcPs
forall a. EpAnn a
noAnn Bool
False [LIdP GhcPs
LocatedAn NameAnn RdrName
loc_meth_RDR]
                 (LHsSigType GhcPs -> Sig GhcPs) -> LHsSigType GhcPs -> Sig GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ EpAnnForallTy
-> [LHsTyVarBndr Specificity GhcPs]
-> LHsType GhcPs
-> HsSigType GhcPs
mkHsExplicitSigType EpAnnForallTy
forall a. EpAnn a
noAnn
                              ((VarBndr TyVar Specificity
 -> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs))
-> [VarBndr TyVar Specificity]
-> [GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map VarBndr TyVar Specificity
-> GenLocated SrcSpanAnnA (HsTyVarBndr Specificity GhcPs)
forall flag. VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb [VarBndr TyVar Specificity]
to_tvbs)
                              (Type -> LHsType GhcPs
nlHsCoreTy Type
to_rho)
        )
      where
        Pair Type
from_ty Type
to_ty = Class -> [TyVar] -> [Type] -> Type -> TyVar -> Pair Type
mkCoerceClassMethEqn Class
cls [TyVar]
inst_tvs [Type]
inst_tys Type
rhs_ty TyVar
meth_id
        ([TyVar]
_, [Type]
_, Type
from_tau)  = Type -> ([TyVar], [Type], Type)
tcSplitSigmaTy Type
from_ty
        ([VarBndr TyVar Specificity]
to_tvbs, Type
to_rho) = Type -> ([VarBndr TyVar Specificity], Type)
tcSplitForAllInvisTVBinders Type
to_ty
        ([Type]
_, Type
to_tau)       = Type -> ([Type], Type)
tcSplitPhiTy Type
to_rho
        -- The use of tcSplitForAllInvisTVBinders above expands type synonyms,
        -- which is important to ensure correct type variable scoping.
        -- See "Wrinkle: Use HsOuterExplicit" in
        -- Note [GND and QuantifiedConstraints].

        mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
        mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb (Bndr TyVar
tv flag
flag) = HsTyVarBndr flag GhcPs
-> LocatedAn AnnListItem (HsTyVarBndr flag GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsTyVarBndr flag GhcPs
 -> LocatedAn AnnListItem (HsTyVarBndr flag GhcPs))
-> HsTyVarBndr flag GhcPs
-> LocatedAn AnnListItem (HsTyVarBndr flag GhcPs)
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcPs
-> flag -> LIdP GhcPs -> LHsType GhcPs -> HsTyVarBndr flag GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar GhcPs
forall a. EpAnn a
noAnn
                                                        flag
flag
                                                        (RdrName -> LocatedAn NameAnn RdrName
forall a an. a -> LocatedAn an a
noLocA (TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyVar
tv))
                                                        (Type -> LHsType GhcPs
nlHsCoreTy (TyVar -> Type
tyVarKind TyVar
tv))

        meth_RDR :: RdrName
meth_RDR = TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyVar
meth_id
        loc_meth_RDR :: LocatedAn NameAnn RdrName
loc_meth_RDR = SrcSpanAnn' (EpAnn NameAnn) -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn RdrName
meth_RDR

        rhs_expr :: LHsExpr GhcPs
rhs_expr = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyVar
coerceId)
                                      LHsExpr GhcPs -> Type -> LHsExpr GhcPs
`nlHsAppType`     Type
from_tau
                                      LHsExpr GhcPs -> Type -> LHsExpr GhcPs
`nlHsAppType`     Type
to_tau
                                      LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp`         LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
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 :: LocatedA (HsExpr GhcPs)
meth_app = (LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs) -> [Type] -> LocatedA (HsExpr GhcPs)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr GhcPs -> Type -> LHsExpr GhcPs
LocatedA (HsExpr GhcPs) -> Type -> LocatedA (HsExpr GhcPs)
nlHsAppType (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
meth_RDR) ([Type] -> LocatedA (HsExpr GhcPs))
-> [Type] -> LocatedA (HsExpr GhcPs)
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.

gen_Newtype_fam_insts :: 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 [FamInst]
-- See Note [GND and associated type families] in GHC.Tc.Deriv
gen_Newtype_fam_insts :: SrcSpan -> Class -> [TyVar] -> [Type] -> Type -> TcM [FamInst]
gen_Newtype_fam_insts SrcSpan
loc' Class
cls [TyVar]
inst_tvs [Type]
inst_tys Type
rhs_ty
  = Bool -> TcM [FamInst] -> TcM [FamInst]
forall a. HasCallStack => Bool -> a -> a
assert ((TyCon -> Bool) -> [TyCon] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool) -> (TyCon -> Bool) -> TyCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Bool
isDataFamilyTyCon) [TyCon]
ats) (TcM [FamInst] -> TcM [FamInst]) -> TcM [FamInst] -> TcM [FamInst]
forall a b. (a -> b) -> a -> b
$
    (TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst)
-> [TyCon] -> TcM [FamInst]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst
mk_atf_inst [TyCon]
ats
  where
    -- 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

    ats :: [TyCon]
ats       = Class -> [TyCon]
classATs Class
cls
    locn :: SrcSpanAnn' (EpAnn NameAnn)
locn      = SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
    cls_tvs :: [TyVar]
cls_tvs   = Class -> [TyVar]
classTyVars Class
cls
    in_scope :: InScopeSet
in_scope  = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TyVar] -> VarSet
mkVarSet [TyVar]
inst_tvs
    lhs_env :: TvSubstEnv
lhs_env   = [TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
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   = [TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
cls_tvs [Type]
underlying_inst_tys
    rhs_subst :: TCvSubst
rhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
rhs_env

    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 <- LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (SrcSpanAnn' (EpAnn NameAnn) -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn (TyCon -> Name
tyConName TyCon
fam_tc))
                                           [Type]
rep_lhs_tys
        let axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_tc_name [TyVar]
rep_tvs' [] [TyVar]
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
        fam_tvs :: [TyVar]
fam_tvs     = TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc
        rep_lhs_tys :: [Type]
rep_lhs_tys = TCvSubst -> [TyVar] -> [Type]
substTyVars TCvSubst
lhs_subst [TyVar]
fam_tvs
        rep_rhs_tys :: [Type]
rep_rhs_tys = TCvSubst -> [TyVar] -> [Type]
substTyVars TCvSubst
rhs_subst [TyVar]
fam_tvs
        rep_rhs_ty :: Type
rep_rhs_ty  = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
rep_rhs_tys
        rep_tcvs :: [TyVar]
rep_tcvs    = [Type] -> [TyVar]
tyCoVarsOfTypesList [Type]
rep_lhs_tys
        ([TyVar]
rep_tvs, [TyVar]
rep_cvs) = (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyVar -> Bool
isTyVar [TyVar]
rep_tcvs
        rep_tvs' :: [TyVar]
rep_tvs'    = [TyVar] -> [TyVar]
scopedSort [TyVar]
rep_tvs
        rep_cvs' :: [TyVar]
rep_cvs'    = [TyVar] -> [TyVar]
scopedSort [TyVar]
rep_cvs

nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType LHsExpr GhcPs
e Type
s = HsExpr GhcPs -> LocatedA (HsExpr GhcPs)
forall a an. a -> LocatedAn an a
noLocA (XAppTypeE GhcPs
-> LHsExpr GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE GhcPs
SrcSpan
noSrcSpan LHsExpr GhcPs
e HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
LHsWcType (NoGhcTc GhcPs)
hs_ty)
  where
    hs_ty :: HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
hs_ty = GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$ PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ Type -> LHsType GhcPs
nlHsCoreTy Type
s

nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
nlHsCoreTy :: Type -> LHsType GhcPs
nlHsCoreTy = HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a an. a -> LocatedAn an a
noLocA (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> (Type -> HsType GhcPs)
-> Type
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType

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 -> [TyVar] -> [Type] -> Type -> TyVar -> Pair Type
mkCoerceClassMethEqn Class
cls [TyVar]
inst_tvs [Type]
inst_tys Type
rhs_ty TyVar
id
  = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair (HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
rhs_subst Type
user_meth_ty)
         (HasDebugCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
lhs_subst Type
user_meth_ty)
  where
    cls_tvs :: [TyVar]
cls_tvs = Class -> [TyVar]
classTyVars Class
cls
    in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TyVar] -> VarSet
mkVarSet [TyVar]
inst_tvs
    lhs_subst :: TCvSubst
lhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope ([TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
cls_tvs [Type]
inst_tys)
    rhs_subst :: TCvSubst
rhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope ([TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
cls_tvs ([Type] -> Type -> [Type]
forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty))
    ([TyVar]
_class_tvs, Type
_class_constraint, Type
user_meth_ty)
      = Type -> ([TyVar], Type, Type)
tcSplitMethodTy (TyVar -> Type
varType TyVar
id)

{-
************************************************************************
*                                                                      *
\subsection{Generating extra binds (@tag2con@, etc.)}
*                                                                      *
************************************************************************

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

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

-- | Generate the full code for an auxiliary binding.
-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
                       -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal DynFlags
dflags SrcSpan
loc AuxBindSpec
spec
  = (AuxBindSpec -> LHsBind GhcPs
gen_bind AuxBindSpec
spec,
     SrcSpanAnnA -> Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (XTypeSig GhcPs -> [LIdP GhcPs] -> LHsSigWcType GhcPs -> Sig GhcPs
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcPs
forall a. EpAnn a
noAnn [SrcSpanAnn' (EpAnn NameAnn) -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn (AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
spec)]
           (SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
spec)))
  where
    loca :: SrcSpanAnnA
loca = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
    locn :: SrcSpanAnn' (EpAnn NameAnn)
locn = SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
    gen_bind :: AuxBindSpec -> LHsBind GhcPs
    gen_bind :: AuxBindSpec -> LHsBind GhcPs
gen_bind (DerivTag2Con TyCon
_ RdrName
tag2con_RDR)
      = Arity
-> SrcSpan
-> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE Arity
0 SrcSpan
loc RdrName
tag2con_RDR
           [([RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
intDataCon_RDR [RdrName
a_RDR]],
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
tagToEnum_RDR) LHsExpr GhcPs
a_Expr)]

    gen_bind (DerivMaxTag TyCon
tycon RdrName
maxtag_RDR)
      = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
maxtag_RDR LHsExpr GhcPs
rhs
      where
        rhs :: LHsExpr GhcPs
rhs = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
intDataCon_RDR)
                      (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim GhcPs
SourceText
NoSourceText Integer
max_tag))
        max_tag :: Integer
max_tag =  case (TyCon -> [DataCon]
tyConDataCons TyCon
tycon) of
                     [DataCon]
data_cons -> Arity -> Integer
forall a. Integral a => a -> Integer
toInteger (([DataCon] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [DataCon]
data_cons) Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
fIRST_TAG)

    gen_bind (DerivDataDataType TyCon
tycon RdrName
dataT_RDR [RdrName]
dataC_RDRs)
      = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
dataT_RDR LHsExpr GhcPs
rhs
      where
        tc_name :: Name
tc_name = TyCon -> Name
tyConName TyCon
tycon
        tc_name_string :: String
tc_name_string = OccName -> String
occNameString (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
tc_name)
        definition_mod_name :: String
definition_mod_name = ModuleName -> String
moduleNameString (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (String -> Maybe Module -> Module
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"gen_bind DerivDataDataType" (Maybe Module -> Module) -> Maybe Module -> Module
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
tc_name))
        ctx :: SDocContext
ctx = DynFlags -> SDocContext
initDefaultSDocContext DynFlags
dflags
        rhs :: LHsExpr GhcPs
rhs = IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
mkDataType_RDR
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (String -> SDoc
text String
definition_mod_name SDoc -> SDoc -> SDoc
<> SDoc
dot SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
tc_name_string)))
              LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` [LHsExpr GhcPs] -> LHsExpr GhcPs
nlList ((RdrName -> LocatedA (HsExpr GhcPs))
-> [RdrName] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> LocatedA (HsExpr GhcPs)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar [RdrName]
dataC_RDRs)

    gen_bind (DerivDataConstr DataCon
dc RdrName
dataC_RDR RdrName
dataT_RDR)
      = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
dataC_RDR LHsExpr GhcPs
rhs
      where
        rhs :: LHsExpr GhcPs
rhs = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP GhcPs
RdrName
mkConstrTag_RDR [LHsExpr GhcPs]
[LocatedA (HsExpr GhcPs)]
constr_args

        constr_args :: [LocatedA (HsExpr GhcPs)]
constr_args
           = [ IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
dataT_RDR                            -- DataType
             , HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (OccName -> String
occNameString OccName
dc_occ))  -- Constructor name
             , Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger (DataCon -> Arity
dataConTag DataCon
dc))       -- Constructor tag
             , [LHsExpr GhcPs] -> LHsExpr GhcPs
nlList  [LHsExpr GhcPs]
[LocatedA (HsExpr GhcPs)]
labels                               -- Field labels
             , IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
fixity ]                             -- Fixity

        labels :: [LocatedA (HsExpr GhcPs)]
labels   = (FieldLabel -> LocatedA (HsExpr GhcPs))
-> [FieldLabel] -> [LocatedA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (HsLit GhcPs -> LocatedA (HsExpr GhcPs)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (HsLit GhcPs -> LocatedA (HsExpr GhcPs))
-> (FieldLabel -> HsLit GhcPs)
-> FieldLabel
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String -> HsLit GhcPs)
-> (FieldLabel -> String) -> FieldLabel -> HsLit GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS (FastString -> String)
-> (FieldLabel -> FastString) -> FieldLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FastString
flLabel)
                       (DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
        dc_occ :: OccName
dc_occ   = DataCon -> OccName
forall a. NamedThing a => a -> OccName
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

-- | Generate the code for an auxiliary binding that is a duplicate of another
-- auxiliary binding.
-- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
                  -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup SrcSpan
loc RdrName
original_rdr_name AuxBindSpec
dup_spec
  = (SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
dup_rdr_name (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
original_rdr_name),
     SrcSpanAnnA -> Sig GhcPs -> GenLocated SrcSpanAnnA (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (XTypeSig GhcPs -> [LIdP GhcPs] -> LHsSigWcType GhcPs -> Sig GhcPs
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig GhcPs
forall a. EpAnn a
noAnn [SrcSpanAnn' (EpAnn NameAnn) -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn RdrName
dup_rdr_name]
           (SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
dup_spec)))
  where
    loca :: SrcSpanAnnA
loca = SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
    locn :: SrcSpanAnn' (EpAnn NameAnn)
locn = SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
    dup_rdr_name :: RdrName
dup_rdr_name = AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
dup_spec

-- | Generate the type signature of an auxiliary binding.
-- See @Note [Auxiliary binders]@.
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
spec = case AuxBindSpec
spec of
  DerivTag2Con TyCon
tycon RdrName
_
    -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
mk_sig (GenLocated SrcSpanAnnA (HsType GhcPs)
 -> HsWildCardBndrs
      GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$
       XXType GhcPs -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType (XXType GhcPs -> HsType GhcPs) -> XXType GhcPs -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ [TyVar] -> Type -> Type
mkSpecForAllTys (TyCon -> [TyVar]
tyConTyVars TyCon
tycon) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
       Type
intTy Type -> Type -> Type
`mkVisFunTyMany` TyCon -> Type
mkParentType TyCon
tycon
  DerivMaxTag TyCon
_ RdrName
_
    -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
mk_sig (SrcSpanAnnA
-> HsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (XXType GhcPs -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType XXType GhcPs
Type
intTy))
  DerivDataDataType TyCon
_ RdrName
_ [RdrName]
_
    -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
mk_sig (IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar IdP GhcPs
RdrName
dataType_RDR)
  DerivDataConstr DataCon
_ RdrName
_ RdrName
_
    -> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
mk_sig (IdP GhcPs -> LHsType GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar IdP GhcPs
RdrName
constr_RDR)
  where
    mk_sig :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
mk_sig = GenLocated SrcSpanAnnA (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (GenLocated SrcSpanAnnA (HsSigType GhcPs)
 -> HsWildCardBndrs
      GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs)))
-> (GenLocated SrcSpanAnnA (HsType GhcPs)
    -> GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsWildCardBndrs GhcPs (GenLocated SrcSpanAnnA (HsSigType GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpanAnnA
-> HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnnA
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (HsSigType GhcPs -> GenLocated SrcSpanAnnA (HsSigType GhcPs))
-> (GenLocated SrcSpanAnnA (HsType GhcPs) -> HsSigType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsSigType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> HsSigType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs) -> HsSigType GhcPs
mkHsImplicitSigType

-- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary
-- bindings based on the declarative descriptions in the supplied
-- 'AuxBindSpec's. See @Note [Auxiliary binders]@.
genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec
            -> Bag (LHsBind GhcPs, LSig GhcPs)
genAuxBinds :: DynFlags
-> SrcSpan -> Bag AuxBindSpec -> Bag (LHsBind GhcPs, LSig GhcPs)
genAuxBinds DynFlags
dflags SrcSpan
loc = (OccEnv RdrName,
 Bag
   (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
    GenLocated SrcSpanAnnA (Sig GhcPs)))
-> Bag
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
      GenLocated SrcSpanAnnA (Sig GhcPs))
forall a b. (a, b) -> b
snd ((OccEnv RdrName,
  Bag
    (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
     GenLocated SrcSpanAnnA (Sig GhcPs)))
 -> Bag
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
       GenLocated SrcSpanAnnA (Sig GhcPs)))
-> (Bag AuxBindSpec
    -> (OccEnv RdrName,
        Bag
          (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
           GenLocated SrcSpanAnnA (Sig GhcPs))))
-> Bag AuxBindSpec
-> Bag
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
      GenLocated SrcSpanAnnA (Sig GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuxBindSpec
 -> (OccEnv RdrName,
     Bag
       (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
        GenLocated SrcSpanAnnA (Sig GhcPs)))
 -> (OccEnv RdrName,
     Bag
       (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
        GenLocated SrcSpanAnnA (Sig GhcPs))))
-> (OccEnv RdrName,
    Bag
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
       GenLocated SrcSpanAnnA (Sig GhcPs)))
-> Bag AuxBindSpec
-> (OccEnv RdrName,
    Bag
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
       GenLocated SrcSpanAnnA (Sig GhcPs)))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
AuxBindSpec
-> (OccEnv RdrName,
    Bag
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
       GenLocated SrcSpanAnnA (Sig GhcPs)))
-> (OccEnv RdrName,
    Bag
      (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
       GenLocated SrcSpanAnnA (Sig GhcPs)))
gen_aux_bind_spec (OccEnv RdrName
forall a. OccEnv a
emptyOccEnv, Bag
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
   GenLocated SrcSpanAnnA (Sig GhcPs))
forall a. Bag a
emptyBag)
 where
  -- Perform a CSE-like pass over the generated auxiliary bindings to avoid
  -- code duplication, as described in
  -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).
  -- The OccEnv remembers the first occurrence of each sort of auxiliary
  -- binding and maps it to the unique RdrName for that binding.
  gen_aux_bind_spec :: AuxBindSpec
                    -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
                    -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
  gen_aux_bind_spec :: AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
gen_aux_bind_spec AuxBindSpec
spec (OccEnv RdrName
original_rdr_name_env, Bag (LHsBind GhcPs, LSig GhcPs)
spec_bag) =
    case OccEnv RdrName -> OccName -> Maybe RdrName
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv RdrName
original_rdr_name_env OccName
spec_occ of
      Maybe RdrName
Nothing
        -> ( OccEnv RdrName -> OccName -> RdrName -> OccEnv RdrName
forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv RdrName
original_rdr_name_env OccName
spec_occ RdrName
spec_rdr_name
           , DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal DynFlags
dflags SrcSpan
loc AuxBindSpec
spec (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
 GenLocated SrcSpanAnnA (Sig GhcPs))
-> Bag
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
      GenLocated SrcSpanAnnA (Sig GhcPs))
-> Bag
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
      GenLocated SrcSpanAnnA (Sig GhcPs))
forall a. a -> Bag a -> Bag a
`consBag` Bag (LHsBind GhcPs, LSig GhcPs)
Bag
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
   GenLocated SrcSpanAnnA (Sig GhcPs))
spec_bag )
      Just RdrName
original_rdr_name
        -> ( OccEnv RdrName
original_rdr_name_env
           , SrcSpan -> RdrName -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup SrcSpan
loc RdrName
original_rdr_name AuxBindSpec
spec (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
 GenLocated SrcSpanAnnA (Sig GhcPs))
-> Bag
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
      GenLocated SrcSpanAnnA (Sig GhcPs))
-> Bag
     (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
      GenLocated SrcSpanAnnA (Sig GhcPs))
forall a. a -> Bag a -> Bag a
`consBag` Bag (LHsBind GhcPs, LSig GhcPs)
Bag
  (GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs),
   GenLocated SrcSpanAnnA (Sig GhcPs))
spec_bag )
    where
      spec_rdr_name :: RdrName
spec_rdr_name = AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
spec
      spec_occ :: OccName
spec_occ      = RdrName -> OccName
rdrNameOcc RdrName
spec_rdr_name

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 ([TyVar] -> [Type]
mkTyVarTys (TyCon -> [TyVar]
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 :: Arity
-> SrcSpan
-> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE Arity
arity SrcSpan
loc RdrName
fun [([LPat GhcPs], LHsExpr GhcPs)]
pats_and_exprs
  = Arity
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindSE Arity
arity (SrcSpanAnn' (EpAnn NameAnn) -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun) [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches
  where
    matches :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches = [HsMatchContext GhcPs
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> HsLocalBinds GhcPs
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnn' (EpAnn NameAnn) -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun))
                               ((GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [GenLocated SrcSpanAnnA (Pat GhcPs)]
p) LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
e
                               HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
              | ([GenLocated SrcSpanAnnA (Pat GhcPs)]
p,LocatedA (HsExpr GhcPs)
e) <-[([LPat GhcPs], LHsExpr GhcPs)]
[([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))]
pats_and_exprs]

mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> LHsBind GhcPs
mkRdrFunBind :: LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind fun :: LocatedAn NameAnn RdrName
fun@(L SrcSpanAnn' (EpAnn NameAnn)
loc RdrName
_fun_rdr) [LMatch GhcPs (LHsExpr GhcPs)]
matches
  = SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' (EpAnn NameAnn) -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnn' (EpAnn NameAnn)
loc) (Origin
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBindLR GhcPs GhcPs
mkFunBind Origin
Generated LocatedAn NameAnn RdrName
fun [LMatch GhcPs (LHsExpr GhcPs)]
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 :: Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
arity SrcSpan
loc RdrName
fun LHsExpr GhcPs -> LHsExpr GhcPs
catch_all [([LPat GhcPs], LHsExpr GhcPs)]
pats_and_exprs
  = Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
arity LHsExpr GhcPs -> LHsExpr GhcPs
catch_all (SrcSpanAnn' (EpAnn NameAnn) -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun) [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches
  where
    matches :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches = [ HsMatchContext GhcPs
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> HsLocalBinds GhcPs
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpanAnn' (EpAnn NameAnn) -> RdrName -> LocatedAn NameAnn RdrName
forall l e. l -> e -> GenLocated l e
L (SrcSpan -> SrcSpanAnn' (EpAnn NameAnn)
forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun))
                                ((GenLocated SrcSpanAnnA (Pat GhcPs)
 -> GenLocated SrcSpanAnnA (Pat GhcPs))
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [GenLocated SrcSpanAnnA (Pat GhcPs)]
p) LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
e
                                HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
              | ([GenLocated SrcSpanAnnA (Pat GhcPs)]
p,LocatedA (HsExpr GhcPs)
e) <- [([LPat GhcPs], LHsExpr GhcPs)]
[([GenLocated SrcSpanAnnA (Pat GhcPs)], LocatedA (HsExpr GhcPs))]
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)
               -> LocatedN RdrName
               -> [LMatch GhcPs (LHsExpr GhcPs)]
               -> LHsBind GhcPs
mkRdrFunBindEC :: Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
arity LHsExpr GhcPs -> LHsExpr GhcPs
catch_all fun :: LocatedAn NameAnn RdrName
fun@(L SrcSpanAnn' (EpAnn NameAnn)
loc RdrName
_fun_rdr) [LMatch GhcPs (LHsExpr GhcPs)]
matches
  = SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' (EpAnn NameAnn) -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnn' (EpAnn NameAnn)
loc) (Origin
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBindLR GhcPs GhcPs
mkFunBind Origin
Generated LocatedAn NameAnn RdrName
fun [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
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' :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches' = if [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches
              then [HsMatchContext GhcPs
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> HsLocalBinds GhcPs
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcPs
LocatedAn NameAnn RdrName
fun)
                            (Arity
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. Arity -> a -> [a]
replicate (Arity
arity Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1) LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
nlWildPat [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
z_Pat])
                            (LHsExpr GhcPs -> LHsExpr GhcPs
catch_all (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
z_Expr [])
                            HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds]
              else [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
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 -> LocatedN RdrName ->
                    [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE :: Arity
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindSE Arity
arity fun :: LocatedAn NameAnn RdrName
fun@(L SrcSpanAnn' (EpAnn NameAnn)
loc RdrName
fun_rdr) [LMatch GhcPs (LHsExpr GhcPs)]
matches
  = SrcSpanAnnA
-> HsBindLR GhcPs GhcPs
-> GenLocated SrcSpanAnnA (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnn' (EpAnn NameAnn) -> SrcSpanAnnA
forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnn' (EpAnn NameAnn)
loc) (Origin
-> LocatedAn NameAnn RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBindLR GhcPs GhcPs
mkFunBind Origin
Generated LocatedAn NameAnn RdrName
fun [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
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' :: [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches' = if [GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
-> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
matches
              then [HsMatchContext GhcPs
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> HsLocalBinds GhcPs
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs LIdP GhcPs
LocatedAn NameAnn RdrName
fun)
                            (Arity
-> GenLocated SrcSpanAnnA (Pat GhcPs)
-> [GenLocated SrcSpanAnnA (Pat GhcPs)]
forall a. Arity -> a -> [a]
replicate Arity
arity LPat GhcPs
GenLocated SrcSpanAnnA (Pat GhcPs)
nlWildPat)
                            (String -> LHsExpr GhcPs
error_Expr String
str) HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds]
              else [LMatch GhcPs (LHsExpr GhcPs)]
[GenLocated SrcSpanAnnA (Match GhcPs (LocatedA (HsExpr GhcPs)))]
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 GhcPs -> Type -> LHsExpr GhcPs
box String
cls_str LHsExpr GhcPs
arg Type
arg_ty = String
-> [(Type, LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))]
-> Type
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
cls_str [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
[(Type, LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))]
boxConTbl Type
arg_ty LHsExpr GhcPs
LocatedA (HsExpr GhcPs)
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
int32PrimTy , (RdrName
ltInt32_RDR , RdrName
leInt32_RDR
     , RdrName
eqInt32_RDR , RdrName
geInt32_RDR , RdrName
gtInt32_RDR   ))
    ,(Type
int64PrimTy , (RdrName
ltInt64_RDR , RdrName
leInt64_RDR
     , RdrName
eqInt64_RDR , RdrName
geInt64_RDR , RdrName
gtInt64_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
word32PrimTy, (RdrName
ltWord32_RDR, RdrName
leWord32_RDR
     , RdrName
eqWord32_RDR, RdrName
geWord32_RDR, RdrName
gtWord32_RDR  ))
    ,(Type
word64PrimTy, (RdrName
ltWord64_RDR, RdrName
leWord64_RDR
     , RdrName
eqWord64_RDR, RdrName
geWord64_RDR, RdrName
gtWord64_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 GhcPs -> LHsExpr GhcPs)]
boxConTbl =
    [ (Type
charPrimTy  , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
charDataCon))
    , (Type
intPrimTy   , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon))
    , (Type
wordPrimTy  , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon ))
    , (Type
floatPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
floatDataCon ))
    , (Type
doublePrimTy, LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
doubleDataCon))
    , (Type
int8PrimTy,
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
        (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
int8ToInt_RDR))
    , (Type
word8PrimTy,
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
        (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
word8ToWord_RDR))
    , (Type
int16PrimTy,
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
        (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
int16ToInt_RDR))
    , (Type
word16PrimTy,
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
        (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
word16ToWord_RDR))
    , (Type
int32PrimTy,
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
        (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
int32ToInt_RDR))
    , (Type
word32PrimTy,
        LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
        (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
word32ToWord_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
"##")
    ,(Type
int32PrimTy, String
"#")
    ,(Type
word32PrimTy, String
"##")
    ]

primConvTbl :: [(Type, String)]
primConvTbl :: [(Type, String)]
primConvTbl =
    [ (Type
int8PrimTy, String
"intToInt8#")
    , (Type
word8PrimTy, String
"wordToWord8#")
    , (Type
int16PrimTy, String
"intToInt16#")
    , (Type
word16PrimTy, String
"wordToWord16#")
    , (Type
int32PrimTy, String
"intToInt32#")
    , (Type
word32PrimTy, String
"wordToWord32#")
    ]

litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl
  = [(Type
charPrimTy  , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
charPrimL_RDR))
    ,(Type
intPrimTy   , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
intPrimL_RDR)
                      (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
toInteger_RDR))
    ,(Type
wordPrimTy  , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
wordPrimL_RDR)
                      (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
toInteger_RDR))
    ,(Type
addrPrimTy  , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
stringPrimL_RDR)
                      (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
                          (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
map_RDR)
                          (IdP GhcPs
RdrName
compose_RDR IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsApps`
                            [ IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
fromIntegral_RDR
                            , IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
fromEnum_RDR
                            ])))
    ,(Type
floatPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
floatPrimL_RDR)
                      (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
toRational_RDR))
    ,(Type
doublePrimTy, LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
doublePrimL_RDR)
                      (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> (LocatedA (HsExpr GhcPs) -> LocatedA (HsExpr GhcPs))
-> LocatedA (HsExpr GhcPs)
-> LocatedA (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
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
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
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
<$> ((Type, a) -> Bool) -> [(Type, a)] -> Maybe (Type, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
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 GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr LHsExpr GhcPs
a LHsExpr GhcPs
b = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
a RdrName
and_RDR    LHsExpr GhcPs
b

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

eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr Type
ty LHsExpr GhcPs
a LHsExpr GhcPs
b
    | Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty) = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
a RdrName
eq_RDR LHsExpr GhcPs
b
    | Bool
otherwise               = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a RdrName
prim_eq LHsExpr GhcPs
b
 where
   (RdrName
_, RdrName
_, RdrName
prim_eq, RdrName
_, RdrName
_) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Eq" Type
ty

untag_Expr :: [(RdrName, RdrName)]
           -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr :: [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [] LHsExpr GhcPs
expr = LHsExpr GhcPs
expr
untag_Expr ((RdrName
untag_this, RdrName
put_tag_here) : [(RdrName, RdrName)]
more) LHsExpr GhcPs
expr
  = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP GhcPs
RdrName
dataToTag_RDR [IdP GhcPs
RdrName
untag_this])) {-of-}
      [LPat GhcPs
-> LocatedA (HsExpr GhcPs)
-> LMatch GhcPs (LocatedA (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcAnn NoEpAnns,
 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (IdP GhcPs -> LPat GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP GhcPs
RdrName
put_tag_here) ([(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName, RdrName)]
more LHsExpr GhcPs
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 GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_to_Expr      LHsExpr GhcPs
f   LHsExpr GhcPs
t2 = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
enumFromTo_RDR) LHsExpr GhcPs
f) LHsExpr GhcPs
t2
enum_from_then_to_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_then_to_Expr LHsExpr GhcPs
f LHsExpr GhcPs
t LHsExpr GhcPs
t2 = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
enumFromThenTo_RDR) LHsExpr GhcPs
f) LHsExpr GhcPs
t) LHsExpr GhcPs
t2

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

showParen_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
showParen_Expr LHsExpr GhcPs
e1 LHsExpr GhcPs
e2 = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
showParen_RDR) LHsExpr GhcPs
e1) LHsExpr GhcPs
e2

nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs

nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr []  = String -> LocatedA (HsExpr GhcPs)
forall a. String -> a
panic String
"nested_compose_expr"   -- Arg is always non-empty
nested_compose_Expr [LHsExpr GhcPs
e] = LHsExpr GhcPs -> LHsExpr GhcPs
parenify LHsExpr GhcPs
e
nested_compose_Expr (LHsExpr GhcPs
e:[LHsExpr GhcPs]
es)
  = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
compose_RDR) (LHsExpr GhcPs -> LHsExpr GhcPs
parenify LHsExpr GhcPs
e)) ([LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr [LHsExpr GhcPs]
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 GhcPs
error_Expr String
string = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
error_RDR) (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
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 GhcPs
illegal_Expr String
meth String
tp String
msg =
   LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
error_RDR) (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
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 GhcPs
illegal_toEnum_tag String
tp RdrName
maxtag =
   LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
error_RDR)
           (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
append_RDR)
                       (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
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 GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
                           (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
showsPrec_RDR)
                           (Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
                           (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
a_RDR))
                           (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
                               (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
append_RDR)
                               (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
") is outside of enumeration's range (0,")))
                               (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
                                        (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
showsPrec_RDR)
                                        (Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
                                        (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
maxtag))
                                        (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
")"))))))

parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
parenify e :: LHsExpr GhcPs
e@(L _ (HsVar _ _)) = LHsExpr GhcPs
e
parenify LHsExpr GhcPs
e                   = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar LHsExpr GhcPs
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 GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
e1 RdrName
op LHsExpr GhcPs
e2 = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp LHsExpr GhcPs
e1 IdP GhcPs
RdrName
op LHsExpr GhcPs
e2)

genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
e1 RdrName
op LHsExpr GhcPs
e2 = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP GhcPs
RdrName
tagToEnum_RDR) (LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp LHsExpr GhcPs
e1 IdP GhcPs
RdrName
op LHsExpr GhcPs
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]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]
bs_RDRs :: [RdrName]
bs_RDRs         = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"b"String -> String -> String
forall a. [a] -> [a] -> [a]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]
cs_RDRs :: [RdrName]
cs_RDRs         = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"c"String -> String -> String
forall a. [a] -> [a] -> [a]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]

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

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

minusInt_RDR, tagToEnum_RDR :: RdrName
minusInt_RDR :: RdrName
minusInt_RDR  = TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (PrimOp -> TyVar
primOpId PrimOp
IntSubOp   )
tagToEnum_RDR :: RdrName
tagToEnum_RDR = TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (PrimOp -> TyVar
primOpId PrimOp
TagToEnumOp)

new_tag2con_rdr_name, new_maxtag_rdr_name
  :: SrcSpan -> TyCon -> TcM RdrName
-- Generates Exact RdrNames, for the binding positions
new_tag2con_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
dflags TyCon
tycon = SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
dflags TyCon
tycon OccName -> OccName
mkTag2ConOcc
new_maxtag_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_maxtag_rdr_name  SrcSpan
dflags TyCon
tycon = SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
dflags TyCon
tycon OccName -> OccName
mkMaxTagOcc

new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name SrcSpan
dflags TyCon
tycon = SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
dflags TyCon
tycon OccName -> OccName
mkDataTOcc

new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name SrcSpan
dflags DataCon
dc = SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
new_dc_deriv_rdr_name SrcSpan
dflags DataCon
dc OccName -> OccName
mkDataCOcc

new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
loc TyCon
tycon OccName -> OccName
occ_fun
  = SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName SrcSpan
loc (TyCon -> Name
tyConName TyCon
tycon) OccName -> OccName
occ_fun

new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
new_dc_deriv_rdr_name SrcSpan
loc DataCon
dc OccName -> OccName
occ_fun
  = SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName SrcSpan
loc (DataCon -> Name
dataConName DataCon
dc) OccName -> OccName
occ_fun

-- | Generate the name for an auxiliary binding, giving it a fresh 'Unique'.
-- Returns an 'Exact' 'RdrName' with an underlying 'System' 'Name'.
-- See @Note [Auxiliary binders]@.
newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName SrcSpan
loc Name
parent OccName -> OccName
occ_fun = do
  Unique
uniq <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
  RdrName -> TcM RdrName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RdrName -> TcM RdrName) -> RdrName -> TcM RdrName
forall a b. (a -> b) -> a -> b
$ Name -> RdrName
Exact (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt Unique
uniq (OccName -> OccName
occ_fun (Name -> OccName
nameOccName Name
parent)) SrcSpan
loc

-- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@
-- whose return types match when checked against @tycon_args@.
--
-- See Note [Filter out impossible GADT data constructors]
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args = (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filter DataCon -> Bool
isPossible ([DataCon] -> [DataCon]) -> [DataCon] -> [DataCon]
forall a b. (a -> b) -> a -> b
$ TyCon -> [DataCon]
tyConDataCons TyCon
tycon
  where
    isPossible :: DataCon -> Bool
isPossible DataCon
dc = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Type] -> DataCon -> Bool
dataConCannotMatch (DataCon -> [Type] -> [Type]
dataConInstUnivs DataCon
dc [Type]
tycon_args) DataCon
dc

-- | Information about the arguments to the class in a stock- or
-- newtype-derived instance. For a @deriving@-generated instance declaration
-- such as this one:
--
-- @
-- instance Ctx => Cls cls_ty_1 ... cls_ty_m (TC tc_arg_1 ... tc_arg_n) where ...
-- @
--
-- * 'dit_cls_tys' corresponds to @cls_ty_1 ... cls_ty_m@.
--
-- * 'dit_tc' corresponds to @TC@.
--
-- * 'dit_tc_args' corresponds to @tc_arg_1 ... tc_arg_n@.
--
-- See @Note [DerivEnv and DerivSpecMechanism]@ in "GHC.Tc.Deriv.Utils" for a
-- more in-depth explanation, including the relationship between
-- 'dit_tc'/'dit_rep_tc' and 'dit_tc_args'/'dit_rep_tc_args'.
--
-- A 'DerivInstTys' value can be seen as a more structured representation of
-- the 'denv_inst_tys' in a 'DerivEnv', as the 'denv_inst_tys' is equal to
-- @dit_cls_tys ++ ['mkTyConApp' dit_tc dit_tc_args]@. Other parts of the
-- instance declaration can be found in the 'DerivEnv'. For example, the @Cls@
-- in the example above corresponds to the 'denv_cls' field of 'DerivEnv'.
--
-- Similarly, the type variables that appear in a 'DerivInstTys' value are the
-- same type variables as the 'denv_tvs' in the parent 'DerivEnv'. Accordingly,
-- if we are inferring an instance context, the type variables will be 'TcTyVar'
-- skolems. Otherwise, they will be ordinary 'TyVar's.
-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
data DerivInstTys = DerivInstTys
  { DerivInstTys -> [Type]
dit_cls_tys     :: [Type]
    -- ^ Other arguments to the class except the last
  , DerivInstTys -> TyCon
dit_tc          :: TyCon
    -- ^ Type constructor for which the instance is requested
    --   (last arguments to the type class)
  , DerivInstTys -> [Type]
dit_tc_args     :: [Type]
    -- ^ Arguments to the type constructor
  , DerivInstTys -> TyCon
dit_rep_tc      :: TyCon
    -- ^ The representation tycon for 'dit_tc'
    --   (for data family instances). Otherwise the same as 'dit_tc'.
  , DerivInstTys -> [Type]
dit_rep_tc_args :: [Type]
    -- ^ The representation types for 'dit_tc_args'
    --   (for data family instances). Otherwise the same as 'dit_tc_args'.
  , DerivInstTys -> DataConEnv [Type]
dit_dc_inst_arg_env :: DataConEnv [Type]
    -- ^ The cached results of instantiating each data constructor's field
    --   types using @'dataConInstUnivs' data_con 'dit_rep_tc_args'@.
    --   See @Note [Instantiating field types in stock deriving]@.
    --
    --   This field is only used for stock-derived instances and goes unused
    --   for newtype-derived instances. It is put here mainly for the sake of
    --   convenience.
  }

instance Outputable DerivInstTys where
  ppr :: DerivInstTys -> SDoc
ppr (DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys, dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
                    , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc, dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args
                    , dit_dc_inst_arg_env :: DerivInstTys -> DataConEnv [Type]
dit_dc_inst_arg_env = DataConEnv [Type]
dc_inst_arg_env })
    = SDoc -> Arity -> SDoc -> SDoc
hang (String -> SDoc
text String
"DerivInstTys")
         Arity
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"dit_cls_tys"         SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys
                 , String -> SDoc
text String
"dit_tc"              SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tc
                 , String -> SDoc
text String
"dit_tc_args"         SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
tc_args
                 , String -> SDoc
text String
"dit_rep_tc"          SDoc -> SDoc -> SDoc
<+> TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
rep_tc
                 , String -> SDoc
text String
"dit_rep_tc_args"     SDoc -> SDoc -> SDoc
<+> [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Type]
rep_tc_args
                 , String -> SDoc
text String
"dit_dc_inst_arg_env" SDoc -> SDoc -> SDoc
<+> DataConEnv [Type] -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataConEnv [Type]
dc_inst_arg_env ])

-- | Look up a data constructor's instantiated field types in a 'DerivInstTys'.
-- See @Note [Instantiating field types in stock deriving]@.
derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
dc DerivInstTys
dit =
  case DataConEnv [Type] -> DataCon -> Maybe [Type]
forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (DerivInstTys -> DataConEnv [Type]
dit_dc_inst_arg_env DerivInstTys
dit) DataCon
dc of
    Just [Type]
inst_arg_tys -> [Type]
inst_arg_tys
    Maybe [Type]
Nothing           -> String -> SDoc -> [Type]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"derivDataConInstArgTys" (DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
dc)

-- | @'buildDataConInstArgEnv' tycon arg_tys@ constructs a cache that maps
-- each of @tycon@'s data constructors to their field types, with are to be
-- instantiated with @arg_tys@.
-- See @Note [Instantiating field types in stock deriving]@.
buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args =
  [(DataCon, [Type])] -> DataConEnv [Type]
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [ (DataCon
dc, [Type]
inst_arg_tys)
            | DataCon
dc <- TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
            , let ([TyVar]
_, [Type]
_, [Type]
inst_arg_tys) =
                    DataCon -> [Type] -> ([TyVar], [Type], [Type])
dataConInstSig DataCon
dc ([Type] -> ([TyVar], [Type], [Type]))
-> [Type] -> ([TyVar], [Type], [Type])
forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Type]
dataConInstUnivs DataCon
dc [Type]
rep_tc_args
            ]

-- | Apply a substitution to all of the 'Type's contained in a 'DerivInstTys'.
-- See @Note [Instantiating field types in stock deriving]@ for why we need to
-- substitute into a 'DerivInstTys' in the first place.
substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys
substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys
substDerivInstTys TCvSubst
subst
  dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
                    , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc, dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args })

  | TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst
  = DerivInstTys
dit
  | Bool
otherwise
  = DerivInstTys
dit{ dit_cls_tys :: [Type]
dit_cls_tys         = [Type]
cls_tys'
       , dit_tc_args :: [Type]
dit_tc_args         = [Type]
tc_args'
       , dit_rep_tc_args :: [Type]
dit_rep_tc_args     = [Type]
rep_tc_args'
       , dit_dc_inst_arg_env :: DataConEnv [Type]
dit_dc_inst_arg_env = TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args'
       }
  where
    cls_tys' :: [Type]
cls_tys'     = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
cls_tys
    tc_args' :: [Type]
tc_args'     = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
tc_args
    rep_tc_args' :: [Type]
rep_tc_args' = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
rep_tc_args

-- | Zonk the 'TcTyVar's in a 'DerivInstTys' value to 'TyVar's.
-- See @Note [What is zonking?]@ in "GHC.Tc.Utils.TcMType".
--
-- This is only used in the final zonking step when inferring
-- the context for a derived instance.
-- See @Note [Overlap and deriving]@ in "GHC.Tc.Deriv.Infer".
zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys
zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys
zonkDerivInstTys ZonkEnv
ze dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys
                                      , dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
                                      , dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc
                                      , dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args }) = do
  [Type]
cls_tys'     <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
cls_tys
  [Type]
tc_args'     <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
tc_args
  [Type]
rep_tc_args' <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
rep_tc_args
  DerivInstTys -> TcM DerivInstTys
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivInstTys
dit{ dit_cls_tys :: [Type]
dit_cls_tys         = [Type]
cls_tys'
          , dit_tc_args :: [Type]
dit_tc_args         = [Type]
tc_args'
          , dit_rep_tc_args :: [Type]
dit_rep_tc_args     = [Type]
rep_tc_args'
          , dit_dc_inst_arg_env :: DataConEnv [Type]
dit_dc_inst_arg_env = TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args'
          }

{-
Note [Auxiliary binders]
~~~~~~~~~~~~~~~~~~~~~~~~
We often want to make top-level auxiliary bindings in derived instances.
For example, derived Ix instances sometimes generate code like this:

  data T = ...
  deriving instance Ix T

  ==>

  instance Ix T where
    range (a, b) = map tag2con_T [dataToTag# a .. dataToTag# b]

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

Note that multiple instances of the same type might need to use the same sort
of auxiliary binding. For example, $tag2con is used not only in derived Ix
instances, but also in derived Enum instances:

  deriving instance Enum T

  ==>

  instance Enum T where
    toEnum i = tag2con_T i

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

How do we ensure that the two usages of $tag2con_T do not conflict with each
other? We do so by generating a separate $tag2con_T definition for each
instance, giving each definition an Exact RdrName with a separate Unique to
avoid name clashes:

  instance Ix T where
    range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]

  instance Enum T where
    toEnum a = $tag2con_T{Uniq2} a

   -- $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are Exact RdrNames with
   -- underlying System Names

   $tag2con_T{Uniq1} :: Int -> T
   $tag2con_T{Uniq1} = ...code....

   $tag2con_T{Uniq2} :: Int -> T
   $tag2con_T{Uniq2} = ...code....

Note that:

* This is /precisely/ the same mechanism that we use for
  Template Haskell–generated code.
  See Note [Binders in Template Haskell] in GHC.ThToHs.
  There we explain why we use a 'System' flavour of the Name we generate.

* See "Wrinkle: Reducing code duplication" for how we can avoid generating
  lots of duplicated code in common situations.

* See "Wrinkle: Why we sometimes do generated duplicate code" for why this
  de-duplication mechanism isn't perfect, so we fall back to CSE
  (which is very effective within a single module).

* Note that the "_T" part of "$tag2con_T" is just for debug-printing
  purposes. We could call them all "$tag2con", or even just "aux".
  The Unique is enough to keep them separate.

  This is important: we might be generating an Eq instance for two
  completely-distinct imported type constructors T.

At first glance, it might appear that this plan is infeasible, as it would
require generating multiple top-level declarations with the same OccName. But
what if auxiliary bindings /weren't/ top-level? Conceptually, we could imagine
that auxiliary bindings are /local/ to the instance declarations in which they
are used. Using some hypothetical Haskell syntax, it might look like this:

  let {
    $tag2con_T{Uniq1} :: Int -> T
    $tag2con_T{Uniq1} = ...code....

    $tag2con_T{Uniq2} :: Int -> T
    $tag2con_T{Uniq2} = ...code....
  } in {
    instance Ix T where
      range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]

    instance Enum T where
      toEnum a = $tag2con_T{Uniq2} a
  }

Making auxiliary bindings local is key to making this work, since GHC will
not reject local bindings with duplicate names provided that:

* Each binding has a distinct unique, and
* Each binding has an Exact RdrName with a System Name.

Even though the hypothetical Haskell syntax above does not exist, we can
accomplish the same end result through some sleight of hand in renameDeriv:
we rename auxiliary bindings with rnLocalValBindsLHS. (If we had used
rnTopBindsLHS instead, then GHC would spuriously reject auxiliary bindings
with the same OccName as duplicates.) Luckily, no special treatment is needed
to typecheck them; we can typecheck them as normal top-level bindings
(using tcTopBinds) without danger.

-----
-- Wrinkle: Reducing code duplication
-----

While the approach of generating copies of each sort of auxiliary binder per
derived instance is simpler, it can lead to code bloat if done naïvely.
Consider this example:

  data T = ...
  deriving instance Eq T
  deriving instance Ord T

  ==>

  instance Ix T where
    range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]

  instance Enum T where
    toEnum a = $tag2con_T{Uniq2} a

  $tag2con_T{Uniq1} :: Int -> T
  $tag2con_T{Uniq1} = ...code....

  $tag2con_T{Uniq2} :: Int -> T
  $tag2con_T{Uniq2} = ...code....

$tag2con_T{Uniq1} and $tag2con_T{Uniq2} are blatant duplicates of each other,
which is not ideal. Surely GHC can do better than that at the very least! And
indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like
pass to define duplicate auxiliary binders in terms of the original one. On
the example above, that would look like this:

  $tag2con_T{Uniq1} :: Int -> T
  $tag2con_T{Uniq1} = ...code....

  $tag2con_T{Uniq2} :: Int -> T
  $tag2con_T{Uniq2} = $tag2con_T{Uniq1}

(Note that this pass does not cover all possible forms of code duplication.
See "Wrinkle: Why we sometimes do generate duplicate code" for situations
where genAuxBinds does not deduplicate code.)

To start, genAuxBinds is given a list of AuxBindSpecs, which describe the sort
of auxiliary bindings that must be generates along with their RdrNames. As
genAuxBinds processes this list, it marks the first occurrence of each sort of
auxiliary binding as the "original". For example, if genAuxBinds sees a
DerivCon2Tag for the first time (with the RdrName $tag2con_T{Uniq1}), then it
will generate the full code for a $tag2con binding:

  $tag2con_T{Uniq1} :: Int -> T
  $tag2con_T{Uniq1} = ...code....

Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat
them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with
the RdrName $tag2con_T{Uniq2}, it will generate this code, which is much more
compact:

  $tag2con_T{Uniq2} :: Int -> T
  $tag2con_T{Uniq2} = $tag2con_T{Uniq1}

An alternative approach would be /not/ performing any kind of deduplication in
genAuxBinds at all and simply relying on GHC's simplifier to perform this kind
of CSE. But this is a more expensive analysis in general, while genAuxBinds can
accomplish the same result with a simple check.

-----
-- Wrinkle: Why we sometimes do generate duplicate code
-----

It is worth noting that deduplicating auxiliary binders is difficult in the
general case. Here are two particular examples where GHC cannot easily remove
duplicate copies of an auxiliary binding:

1. When derived instances are contained in different modules, as in the
   following example:

     module A where
       data T = ...
     module B where
       import A
       deriving instance Ix T
     module C where
       import B
       deriving instance Enum T

   The derived Eq and Enum instances for T make use of $tag2con_T, and since
   they are defined in separate modules, each module must produce its own copy
   of $tag2con_T.

2. When derived instances are separated by TH splices (#18321), as in the
   following example:

     module M where

     data T = ...
     deriving instance Ix T
     $(pure [])
     deriving instance Enum T

   Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice
   in this program: once for all the declarations before the TH splice, and
   once again for all the declarations after the TH splice. As a result,
   $tag2con_T will be generated twice, since genAuxBinds will be unable to
   recognize the presence of duplicates.

These situations are much rarer, so we do not spend any effort to deduplicate
auxiliary bindings there. Instead, we focus on the common case of multiple
derived instances within the same module, not separated by any TH splices.
(This is the case described in "Wrinkle: Reducing code duplication".) In
situation (1), we can at least fall back on GHC's simplifier to pick up
genAuxBinds' slack.

Note [Filter out impossible GADT data constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Some stock-derivable classes will filter out impossible GADT data constructors,
to rule out problematic constructors when deriving instances. e.g.

```
data Foo a where
  X :: Foo Int
  Y :: (Bool -> Bool) -> Foo Bool
```

when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't
exist in the first place. For instance, if we write

```
deriving instance Eq (Foo Int)
```

it should generate:

```
instance Eq (Foo Int) where
  X == X = True
```

Classes that filter constructors:

* Eq
* Ord
* Show
* Lift
* Functor
* Foldable
* Traversable

Classes that do not filter constructors:

* Enum: doesn't make sense for GADTs in the first place
* Bounded: only makes sense for GADTs with a single constructor
* Ix: only makes sense for GADTs with a single constructor
* Read: `Read a` returns `a` instead of consumes `a`, so filtering data
  constructors would make this function _more_ partial instead of less
* Data: derived implementations of gunfold rely on a constructor-indexing
  scheme that wouldn't work if certain constructors were filtered out
* Generic/Generic1: doesn't make sense for GADTs

Classes that do not currently filter constructors may do so in the future, if
there is a valid use-case and we have requirements for how they should work.

See #16341 and the T16341.hs test case.

Note [Instantiating field types in stock deriving]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Figuring out what the types of data constructor fields are in `deriving` can
be surprisingly tricky. Here are some examples (adapted from #20375) to set
the scene:

  data Ta = MkTa Int#
  data Tb (x :: TYPE IntRep) = MkTb x

  deriving instance Eq Ta        -- 1.
  deriving instance Eq (Tb a)    -- 2.
  deriving instance Eq (Tb Int#) -- 3.

Example (1) is accepted, as `deriving Eq` has a special case for fields of type
Int#. Example (2) is rejected, however, as the special case for Int# does not
extend to all types of kind (TYPE IntRep).

Example (3) ought to typecheck. If you instantiate the field of type `x` in
MkTb to be Int#, then `deriving Eq` is capable of handling that. We must be
careful, however. If we naïvely use, say, `dataConOrigArgTys` to retrieve the
field types, then we would get `b`, which `deriving Eq` would reject. In
order to handle `deriving Eq` (and, more generally, any stock deriving
strategy) correctly, we /must/ instantiate the field types as needed.
Not doing so led to #20375 and #20387.

In fact, we end up needing to instantiate the field types in quite a few
places:

* When performing validity checks for stock deriving strategies (e.g., in
  GHC.Tc.Deriv.Utils.cond_stdOK)

* When inferring the instance context in
  GHC.Tc.Deriv.Infer.inferConstraintStock

* When generating code for stock-derived instances in
  GHC.Tc.Deriv.{Functor,Generate,Generics}

Repeatedly performing these instantiations in multiple places would be
wasteful, so we build a cache of data constructor field instantiations in
the `dit_dc_inst_arg_env` field of DerivInstTys. Specifically:

1. When beginning to generate code for a stock-derived instance
   `T arg_1 ... arg_n`, the `dit_dc_inst_arg_env` field is created by taking
   each data constructor `dc`, instantiating its field types with
   `dataConInstUnivs dc [arg_1, ..., arg_n]`, and mapping `dc` to the
   instantiated field types in the cache. The `buildDataConInstArgEnv` function
   is responsible for orchestrating this.

2. When a part of the code in GHC.Tc.Deriv.* needs to look up the field
   types, we deliberately avoid using `dataConOrigArgTys`. Instead, we use
   `derivDataConInstArgTys`, which looks up a DataCon's instantiated field
   types in the cache.

StandaloneDeriving is one way for the field types to become instantiated.
Another way is by deriving Functor and related classes, as chronicled in
Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. Here is one such
example:

  newtype Compose (f :: k -> Type) (g :: j -> k) (a :: j) = Compose (f (g a))
    deriving Generic1

This ultimately generates the following instance:

  instance forall (f :: Type -> Type) (g :: j -> Type).
    Functor f => Generic1 (Compose f g) where ...

Note that because of the inferred `Functor f` constraint, `k` was instantiated
to be `Type`. GHC's deriving machinery doesn't realize this until it performs
constraint inference (in GHC.Tc.Deriv.Infer.inferConstraintsStock), however,
which is *after* the initial DerivInstTys has been created. As a result, the
`dit_dc_inst_arg_env` field might need to be updated after constraint inference,
as the inferred constraints might instantiate the field types further.

This is accomplished by way of `substDerivInstTys`, which substitutes all of
the fields in a `DerivInstTys`, including the `dit_dc_inst_arg_env`.
It is important to do this in inferConstraintsStock, as the
deriving/should_compile/T20387 test case will not compile otherwise.
-}