{-
    %
(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,
        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,

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

import GHC.Prelude

import GHC.Hs

import GHC.Tc.TyCl.Class ( substATBndrs )
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Instantiate( newFamInst )
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Zonk.Type
import GHC.Tc.Validity

import GHC.Core.DataCon
import GHC.Core.FamInstEnv
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
import GHC.Core.Type
import GHC.Core.Class

import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Types.Name
import GHC.Types.SourceText
import GHC.Types.Id.Make ( coerceId )
import GHC.Types.SrcLoc
import GHC.Types.Unique.FM ( lookupUFM, listToUFM )
import GHC.Types.Var.Env
import GHC.Types.Var
import GHC.Types.Var.Set

import GHC.Builtin.Names
import GHC.Builtin.Names.TH
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types

import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Lexeme

import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Bag
import GHC.Data.Maybe ( expectJust )
import GHC.Unit.Module

import Language.Haskell.Syntax.Basic (FieldLabelString(..))

import Data.List  ( find, partition, intersperse )

-- | 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 (GhcPass 'Parsed), 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
    ([GenLocated
    SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))],
 Bag AuxBindSpec)
-> IOEnv
     (Env TcGblEnv TcLclEnv)
     ([GenLocated
         SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))],
      Bag AuxBindSpec)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
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 (GhcPass 'Parsed)
eq_expr_with_tag_check = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase
      (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar ([(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR,RdrName
ah_RDR), (RdrName
b_RDR,RdrName
bh_RDR)]
                    (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
ah_RDR) IdP (GhcPass 'Parsed)
RdrName
neInt_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
bh_RDR))))
      [ LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
nlLitPat (XHsIntPrim (GhcPass 'Parsed) -> Integer -> HsLit (GhcPass 'Parsed)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim (GhcPass 'Parsed)
SourceText
NoSourceText Integer
1)) LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
false_Expr
      , LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (
          LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase
            (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
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 (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
non_nullary_pats = (DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
DataCon
-> GenLocated
     SrcSpanAnnA
     (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
pats_etc [DataCon]
non_nullary_cons
             in if [DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons
                then [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
[GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
non_nullary_pats
                else [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
non_nullary_pats [GenLocated
   SrcSpanAnnA
   (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
true_Expr]))
      ]

    method_binds :: [GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
method_binds = [LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
eq_bind]
    eq_bind :: LHsBind (GhcPass 'Parsed)
eq_bind = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
2 SrcSpan
loc RdrName
eq_RDR (LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a b. a -> b -> a
const LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
true_Expr) [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
[([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
  LocatedA (HsExpr (GhcPass 'Parsed)))]
binds
      where
        binds :: [([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
  LocatedA (HsExpr (GhcPass 'Parsed)))]
binds
          | [DataCon] -> Bool
forall a. [a] -> 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 (GhcPass 'Parsed)
con1_pat <- LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed))
-> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
          , LPat (GhcPass 'Parsed)
con2_pat <- LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed))
-> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
          , LocatedA (HsExpr (GhcPass 'Parsed))
eq_expr <- [Type]
-> [RdrName] -> [RdrName] -> LocatedA (HsExpr (GhcPass 'Parsed))
nested_eq_expr [Type]
tys_needed [RdrName]
as_needed [RdrName]
bs_needed
          = [([LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
con1_pat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
con2_pat], LocatedA (HsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
b_Pat], [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR,RdrName
ah_RDR), (RdrName
b_RDR,RdrName
bh_RDR)]
                    (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
ah_RDR) RdrName
eqInt_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
bh_RDR)))]
          | Bool
otherwise
          = [([LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
b_Pat], LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
eq_expr_with_tag_check)]

    ------------------------------------------------------------------
    nested_eq_expr :: [Type] -> [RdrName] -> [RdrName] -> LHsExpr (GhcPass 'Parsed)
nested_eq_expr []  [] [] = LHsExpr (GhcPass 'Parsed)
true_Expr
    nested_eq_expr [Type]
tys [RdrName]
as [RdrName]
bs
      = (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
and_Expr (String
-> (Type
    -> RdrName -> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [Type]
-> [RdrName]
-> [RdrName]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a b c d.
HasDebugCallStack =>
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"nested_eq" Type -> RdrName -> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
nested_eq [Type]
tys [RdrName]
as [RdrName]
bs)
      -- Using 'foldr1' here ensures that the derived code is correctly
      -- associated. See #10859.
      where
        nested_eq :: Type -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
nested_eq Type
ty RdrName
a RdrName
b = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (Type
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
eq_Expr Type
ty (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
a) (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
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
      , Int
con_arity <- [Type] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys_needed
      , [RdrName]
as_needed <- Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
      , [RdrName]
bs_needed <- Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
bs_RDRs
      = ([RdrName]
as_needed, [RdrName]
bs_needed, [Type]
tys_needed)

    pats_etc :: DataCon
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
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 (GhcPass 'Parsed)
con1_pat <- LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed))
-> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
      , LPat (GhcPass 'Parsed)
con2_pat <- LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LPat (GhcPass p) -> LPat (GhcPass p)
nlParPat (LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed))
-> LPat (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
      , LocatedA (HsExpr (GhcPass 'Parsed))
fields_eq_expr <- [Type]
-> [RdrName] -> [RdrName] -> LocatedA (HsExpr (GhcPass 'Parsed))
nested_eq_expr [Type]
tys_needed [RdrName]
as_needed [RdrName]
bs_needed
      = LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
con1_pat (LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b_RDR) [LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
con2_pat LocatedA (HsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
ltResult OrdOp
OrdCompare = LHsExpr (GhcPass 'Parsed)
ltTag_Expr
ltResult OrdOp
OrdLT      = LHsExpr (GhcPass 'Parsed)
true_Expr
ltResult OrdOp
OrdLE      = LHsExpr (GhcPass 'Parsed)
true_Expr
ltResult OrdOp
OrdGE      = LHsExpr (GhcPass 'Parsed)
false_Expr
ltResult OrdOp
OrdGT      = LHsExpr (GhcPass 'Parsed)
false_Expr

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

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

------------
gen_Ord_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Ord_binds :: SrcSpan
-> DerivInstTys
-> TcM (LHsBinds (GhcPass 'Parsed), 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
    (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
-> TcM (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return ((LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
 -> TcM (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec))
-> (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
-> TcM (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
forall a b. (a -> b) -> a -> b
$ if [DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
tycon_data_cons -- No data-cons => invoke bale-out case
      then ( [Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
2 SrcSpan
loc RdrName
compare_RDR (LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a b. a -> b -> a
const LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
eqTag_Expr) []]
           , Bag AuxBindSpec
forall a. Bag a
emptyBag)
      else ( [OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp OrdOp
OrdCompare] [GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
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 :: [GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
other_ops
      | (Int
last_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
first_tag) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
2     -- 1-3 constructors
        Bool -> Bool -> Bool
|| [DataCon] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons        -- Or it's an enumeration
      = [OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp OrdOp
OrdLT, LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
lE, LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
gT, LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
gE]
      | Bool
otherwise
      = []

    negate_expr :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
negate_expr = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
not_RDR)
    pats :: GenLocated
  EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pats = [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
b_Pat]
    lE :: LHsBind (GhcPass 'Parsed)
lE = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
le_RDR LocatedE [LPat (GhcPass 'Parsed)]
GenLocated
  EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pats (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
negate_expr (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
lt_RDR) LHsExpr (GhcPass 'Parsed)
b_Expr) LHsExpr (GhcPass 'Parsed)
a_Expr)
    gT :: LHsBind (GhcPass 'Parsed)
gT = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
gt_RDR LocatedE [LPat (GhcPass 'Parsed)]
GenLocated
  EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pats (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
lt_RDR) LHsExpr (GhcPass 'Parsed)
b_Expr) LHsExpr (GhcPass 'Parsed)
a_Expr
    gE :: LHsBind (GhcPass 'Parsed)
gE = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
ge_RDR LocatedE [LPat (GhcPass 'Parsed)]
GenLocated
  EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
pats (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
negate_expr (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
lt_RDR) LHsExpr (GhcPass 'Parsed)
a_Expr) LHsExpr (GhcPass 'Parsed)
b_Expr)

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

    tycon_data_cons :: [DataCon]
tycon_data_cons = TyCon -> [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 :: Int
first_tag       = DataCon -> Int
get_tag DataCon
first_con
    last_tag :: Int
last_tag        = DataCon -> Int
get_tag DataCon
last_con

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


    mkOrdOp :: OrdOp -> LHsBind GhcPs
    -- Returns a binding   op a b = ... compares a and b according to op ....
    mkOrdOp :: OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp OrdOp
op
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc (OrdOp -> RdrName
ordMethRdr OrdOp
op) ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
b_Pat])
                        (OrdOp -> LHsExpr (GhcPass 'Parsed)
mkOrdOpRhs OrdOp
op)

    mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
    mkOrdOpRhs :: OrdOp -> LHsExpr (GhcPass 'Parsed)
mkOrdOpRhs OrdOp
op -- RHS for comparing 'a' and 'b' according to op
      | [DataCon]
nullary_cons [DataCon] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthAtMost` Int
2 -- Two nullary or fewer, so use cases
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
a_RDR) ([LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
 -> LHsExpr (GhcPass 'Parsed))
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        (DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed)))
-> [DataCon]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map (OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
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 -> ....compare x.... }

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

      | Bool
otherwise                -- Mixed nullary and non-nullary
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
a_RDR) ([LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
 -> LHsExpr (GhcPass 'Parsed))
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        ((DataCon
 -> GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [DataCon]
-> [GenLocated
      SrcSpanAnnA
      (Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b. (a -> b) -> [a] -> [b]
map (OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt OrdOp
op) [DataCon]
non_nullary_cons
         [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
forall a. [a] -> [a] -> [a]
++ [LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
mkTagCmp OrdOp
op)])


    mkOrdOpAlt :: OrdOp -> DataCon
               -> LMatch GhcPs (LHsExpr GhcPs)
    -- Make the alternative  (Ki a1 a2 .. av ->
    mkOrdOpAlt :: OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt OrdOp
op DataCon
data_con
      = LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed)
                    (OrdOp -> DataCon -> LHsExpr (GhcPass 'Parsed)
mkInnerRhs OrdOp
op DataCon
data_con)
      where
        as_needed :: [RdrName]
as_needed    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
data_con) [RdrName]
as_RDRs
        data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con

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

      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
first_tag
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]
      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
last_tag
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]

      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
first_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b_RDR) [ LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlConWildPat DataCon
first_con)
                                             (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op)
                                 , OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]
      | Int
tag Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
last_tag Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b_RDR) [ LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlConWildPat DataCon
last_con)
                                             (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op)
                                 , OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]

      | Int
tag Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
last_tag Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2  -- lower range is larger
      = [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
bh_RDR) RdrName
ltInt_RDR LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
tag_lit)
               (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$  -- Definitely GT
        LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]

      | Bool
otherwise               -- upper range is larger
      = [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
bh_RDR) RdrName
gtInt_RDR LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
tag_lit)
               (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$  -- Definitely LT
        LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
                                 , LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]
      where
        tag :: Int
tag     = DataCon -> Int
get_tag DataCon
data_con
        tag_lit :: LocatedA (HsExpr (GhcPass 'Parsed))
tag_lit
             = HsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XLitE (GhcPass 'Parsed)
-> HsLit (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit XLitE (GhcPass 'Parsed)
NoExtField
noExtField (XHsIntPrim (GhcPass 'Parsed) -> Integer -> HsLit (GhcPass 'Parsed)
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim XHsIntPrim (GhcPass 'Parsed)
SourceText
NoSourceText (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
tag)))

    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
    -- First argument 'a' known to be built with K
    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
    mkInnerEqAlt :: OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
      = LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed) (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$
        OrdOp -> [Type] -> LHsExpr (GhcPass 'Parsed)
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    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take (DataCon -> Int
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 (GhcPass 'Parsed)
mkTagCmp OrdOp
op =
      [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR),(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        Type -> OrdOp -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
unliftedOrdOp Type
intPrimTy OrdOp
op RdrName
ah_RDR RdrName
bh_RDR

mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
-- where the ai,bi have the given types
mkCompareFields :: OrdOp -> [Type] -> LHsExpr (GhcPass 'Parsed)
mkCompareFields OrdOp
op [Type]
tys
  = [Type]
-> [RdrName] -> [RdrName] -> LocatedA (HsExpr (GhcPass 'Parsed))
go [Type]
tys [RdrName]
as_RDRs [RdrName]
bs_RDRs
  where
    go :: [Type]
-> [RdrName] -> [RdrName] -> LocatedA (HsExpr (GhcPass 'Parsed))
go []   [RdrName]
_      [RdrName]
_          = OrdOp -> LHsExpr (GhcPass 'Parsed)
eqResult OrdOp
op
    go [Type
ty] (RdrName
a:[RdrName]
_)  (RdrName
b:[RdrName]
_)
      | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty     = Type -> OrdOp -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
      | Bool
otherwise             = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
a) (OrdOp -> RdrName
ordMethRdr OrdOp
op) (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b)
    go (Type
ty:[Type]
tys) (RdrName
a:[RdrName]
as) (RdrName
b:[RdrName]
bs) = Type
-> RdrName
-> RdrName
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_compare Type
ty RdrName
a RdrName
b
                                  (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op)
                                  ([Type]
-> [RdrName] -> [RdrName] -> LocatedA (HsExpr (GhcPass 'Parsed))
go [Type]
tys [RdrName]
as [RdrName]
bs)
                                  (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op)
    go [Type]
_ [RdrName]
_ [RdrName]
_ = String -> LocatedA (HsExpr (GhcPass 'Parsed))
forall a. HasCallStack => 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
-> IdGhcP 'Parsed
-> IdGhcP 'Parsed
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
mk_compare Type
ty IdGhcP 'Parsed
a IdGhcP 'Parsed
b LocatedA (HsExpr (GhcPass 'Parsed))
lt LocatedA (HsExpr (GhcPass 'Parsed))
eq LocatedA (HsExpr (GhcPass 'Parsed))
gt
      | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty
      = RdrName
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr (GhcPass 'Parsed)
a_expr LHsExpr (GhcPass 'Parsed)
b_expr LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
lt LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
eq LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
gt
      | Bool
otherwise
      = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
compare_RDR) LHsExpr (GhcPass 'Parsed)
a_expr) LHsExpr (GhcPass 'Parsed)
b_expr))
          [LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlNullaryConPat RdrName
ltTag_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
lt,
           LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlNullaryConPat RdrName
eqTag_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
eq,
           LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
nlNullaryConPat RdrName
gtTag_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
gt]
      where
        a_expr :: LHsExpr (GhcPass 'Parsed)
a_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
IdGhcP 'Parsed
a
        b_expr :: LHsExpr (GhcPass 'Parsed)
b_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
IdGhcP 'Parsed
b
        (RdrName
lt_op, RdrName
_, RdrName
eq_op, RdrName
_, RdrName
_) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Ord" Type
ty

unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
  = case OrdOp
op of
       OrdOp
OrdCompare -> RdrName
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr (GhcPass 'Parsed)
a_expr LHsExpr (GhcPass 'Parsed)
b_expr
                                     LHsExpr (GhcPass 'Parsed)
ltTag_Expr LHsExpr (GhcPass 'Parsed)
eqTag_Expr LHsExpr (GhcPass 'Parsed)
gtTag_Expr
       OrdOp
OrdLT      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
lt_op
       OrdOp
OrdLE      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
le_op
       OrdOp
OrdGE      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
ge_op
       OrdOp
OrdGT      -> RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
gt_op
  where
   (RdrName
lt_op, RdrName
le_op, RdrName
eq_op, RdrName
ge_op, RdrName
gt_op) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Ord" Type
ty
   wrap :: RdrName -> LHsExpr (GhcPass 'Parsed)
wrap RdrName
prim_op = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a_expr RdrName
prim_op LHsExpr (GhcPass 'Parsed)
b_expr
   a_expr :: LHsExpr (GhcPass 'Parsed)
a_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
a
   b_expr :: LHsExpr (GhcPass 'Parsed)
b_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
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 (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr (GhcPass 'Parsed)
a_expr LHsExpr (GhcPass 'Parsed)
b_expr LHsExpr (GhcPass 'Parsed)
lt LHsExpr (GhcPass 'Parsed)
eq LHsExpr (GhcPass 'Parsed)
gt
  = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p} {e}.
(NoGhcTc p ~ GhcPass 'Parsed, NoAnn (XExprWithTySig p),
 HasAnnotation e) =>
XRec p (HsExpr p) -> GenLocated e (HsExpr p)
ascribeBool (LHsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a_expr RdrName
lt_op LHsExpr (GhcPass 'Parsed)
b_expr) LHsExpr (GhcPass 'Parsed)
lt (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
                        -- Test (<) first, not (==), because the latter
                        -- is true less often, so putting it first would
                        -- mean more tests (dynamically)
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (LHsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p} {e}.
(NoGhcTc p ~ GhcPass 'Parsed, NoAnn (XExprWithTySig p),
 HasAnnotation e) =>
XRec p (HsExpr p) -> GenLocated e (HsExpr p)
ascribeBool (LHsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> LHsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a_expr RdrName
eq_op LHsExpr (GhcPass 'Parsed)
b_expr) LHsExpr (GhcPass 'Parsed)
eq LHsExpr (GhcPass 'Parsed)
gt
  where
    ascribeBool :: XRec p (HsExpr p) -> GenLocated e (HsExpr p)
ascribeBool XRec p (HsExpr p)
e = HsExpr p -> GenLocated e (HsExpr p)
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsExpr p -> GenLocated e (HsExpr p))
-> HsExpr p -> GenLocated e (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. NoAnn a => a
noAnn XRec p (HsExpr p)
e
                           (LHsSigWcType (NoGhcTc p) -> HsExpr p)
-> LHsSigWcType (NoGhcTc p) -> HsExpr p
forall a b. (a -> b) -> a -> b
$ LHsSigType (NoGhcTc p)
-> HsWildCardBndrs (GhcPass 'Parsed) (LHsSigType (NoGhcTc p))
forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs (LHsSigType (NoGhcTc p)
 -> HsWildCardBndrs (GhcPass 'Parsed) (LHsSigType (NoGhcTc p)))
-> LHsSigType (NoGhcTc p)
-> HsWildCardBndrs (GhcPass 'Parsed) (LHsSigType (NoGhcTc p))
forall a b. (a -> b) -> a -> b
$ HsSigType (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsSigType (GhcPass 'Parsed)
 -> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)))
-> HsSigType (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed)
mkHsImplicitSigType
                           (LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed))
-> LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ PromotionFlag -> IdP (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted IdP (GhcPass 'Parsed)
RdrName
boolTyCon_RDR

nlConWildPat :: DataCon -> LPat GhcPs
-- The pattern (K {})
nlConWildPat :: DataCon -> LPat (GhcPass 'Parsed)
nlConWildPat DataCon
con = Pat (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Pat (GhcPass 'Parsed)
 -> GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed)))
-> Pat (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ ConPat
  { pat_con_ext :: XConPat (GhcPass 'Parsed)
pat_con_ext = XConPat (GhcPass 'Parsed)
forall a. NoAnn a => a
noAnn
  , pat_con :: XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
pat_con = RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (RdrName -> GenLocated SrcSpanAnnN RdrName)
-> RdrName -> GenLocated SrcSpanAnnN RdrName
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
  , pat_args :: HsConPatDetails (GhcPass 'Parsed)
pat_args = HsRecFields (GhcPass 'Parsed) (LPat (GhcPass 'Parsed))
-> HsConPatDetails (GhcPass 'Parsed)
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (HsRecFields (GhcPass 'Parsed) (LPat (GhcPass 'Parsed))
 -> HsConPatDetails (GhcPass 'Parsed))
-> HsRecFields (GhcPass 'Parsed) (LPat (GhcPass 'Parsed))
-> HsConPatDetails (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ HsRecFields
      { rec_ext :: XHsRecFields (GhcPass 'Parsed)
rec_ext = NoExtField
XHsRecFields (GhcPass 'Parsed)
noExtField
      , rec_flds :: [LHsRecField (GhcPass 'Parsed) (LPat (GhcPass 'Parsed))]
rec_flds = []
      , rec_dotdot :: Maybe (XRec (GhcPass 'Parsed) RecFieldsDotDot)
rec_dotdot = Maybe (XRec (GhcPass 'Parsed) RecFieldsDotDot)
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 (GhcPass 'Parsed), Bag AuxBindSpec)
gen_Enum_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon}) = do
    -- See Note [Auxiliary binders]
    tag2con_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
loc TyCon
tycon
    maxtag_RDR  <- new_maxtag_rdr_name  loc tycon

    return ( method_binds tag2con_RDR maxtag_RDR
           , aux_binds    tag2con_RDR maxtag_RDR )
  where
    method_binds :: RdrName
-> RdrName
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
method_binds RdrName
tag2con_RDR RdrName
maxtag_RDR =
      [ RdrName -> RdrName -> LHsBind (GhcPass 'Parsed)
succ_enum      RdrName
tag2con_RDR RdrName
maxtag_RDR
      , RdrName -> LHsBind (GhcPass 'Parsed)
pred_enum      RdrName
tag2con_RDR
      , RdrName -> RdrName -> LHsBind (GhcPass 'Parsed)
to_enum        RdrName
tag2con_RDR RdrName
maxtag_RDR
      , RdrName -> RdrName -> LHsBind (GhcPass 'Parsed)
enum_from      RdrName
tag2con_RDR RdrName
maxtag_RDR -- [0 ..]
      , RdrName -> RdrName -> LHsBind (GhcPass 'Parsed)
enum_from_then RdrName
tag2con_RDR RdrName
maxtag_RDR -- [0, 1 ..]
      , LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
succ_enum RdrName
tag2con_RDR RdrName
maxtag_RDR
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
succ_RDR ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat]) (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
eq_RDR [IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
maxtag_RDR,
                               IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP (GhcPass 'Parsed)
RdrName
intDataCon_RDR [IdP (GhcPass 'Parsed)
RdrName
ah_RDR]])
             (String -> String -> String -> LHsExpr (GhcPass 'Parsed)
illegal_Expr String
"succ" String
occ_nm String
"tried to take `succ' of last tag in enumeration")
             (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
tag2con_RDR)
                    (IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
plus_RDR [IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP (GhcPass 'Parsed)
RdrName
intDataCon_RDR [IdP (GhcPass 'Parsed)
RdrName
ah_RDR],
                                        Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
1]))

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

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

    enum_from :: RdrName -> RdrName -> LHsBind (GhcPass 'Parsed)
enum_from RdrName
tag2con_RDR RdrName
maxtag_RDR
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFrom_RDR ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat]) (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
map_RDR
                [IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
tag2con_RDR,
                 LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
enum_from_to_Expr
                            (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP (GhcPass 'Parsed)
RdrName
intDataCon_RDR [IdP (GhcPass 'Parsed)
RdrName
ah_RDR])
                            (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
maxtag_RDR))]

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

    from_enum :: LHsBind (GhcPass 'Parsed)
from_enum
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
fromEnum_RDR ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat]) (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP (GhcPass 'Parsed)
RdrName
intDataCon_RDR [IdP (GhcPass 'Parsed)
RdrName
ah_RDR])

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

gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Bounded_binds :: SrcSpan
-> DerivInstTys -> (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
gen_Bounded_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon})
  | TyCon -> Bool
isEnumerationTyCon TyCon
tycon
  = ([ LHsBind (GhcPass 'Parsed)
min_bound_enum, LHsBind (GhcPass 'Parsed)
max_bound_enum ], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  | Bool
otherwise
  = Bool
-> ([GenLocated
       SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))],
    Bag AuxBindSpec)
-> ([GenLocated
       SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))],
    Bag AuxBindSpec)
forall a. HasCallStack => Bool -> a -> a
assert ([DataCon] -> Bool
forall a. [a] -> Bool
isSingleton [DataCon]
data_cons)
    ([ LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
min_bound_1con, LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
min_bound_enum = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
data_con_1_RDR)
    max_bound_enum :: LHsBind (GhcPass 'Parsed)
max_bound_enum = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
maxBound_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
data_con_N_RDR)

    data_con_1 :: DataCon
data_con_1     = [DataCon] -> DataCon
forall a. HasCallStack => [a] -> a
head [DataCon]
data_cons
    data_con_N :: DataCon
data_con_N     = [DataCon] -> DataCon
forall a. HasCallStack => [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 :: Int
arity          = DataCon -> Int
dataConSourceArity DataCon
data_con_1

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

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

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

For an enumeration type, e.g.,
\begin{verbatim}
    data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}
things go not too differently from @Enum@:
\begin{verbatim}
instance ... Ix (Foo ...) where
    range (a, b)
      = map tag2con_Foo [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 (GhcPass 'Parsed), Bag AuxBindSpec)
gen_Ix_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
tycon}) = do
    -- See Note [Auxiliary binders]
    tag2con_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
loc TyCon
tycon

    return $ if isEnumerationTyCon tycon
      then (enum_ixes tag2con_RDR, listToBag
                   [ DerivTag2Con tycon tag2con_RDR
                   ])
      else (single_con_ixes, emptyBag)
  where
    --------------------------------------------------------------
    enum_ixes :: RdrName
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
enum_ixes RdrName
tag2con_RDR =
      [ RdrName -> LHsBind (GhcPass 'Parsed)
enum_range   RdrName
tag2con_RDR
      , LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
enum_index
      , LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
enum_inRange
      ]

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

    enum_index :: LHsBind (GhcPass 'Parsed)
enum_index
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
                ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [Pat (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XAsPat (GhcPass 'Parsed)
-> LIdP (GhcPass 'Parsed)
-> LPat (GhcPass 'Parsed)
-> Pat (GhcPass 'Parsed)
forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat XAsPat (GhcPass 'Parsed)
EpToken "@"
forall a. NoAnn a => a
noAnn (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA RdrName
c_RDR)
                                  ([LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
nlWildPat] Boxity
Boxed)),
                                       LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
d_Pat]) (
           [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (
           [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
d_RDR, RdrName
dh_RDR)] (
           let
                rhs :: LHsExpr (GhcPass 'Parsed)
rhs = IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP (GhcPass 'Parsed)
RdrName
intDataCon_RDR [IdP (GhcPass 'Parsed)
RdrName
c_RDR]
           in
           LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase
             (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
dh_RDR) RdrName
minusInt_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
ah_RDR))
             [LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP (GhcPass 'Parsed)
RdrName
c_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
rhs]
           ))
        )

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

    --------------------------------------------------------------
    single_con_ixes :: [GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
single_con_ixes
      = [LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
single_con_range, LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
single_con_index, LHsBind (GhcPass 'Parsed)
GenLocated
  SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))
single_con_inRange]

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

    con_arity :: Int
con_arity    = DataCon -> Int
dataConSourceArity DataCon
data_con
    data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con

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

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

    --------------------------------------------------------------
    single_con_range :: LHsBind (GhcPass 'Parsed)
single_con_range
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR
          ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed]) (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
        HsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsDoFlavour
-> [ExprLStmt (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> HsExpr (GhcPass 'Parsed)
mkHsComp HsDoFlavour
ListComp [ExprLStmt (GhcPass 'Parsed)]
[GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts LHsExpr (GhcPass 'Parsed)
con_expr)
      where
        stmts :: [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts = String
-> (RdrName
    -> RdrName
    -> RdrName
    -> GenLocated
         SrcSpanAnnA
         (StmtLR
            (GhcPass 'Parsed)
            (GhcPass 'Parsed)
            (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b c d.
HasDebugCallStack =>
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_range" RdrName
-> RdrName
-> RdrName
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e}.
HasAnnotation e =>
RdrName
-> RdrName
-> RdrName
-> GenLocated
     e
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
mk_qual [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed

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

    ----------------
    single_con_index :: LHsBind (GhcPass 'Parsed)
single_con_index
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
                ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed,
                        [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
cs_needed])
        -- We need to reverse the order we consider the components in
        -- so that
        --     range (l,u) !! index (l,u) i == i   -- when i is in range
        -- (from http://haskell.org/onlinereport/ix.html) holds.
                ([(RdrName, RdrName, RdrName)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_index ([(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)]
forall a. [a] -> [a]
reverse ([(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)])
-> [(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)]
forall a b. (a -> b) -> a -> b
$ [RdrName]
-> [RdrName] -> [RdrName] -> [(RdrName, RdrName, RdrName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed))
      where
        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
        mk_index :: [(RdrName, RdrName, RdrName)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_index []        = Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0
        mk_index [(RdrName
l,RdrName
u,RdrName
i)] = RdrName
-> RdrName -> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass}.
(IdGhcP p ~ RdrName, NoAnn (XExplicitTuple (GhcPass p)),
 IsPass p) =>
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 (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (
                RdrName
-> RdrName -> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass}.
(IdGhcP p ~ RdrName, NoAnn (XExplicitTuple (GhcPass p)),
 IsPass p) =>
RdrName
-> RdrName
-> RdrName
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_one RdrName
l RdrName
u RdrName
i
            ) RdrName
plus_RDR (
                LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp (
                    (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
unsafeRangeSize_RDR)
                             ([IdP (GhcPass 'Parsed)]
-> XExplicitTuple (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [IdP (GhcPass 'Parsed)
RdrName
l,IdP (GhcPass 'Parsed)
RdrName
u] [AddEpAnn]
XExplicitTuple (GhcPass 'Parsed)
forall a. NoAnn a => a
noAnn))
                ) RdrName
times_RDR ([(RdrName, RdrName, RdrName)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
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. NoAnn a => 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 (GhcPass 'Parsed)
single_con_inRange
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR
                ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed,
                         [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
cs_needed]) (LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed) -> LHsBind (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$
          if Int
con_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
             -- If the product type has no fields, inRange is trivially true
             -- (see #12853).
             then LHsExpr (GhcPass 'Parsed)
true_Expr
             else (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
and_Expr (String
-> (RdrName
    -> RdrName -> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a b c d.
HasDebugCallStack =>
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_inRange" RdrName
-> RdrName -> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass}.
(IdGhcP p ~ RdrName, NoAnn (XExplicitTuple (GhcPass p)),
 IsPass p) =>
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. NoAnn a => 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 (GhcPass 'Parsed), 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})
  = ([LHsBind (GhcPass 'Parsed)
read_prec, LHsBind (GhcPass 'Parsed)
default_readlist, LHsBind (GhcPass 'Parsed)
default_readlistprec], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    -----------------------------------------------------------------------
    default_readlist :: LHsBind (GhcPass 'Parsed)
default_readlist
        = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
readList_RDR     (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
readListDefault_RDR)

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

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

    read_nullary_cons :: [LocatedA (HsExpr (GhcPass 'Parsed))]
read_nullary_cons
      = case [DataCon]
nullary_cons of
            []    -> []
            [DataCon
con] -> [HsDoFlavour
-> [ExprLStmt (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlHsDo (Maybe ModuleName -> HsDoFlavour
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing) (DataCon
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall {a} {e} {idL :: Pass}.
(NamedThing a, HasAnnotation e) =>
a
-> [GenLocated
      e
      (StmtLR
         (GhcPass idL)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
match_con DataCon
con [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [StmtLR
  (GhcPass 'Parsed)
  (GhcPass 'Parsed)
  (LocatedA (HsExpr (GhcPass 'Parsed)))
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (StmtLR
   (GhcPass 'Parsed)
   (GhcPass 'Parsed)
   (LocatedA (HsExpr (GhcPass 'Parsed)))
 -> GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (HsExpr (GhcPass 'Parsed)))
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt (DataCon -> [RdrName] -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {id :: Pass} {thing}.
(IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing -> [RdrName] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr DataCon
con [])])]
            [DataCon]
_     -> [LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
choose_RDR)
                              ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList ((DataCon -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [DataCon] -> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass} {thing}.
(IdGhcP p ~ RdrName, NamedThing thing,
 NoAnn (XExplicitTuple (GhcPass p)), IsPass p) =>
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
-> [GenLocated
      e
      (StmtLR
         (GhcPass idL)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
match_con a
con | String -> Bool
isSym String
con_str = [String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
con_str]
                  | Bool
otherwise     = String
-> [GenLocated
      e
      (StmtLR
         (GhcPass idL)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> [GenLocated
      e
      (StmtLR
         (GhcPass idL)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
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 -> [RdrName] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall {id :: Pass} {thing}.
(IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing -> [RdrName] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr thing
con []] XExplicitTuple (GhcPass p)
forall a. NoAnn a => a
noAnn

    read_non_nullary_con :: DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
read_non_nullary_con DataCon
data_con
      | Bool
is_infix  = Integer
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_parser Integer
infix_prec  [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
infix_stmts  LocatedA (HsExpr (GhcPass 'Parsed))
body
      | Bool
is_record = Integer
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_parser Integer
record_prec [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
record_stmts LocatedA (HsExpr (GhcPass 'Parsed))
body
--              Using these two lines instead allows the derived
--              read for infix and record bindings to read the prefix form
--      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)
--      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
      | Bool
otherwise = LocatedA (HsExpr (GhcPass 'Parsed))
prefix_parser
      where
        body :: LocatedA (HsExpr (GhcPass 'Parsed))
body = DataCon -> [RdrName] -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {id :: Pass} {thing}.
(IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing -> [RdrName] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr DataCon
data_con [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 (GhcPass 'Parsed))
prefix_parser = Integer
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_parser Integer
prefix_prec [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
prefix_stmts LocatedA (HsExpr (GhcPass 'Parsed))
body

        read_prefix_con :: [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_prefix_con
            | String -> Bool
isSym String
con_str = [String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"(", String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
con_str, String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
")"]
            | Bool
otherwise     = String
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> [GenLocated
      e
      (StmtLR
         (GhcPass idL)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
ident_h_pat String
con_str

        read_infix_con :: [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_infix_con
            | String -> Bool
isSym String
con_str = [String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
con_str]
            | Bool
otherwise     = [String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"`"] [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ String
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> [GenLocated
      e
      (StmtLR
         (GhcPass idL)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
ident_h_pat String
con_str [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"`"]

        prefix_stmts :: [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
prefix_stmts            -- T a b c
          = [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_prefix_con [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_args

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

        record_stmts :: [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
record_stmts            -- T { f1 = a, f2 = b }
          = [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_prefix_con
            [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"{"]
            [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [[GenLocated
    SrcSpanAnnA
    (StmtLR
       (GhcPass 'Parsed)
       (GhcPass 'Parsed)
       (LocatedA (HsExpr (GhcPass 'Parsed))))]]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [[GenLocated
       SrcSpanAnnA
       (StmtLR
          (GhcPass 'Parsed)
          (GhcPass 'Parsed)
          (LocatedA (HsExpr (GhcPass 'Parsed))))]]
-> [[GenLocated
       SrcSpanAnnA
       (StmtLR
          (GhcPass 'Parsed)
          (GhcPass 'Parsed)
          (LocatedA (HsExpr (GhcPass 'Parsed))))]]
forall a. a -> [a] -> [a]
intersperse [String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
","] [[GenLocated
    SrcSpanAnnA
    (StmtLR
       (GhcPass 'Parsed)
       (GhcPass 'Parsed)
       (LocatedA (HsExpr (GhcPass 'Parsed))))]]
field_stmts)
            [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [String
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"}"]

        field_stmts :: [[GenLocated
    SrcSpanAnnA
    (StmtLR
       (GhcPass 'Parsed)
       (GhcPass 'Parsed)
       (LocatedA (HsExpr (GhcPass 'Parsed))))]]
field_stmts  = String
-> (FastString
    -> RdrName
    -> [GenLocated
          SrcSpanAnnA
          (StmtLR
             (GhcPass 'Parsed)
             (GhcPass 'Parsed)
             (LocatedA (HsExpr (GhcPass 'Parsed))))])
-> [FastString]
-> [RdrName]
-> [[GenLocated
       SrcSpanAnnA
       (StmtLR
          (GhcPass 'Parsed)
          (GhcPass 'Parsed)
          (LocatedA (HsExpr (GhcPass 'Parsed))))]]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"lbl_stmts" FastString
-> RdrName
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall {e}.
HasAnnotation e =>
FastString
-> RdrName
-> [GenLocated
      e
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_field [FastString]
labels [RdrName]
as_needed

        con_arity :: Int
con_arity    = DataCon -> Int
dataConSourceArity DataCon
data_con
        labels :: [FastString]
labels       = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString)
-> (FieldLabel -> FieldLabelString) -> FieldLabel -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FieldLabelString
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] -> Int -> Bool
forall a. [a] -> Int -> Bool
`lengthExceeds` Int
0
        as_needed :: [RdrName]
as_needed    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
        read_args :: [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_args    = String
-> (RdrName
    -> Type
    -> GenLocated
         SrcSpanAnnA
         (StmtLR
            (GhcPass 'Parsed)
            (GhcPass 'Parsed)
            (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> [RdrName]
-> [Type]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a b c.
HasDebugCallStack =>
String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Read_binds" RdrName
-> Type
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e}.
HasAnnotation e =>
RdrName
-> Type
-> GenLocated
     e
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
read_arg [RdrName]
as_needed (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit)
        (GenLocated
  SrcSpanAnnA
  (StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (HsExpr (GhcPass 'Parsed))))
read_a1:GenLocated
  SrcSpanAnnA
  (StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (HsExpr (GhcPass 'Parsed))))
read_a2:[GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
_) = [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_args

        prefix_prec :: Integer
prefix_prec = Integer
appPrecedence
        infix_prec :: Integer
infix_prec  = (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
dc_nm
        record_prec :: Integer
record_prec = Integer
appPrecedence Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 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 (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed)) -> LHsExpr (GhcPass 'Parsed)
mk_alt LocatedA (HsExpr (GhcPass 'Parsed))
e1 LocatedA (HsExpr (GhcPass 'Parsed))
e2       = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
e1 RdrName
alt_RDR LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
e2                         -- e1 +++ e2
    mk_parser :: Integer
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
mk_parser Integer
p [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
ss LocatedA (HsExpr (GhcPass 'Parsed))
b   = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
prec_RDR [Integer -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
p                -- prec p (do { ss ; b })
                                           , HsDoFlavour
-> [ExprLStmt (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlHsDo (Maybe ModuleName -> HsDoFlavour
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing) ([GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
ss [GenLocated
   SrcSpanAnnA
   (StmtLR
      (GhcPass 'Parsed)
      (GhcPass 'Parsed)
      (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
-> [GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
forall a. [a] -> [a] -> [a]
++ [StmtLR
  (GhcPass 'Parsed)
  (GhcPass 'Parsed)
  (LocatedA (HsExpr (GhcPass 'Parsed)))
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (StmtLR
   (GhcPass 'Parsed)
   (GhcPass 'Parsed)
   (LocatedA (HsExpr (GhcPass 'Parsed)))
 -> GenLocated
      SrcSpanAnnA
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed)))))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (HsExpr (GhcPass 'Parsed)))
-> GenLocated
     SrcSpanAnnA
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall a b. (a -> b) -> a -> b
$ LocatedA (HsExpr (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
     (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt LocatedA (HsExpr (GhcPass 'Parsed))
b])]
    con_app :: thing -> [RdrName] -> LHsExpr (GhcPass p)
con_app thing
con [RdrName]
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) [IdP (GhcPass p)]
[RdrName]
as                -- con as
    result_expr :: thing -> [RdrName] -> LHsExpr (GhcPass id)
result_expr thing
con [RdrName]
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 -> [RdrName] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
forall {id :: Pass} {thing}.
(IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing -> [RdrName] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
con_app thing
con [RdrName]
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
-> [GenLocated
      e
      (StmtLR
         (GhcPass idL)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
ident_h_pat String
s | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [ String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
ident_pat String
ss, String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
"#" ]
                  | Bool
otherwise                    = [ String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall {e} {idL :: Pass}.
HasAnnotation e =>
String
-> GenLocated
     e
     (StmtLR
        (GhcPass idL)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
ident_pat String
s ]

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

    data_con_str :: a -> String
data_con_str a
con = OccName -> String
occNameString (a -> OccName
forall a. NamedThing a => a -> OccName
getOccName a
con)

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

    -- When reading field labels we might encounter
    --      a  = 3
    --      _a = 3
    -- or   (#) = 4
    -- Note the parens!
    read_field :: FastString
-> RdrName
-> [GenLocated
      e
      (StmtLR
         (GhcPass 'Parsed)
         (GhcPass 'Parsed)
         (LocatedA (HsExpr (GhcPass 'Parsed))))]
read_field FastString
lbl RdrName
a =
        [StmtLR
  (GhcPass 'Parsed)
  (GhcPass 'Parsed)
  (LocatedA (HsExpr (GhcPass 'Parsed)))
-> GenLocated
     e
     (StmtLR
        (GhcPass 'Parsed)
        (GhcPass 'Parsed)
        (LocatedA (HsExpr (GhcPass 'Parsed))))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA
          ([AddEpAnn]
-> LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (bodyR :: * -> *).
[AddEpAnn]
-> LPat (GhcPass 'Parsed)
-> LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
     (GhcPass 'Parsed)
     (GhcPass 'Parsed)
     (LocatedA (bodyR (GhcPass 'Parsed)))
mkPsBindStmt [AddEpAnn]
forall a. NoAnn a => a
noAnn
            (IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP (GhcPass 'Parsed)
RdrName
a)
            (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
              LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
read_field
              (IdP (GhcPass 'Parsed)
-> [IdP (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps IdP (GhcPass 'Parsed)
RdrName
reset_RDR [IdP (GhcPass 'Parsed)
RdrName
readPrec_RDR])
            )
          )
        ]
        where
          lbl_str :: String
lbl_str = FastString -> String
unpackFS FastString
lbl
          mk_read_field :: IdGhcP p -> FastString -> LHsExpr (GhcPass p)
mk_read_field IdGhcP p
read_field_rdr FastString
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 IdP (GhcPass p)
IdGhcP p
read_field_rdr [HsLit (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass p)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringFS FastString
lbl)]
          read_field :: LocatedA (HsExpr (GhcPass 'Parsed))
read_field
              | String -> Bool
isSym String
lbl_str
              = IdGhcP 'Parsed -> FastString -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass} {a}.
(Anno (IdGhcP p) ~ EpAnn a, NoAnn a, IsPass p) =>
IdGhcP p
-> FastString -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field RdrName
IdGhcP 'Parsed
readSymField_RDR FastString
lbl
              | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
lbl_str -- #14918
              = IdGhcP 'Parsed -> FastString -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass} {a}.
(Anno (IdGhcP p) ~ EpAnn a, NoAnn a, IsPass p) =>
IdGhcP p
-> FastString -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field RdrName
IdGhcP 'Parsed
readFieldHash_RDR (String -> FastString
mkFastString String
ss)
              | Bool
otherwise
              = IdGhcP 'Parsed -> FastString -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass} {a}.
(Anno (IdGhcP p) ~ EpAnn a, NoAnn a, IsPass p) =>
IdGhcP p
-> FastString -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field RdrName
IdGhcP 'Parsed
readField_RDR FastString
lbl

{-
************************************************************************
*                                                                      *
        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 (GhcPass 'Parsed), 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 })
  = ([LHsBind (GhcPass 'Parsed)
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 (GhcPass 'Parsed)
shows_prec = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
2 SrcSpan
loc RdrName
showsPrec_RDR LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a. a -> a
id ((DataCon
 -> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
     LocatedA (HsExpr (GhcPass 'Parsed))))
-> [DataCon]
-> [([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
     LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    LocatedA (HsExpr (GhcPass 'Parsed)))
pats_etc [DataCon]
data_cons)
    comma_space :: LHsExpr (GhcPass 'Parsed)
comma_space = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
showCommaSpace_RDR

    pats_etc :: DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    LocatedA (HsExpr (GhcPass 'Parsed)))
pats_etc DataCon
data_con
      | Bool
nullary_con =  -- skip the showParen junk...
         Bool
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    LocatedA (HsExpr (GhcPass 'Parsed)))
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    LocatedA (HsExpr (GhcPass 'Parsed)))
forall a. HasCallStack => Bool -> a -> a
assert ([RdrName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RdrName]
bs_needed)
         ([LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
nlWildPat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
con_pat], String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
op_con_str)
      | Bool
otherwise   =
         ([LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
a_Pat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
con_pat],
          LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
showParen_Expr (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
a_Expr RdrName
ge_RDR (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit
                         (XHsInt (GhcPass 'Parsed) -> IntegralLit -> HsLit (GhcPass 'Parsed)
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt XHsInt (GhcPass 'Parsed)
NoExtField
noExtField (Integer -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
con_prec_plus_one))))
                         (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
show_thingies)))
        where
             data_con_RDR :: RdrName
data_con_RDR  = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
             con_arity :: Int
con_arity     = DataCon -> Int
dataConSourceArity DataCon
data_con
             bs_needed :: [RdrName]
bs_needed     = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
bs_RDRs
             arg_tys :: [Type]
arg_tys       = DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit -- Correspond 1-1 with bs_needed
             con_pat :: LPat (GhcPass 'Parsed)
con_pat       = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
             nullary_con :: Bool
nullary_con   = Int
con_arity Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
             labels :: [FastString]
labels        = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map (FieldLabelString -> FastString
field_label (FieldLabelString -> FastString)
-> (FieldLabel -> FieldLabelString) -> FieldLabel -> FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FieldLabelString
flLabel) ([FieldLabel] -> [FastString]) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
             lab_fields :: Int
lab_fields    = [FastString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [FastString]
labels
             record_syntax :: Bool
record_syntax = Int
lab_fields Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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 (GhcPass 'Parsed))]
show_thingies
                | Bool
is_infix      = [LocatedA (HsExpr (GhcPass 'Parsed))
show_arg1, String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
backquote_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "), LocatedA (HsExpr (GhcPass 'Parsed))
show_arg2]
                | Bool
record_syntax = String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {") LocatedA (HsExpr (GhcPass 'Parsed))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. a -> [a] -> [a]
:
                                  [LocatedA (HsExpr (GhcPass 'Parsed))]
show_record_args [LocatedA (HsExpr (GhcPass 'Parsed))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. [a] -> [a] -> [a]
++ [String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
"}"]
                | Bool
otherwise     = String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") LocatedA (HsExpr (GhcPass 'Parsed))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. a -> [a] -> [a]
: [LocatedA (HsExpr (GhcPass 'Parsed))]
show_prefix_args

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

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

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

             show_arg :: RdrName -> Type -> LHsExpr GhcPs
             show_arg :: RdrName -> Type -> LHsExpr (GhcPass 'Parsed)
show_arg RdrName
b Type
arg_ty
                 | HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
                 -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
                 = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
compose_RDR
                        [LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_shows_app LHsExpr (GhcPass 'Parsed)
boxed_arg, String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
postfixMod]
                 | Bool
otherwise
                 = Integer -> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_showsPrec_app Integer
arg_prec LHsExpr (GhcPass 'Parsed)
arg
               where
                 arg :: LHsExpr (GhcPass 'Parsed)
arg        = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
b
                 boxed_arg :: LHsExpr (GhcPass 'Parsed)
boxed_arg  = String
-> LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
box String
"Show" LHsExpr (GhcPass 'Parsed)
arg Type
arg_ty
                 postfixMod :: String
postfixMod = String -> [(Type, String)] -> Type -> String
forall a. HasDebugCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
"Show" [(Type, String)]
postfixModTbl Type
arg_ty

                -- 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 (GhcPass 'Parsed)
mk_showString_app String
str = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
showString_RDR) (HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
str))

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

-- | shows :: Show a => a -> ShowS
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_shows_app LHsExpr (GhcPass 'Parsed)
x = LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
shows_RDR) LHsExpr (GhcPass 'Parsed)
x

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

appPrecedence :: Integer
appPrecedence :: Integer
appPrecedence = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
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 Int
x FixityDirection
_assoc -> Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
          -- NB: the Report says that associativity is not taken
          --     into account for either Read or Show; hence we
          --     ignore associativity here

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

From the data type

  data T a b = T1 a b | T2

we generate

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

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

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

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

    dataTypeOf _ = $dT

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

gen_Data_binds :: SrcSpan
               -> DerivInstTys
               -> TcM (LHsBinds GhcPs,  -- The method bindings
                       Bag AuxBindSpec) -- Auxiliary bindings
gen_Data_binds :: SrcSpan
-> DerivInstTys
-> TcM (LHsBinds (GhcPass 'Parsed), Bag AuxBindSpec)
gen_Data_binds SrcSpan
loc (DerivInstTys{dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc})
  = do { -- See Note [Auxiliary binders]
         dataT_RDR  <- SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name SrcSpan
loc TyCon
rep_tc
       ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons

       ; pure ( [ gfoldl_bind, gunfold_bind
                , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]
                ++ gcast_binds
                          -- Auxiliary definitions: the data type and constructors
              , listToBag
                  ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs
                  : zipWith (\DataCon
data_con RdrName
dataC_RDR ->
                               DataCon -> RdrName -> RdrName -> AuxBindSpec
DerivDataConstr DataCon
data_con RdrName
dataC_RDR RdrName
dataT_RDR)
                            data_cons dataC_RDRs )
              ) }
  where
    data_cons :: [DataCon]
data_cons  = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
    n_cons :: Int
n_cons     = [DataCon] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
data_cons

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

    gfoldl_eqn :: DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    LocatedA (HsExpr (GhcPass 'Parsed)))
gfoldl_eqn DataCon
con
      = ([IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP (GhcPass 'Parsed)
RdrName
k_RDR, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
z_Pat, RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
con_name [RdrName]
as_needed],
                   (LocatedA (HsExpr (GhcPass 'Parsed))
 -> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> [RdrName]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LocatedA (HsExpr (GhcPass 'Parsed))
-> RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
mk_k_app (LHsExpr (GhcPass 'Parsed)
z_Expr LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass}.
(XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
 ~ Origin,
 IdGhcP p ~ RdrName, IsPass p) =>
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 = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
con) [RdrName]
as_RDRs
                     mk_k_app :: LocatedA (HsExpr (GhcPass 'Parsed))
-> RdrName -> LHsExpr (GhcPass 'Parsed)
mk_k_app LocatedA (HsExpr (GhcPass 'Parsed))
e RdrName
v = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
e IdP (GhcPass 'Parsed)
RdrName
k_RDR (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
v))

        ------------ gunfold
    gunfold_bind :: LHsBind (GhcPass 'Parsed)
gunfold_bind = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc
                     RdrName
gunfold_RDR
                     ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
k_Pat, LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
z_Pat, if Int
n_cons Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
nlWildPat else LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
c_Pat])
                     LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
gunfold_rhs

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

    gunfold_alt :: DataCon
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
gunfold_alt DataCon
dc = LPat (GhcPass 'Parsed)
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn 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 (GhcPass 'Parsed)
mk_unfold_pat DataCon
dc) (DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
mk_unfold_rhs DataCon
dc)
    mk_unfold_rhs :: DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
mk_unfold_rhs DataCon
dc = (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
                           (LHsExpr (GhcPass 'Parsed)
z_Expr LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
forall {p :: Pass}.
(XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
 ~ Origin,
 IdGhcP p ~ RdrName, IsPass p) =>
DataCon -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
eta_expand_data_con DataCon
dc))
                           (Int
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a. Int -> a -> [a]
replicate (DataCon -> Int
dataConSourceArity DataCon
dc) (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
k_RDR))

    eta_expand_data_con :: DataCon -> LHsExpr (GhcPass p)
eta_expand_data_con DataCon
dc =
        LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin) =>
LocatedE [LPat (GhcPass p)]
-> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam ([GenLocated SrcSpanAnnA (Pat (GhcPass p))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass p))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
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 IdP (GhcPass p) -> LPat (GhcPass p)
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 IdP (GhcPass p) -> LHsExpr (GhcPass p)
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 = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
dc) [RdrName]
as_RDRs


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

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

        ------------ dataTypeOf
    dataTypeOf_bind :: RdrName -> LHsBind (GhcPass 'Parsed)
dataTypeOf_bind RdrName
dataT_RDR
      = SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind
          SrcSpan
loc
          RdrName
dataTypeOf_RDR
          ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
nlWildPat])
          (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
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 :: [GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
gcast_binds | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqKind` Type
kind1 = RdrName
-> RdrName
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
mk_gcast RdrName
dataCast1_RDR RdrName
gcast1_RDR
                | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqKind` Type
kind2 = RdrName
-> RdrName
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
mk_gcast RdrName
dataCast2_RDR RdrName
gcast2_RDR
                | Bool
otherwise                 = []
    mk_gcast :: RdrName
-> RdrName
-> [GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
mk_gcast RdrName
dataCast_RDR RdrName
gcast_RDR
      = [SrcSpan
-> RdrName
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
dataCast_RDR ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA [IdP (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat IdP (GhcPass 'Parsed)
RdrName
f_RDR])
                                 (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
gcast_RDR LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
f_RDR)]


kind1, kind2 :: Kind
kind1 :: Type
kind1 = Type
typeToTypeKind
kind2 :: Type
kind2 = Type
liftedTypeKind HasDebugCallStack => Type -> Type -> Type
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,
    int8DataCon_RDR, int16DataCon_RDR, int32DataCon_RDR, int64DataCon_RDR,
    word8DataCon_RDR, word16DataCon_RDR, word32DataCon_RDR, word64DataCon_RDR
    :: RdrName
gfoldl_RDR :: RdrName
gfoldl_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"gfoldl")
gunfold_RDR :: RdrName
gunfold_RDR    = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"gunfold")
toConstr_RDR :: RdrName
toConstr_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"toConstr")
dataTypeOf_RDR :: RdrName
dataTypeOf_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"dataTypeOf")
dataCast1_RDR :: RdrName
dataCast1_RDR  = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"dataCast1")
dataCast2_RDR :: RdrName
dataCast2_RDR  = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"dataCast2")
gcast1_RDR :: RdrName
gcast1_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_TYPEABLE (String -> FastString
fsLit String
"gcast1")
gcast2_RDR :: RdrName
gcast2_RDR     = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_TYPEABLE (String -> FastString
fsLit String
"gcast2")
mkConstrTag_RDR :: RdrName
mkConstrTag_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"mkConstrTag")
constr_RDR :: RdrName
constr_RDR     = Module -> FastString -> RdrName
tcQual_RDR   Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"Constr")
mkDataType_RDR :: RdrName
mkDataType_RDR = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"mkDataType")
dataType_RDR :: RdrName
dataType_RDR   = Module -> FastString -> RdrName
tcQual_RDR   Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"DataType")
conIndex_RDR :: RdrName
conIndex_RDR   = Module -> FastString -> RdrName
varQual_RDR  Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"constrIndex")
prefix_RDR :: RdrName
prefix_RDR     = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_DATA_DATA (String -> FastString
fsLit String
"Prefix")
infix_RDR :: RdrName
infix_RDR      = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_DATA_DATA (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
">=##")

int8DataCon_RDR :: RdrName
int8DataCon_RDR   = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_INT (String -> FastString
fsLit String
"I8#")
int16DataCon_RDR :: RdrName
int16DataCon_RDR  = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_INT (String -> FastString
fsLit String
"I16#")
int32DataCon_RDR :: RdrName
int32DataCon_RDR  = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_INT (String -> FastString
fsLit String
"I32#")
int64DataCon_RDR :: RdrName
int64DataCon_RDR  = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_INT (String -> FastString
fsLit String
"I64#")
word8DataCon_RDR :: RdrName
word8DataCon_RDR  = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_WORD (String -> FastString
fsLit String
"W8#")
word16DataCon_RDR :: RdrName
word16DataCon_RDR = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_WORD (String -> FastString
fsLit String
"W16#")
word32DataCon_RDR :: RdrName
word32DataCon_RDR = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_WORD (String -> FastString
fsLit String
"W32#")
word64DataCon_RDR :: RdrName
word64DataCon_RDR = Module -> FastString -> RdrName
dataQual_RDR Module
gHC_INTERNAL_WORD (String -> FastString
fsLit String
"W64#")
{-
************************************************************************
*                                                                      *
                        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 (GhcPass 'Parsed), 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 }) =
  ([LHsBind (GhcPass 'Parsed)
lift_bind, LHsBind (GhcPass 'Parsed)
liftTyped_bind], Bag AuxBindSpec
forall a. Bag a
emptyBag)
  where
    lift_bind :: LHsBind (GhcPass 'Parsed)
lift_bind      = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
1 SrcSpan
loc RdrName
lift_RDR (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
pure_Expr)
                                 ((DataCon
 -> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
     LocatedA (HsExpr (GhcPass 'Parsed))))
-> [DataCon]
-> [([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
     LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b. (a -> b) -> [a] -> [b]
map ((LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed))
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> HsExpr (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    LocatedA (HsExpr (GhcPass 'Parsed)))
forall {e} {a}.
HasAnnotation e =>
(LocatedA (HsExpr (GhcPass 'Parsed)) -> a)
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> HsExpr (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    GenLocated e a)
pats_etc LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed)
mk_untyped_bracket LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed)
mk_usplice Name
liftName) [DataCon]
data_cons)
    liftTyped_bind :: LHsBind (GhcPass 'Parsed)
liftTyped_bind = Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
1 SrcSpan
loc RdrName
liftTyped_RDR (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
unsafeCodeCoerce_Expr (LocatedA (HsExpr (GhcPass 'Parsed))
 -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
pure_Expr)
                                 ((DataCon
 -> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
     LocatedA (HsExpr (GhcPass 'Parsed))))
-> [DataCon]
-> [([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
     LocatedA (HsExpr (GhcPass 'Parsed)))]
forall a b. (a -> b) -> [a] -> [b]
map ((LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed))
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> HsExpr (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    LocatedA (HsExpr (GhcPass 'Parsed)))
forall {e} {a}.
HasAnnotation e =>
(LocatedA (HsExpr (GhcPass 'Parsed)) -> a)
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> HsExpr (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    GenLocated e a)
pats_etc LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed)
mk_typed_bracket LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed)
mk_tsplice Name
liftTypedName) [DataCon]
data_cons)

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

    mk_tsplice :: LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_tsplice = XTypedSplice (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
forall p. XTypedSplice p -> LHsExpr p -> HsExpr p
HsTypedSplice []
    mk_usplice :: LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_usplice = XUntypedSplice (GhcPass 'Parsed)
-> HsUntypedSplice (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
forall p. XUntypedSplice p -> HsUntypedSplice p -> HsExpr p
HsUntypedSplice XUntypedSplice (GhcPass 'Parsed)
NoExtField
noExtField (HsUntypedSplice (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed))
-> (LHsExpr (GhcPass 'Parsed) -> HsUntypedSplice (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
-> HsExpr (GhcPass 'Parsed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XUntypedSpliceExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsUntypedSplice (GhcPass 'Parsed)
forall id.
XUntypedSpliceExpr id -> LHsExpr id -> HsUntypedSplice id
HsUntypedSpliceExpr XUntypedSpliceExpr (GhcPass 'Parsed)
forall a. NoAnn a => a
noAnn
    data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args

    pats_etc :: (LocatedA (HsExpr (GhcPass 'Parsed)) -> a)
-> (LocatedA (HsExpr (GhcPass 'Parsed))
    -> HsExpr (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
    GenLocated e a)
pats_etc LocatedA (HsExpr (GhcPass 'Parsed)) -> a
mk_bracket LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed)
mk_splice Name
lift_name DataCon
data_con
      = ([LPat (GhcPass 'Parsed)
GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))
con_pat], GenLocated e a
lift_Expr)
       where
            con_pat :: LPat (GhcPass 'Parsed)
con_pat      = RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
            data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
            con_arity :: Int
con_arity    = DataCon -> Int
dataConSourceArity DataCon
data_con
            as_needed :: [RdrName]
as_needed    = Int -> [RdrName] -> [RdrName]
forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
            lift_Expr :: GenLocated e a
lift_Expr    = a -> GenLocated e a
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (LocatedA (HsExpr (GhcPass 'Parsed)) -> a
mk_bracket LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
br_body)
            br_body :: LHsExpr (GhcPass 'Parsed)
br_body      = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
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 (GhcPass 'Parsed)))
-> [RdrName] -> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> LHsExpr (GhcPass 'Parsed)
RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
lift_var [RdrName]
as_needed)

            lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
            lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
lift_var RdrName
x   = HsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (LocatedA (HsExpr (GhcPass 'Parsed)) -> HsExpr (GhcPass 'Parsed)
mk_splice (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass).
IsPass p =>
LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
nlHsPar (RdrName -> LHsExpr (GhcPass 'Parsed)
mk_lift_expr RdrName
x)))

            mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)
            mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)
mk_lift_expr RdrName
x = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps (Name -> RdrName
Exact Name
lift_name) [IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
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.Equality.

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
-> [Id]
-> [Type]
-> Type
-> (LHsBinds (GhcPass 'Parsed), [LSig (GhcPass 'Parsed)])
gen_Newtype_binds SrcSpan
loc' Class
cls [Id]
inst_tvs [Type]
inst_tys Type
rhs_ty
  = (LHsBinds (GhcPass 'Parsed)
[GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
binds, [LSig (GhcPass 'Parsed)]
[GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs)
  where
    ([GenLocated
   SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
binds, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs) = (Id
 -> (GenLocated
       SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)),
     GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))))
-> [Id]
-> ([GenLocated
       SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))],
    [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip Id -> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
Id
-> (GenLocated
      SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)),
    GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed)))
mk_bind_and_sig (Class -> [Id]
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 :: SrcSpanAnnN
locn = SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc'
    loca :: SrcSpanAnnA
loca = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
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 :: Id -> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
mk_bind_and_sig Id
meth_id
      = ( -- The derived binding, e.g.,
          --
          --   op = coerce @(a -> [<rep-ty>] -> c -> Int)
          --               @(a -> [T x]      -> c -> Int)
          --               op
          GenLocated SrcSpanAnnN RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind GenLocated SrcSpanAnnN RdrName
loc_meth_RDR [HsMatchContext (LIdP (NoGhcTc (GhcPass 'Parsed)))
-> LocatedE [LPat (GhcPass 'Parsed)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ SrcSpanAnnA,
 Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
 ~ EpAnn NoEpAnns) =>
HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> LocatedE [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
                                        (GenLocated SrcSpanAnnN RdrName
-> HsMatchContext (GenLocated SrcSpanAnnN RdrName)
forall fn. fn -> HsMatchContext fn
mkPrefixFunRhs GenLocated SrcSpanAnnN RdrName
loc_meth_RDR)
                                        ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
-> GenLocated
     EpaLocation [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA []) LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (Sig (GhcPass 'Parsed)
 -> GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed)))
-> Sig (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ XClassOpSig (GhcPass 'Parsed)
-> Bool
-> [LIdP (GhcPass 'Parsed)]
-> LHsSigType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig XClassOpSig (GhcPass 'Parsed)
forall a. NoAnn a => a
noAnn Bool
False [LIdP (GhcPass 'Parsed)
GenLocated SrcSpanAnnN RdrName
loc_meth_RDR]
                 (LHsSigType (GhcPass 'Parsed) -> Sig (GhcPass 'Parsed))
-> LHsSigType (GhcPass 'Parsed) -> Sig (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ SrcSpanAnnA
-> HsSigType (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (HsSigType (GhcPass 'Parsed)
 -> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)))
-> HsSigType (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> LHsType (GhcPass 'Parsed)
-> HsSigType (GhcPass 'Parsed)
mkHsExplicitSigType EpAnnForallTy
forall a. NoAnn a => a
noAnn
                              ((VarBndr Id Specificity
 -> GenLocated
      SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed)))
-> [VarBndr Id Specificity]
-> [GenLocated
      SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map VarBndr Id Specificity
-> LHsTyVarBndr Specificity (GhcPass 'Parsed)
VarBndr Id Specificity
-> GenLocated
     SrcSpanAnnA (HsTyVarBndr Specificity (GhcPass 'Parsed))
forall flag. VarBndr Id flag -> LHsTyVarBndr flag (GhcPass 'Parsed)
mk_hs_tvb [VarBndr Id Specificity]
to_tvbs)
                              (Type -> LHsType (GhcPass 'Parsed)
nlHsCoreTy Type
to_rho)
        )
      where
        Pair Type
from_ty Type
to_ty = Class -> [Id] -> [Type] -> Type -> Id -> Pair Type
mkCoerceClassMethEqn Class
cls [Id]
inst_tvs [Type]
inst_tys Type
rhs_ty Id
meth_id
        ([Id]
_, [Type]
_, Type
from_tau)  = Type -> ([Id], [Type], Type)
tcSplitSigmaTy Type
from_ty
        ([VarBndr Id Specificity]
to_tvbs, Type
to_rho) = Type -> ([VarBndr Id 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 :: forall flag. VarBndr Id flag -> LHsTyVarBndr flag (GhcPass 'Parsed)
mk_hs_tvb (Bndr Id
tv flag
flag) = HsTyVarBndr flag (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsTyVarBndr flag (GhcPass 'Parsed)
 -> GenLocated SrcSpanAnnA (HsTyVarBndr flag (GhcPass 'Parsed)))
-> HsTyVarBndr flag (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsTyVarBndr flag (GhcPass 'Parsed))
forall a b. (a -> b) -> a -> b
$ XKindedTyVar (GhcPass 'Parsed)
-> flag
-> LIdP (GhcPass 'Parsed)
-> LHsType (GhcPass 'Parsed)
-> HsTyVarBndr flag (GhcPass 'Parsed)
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar XKindedTyVar (GhcPass 'Parsed)
forall a. NoAnn a => a
noAnn
                                                        flag
flag
                                                        (RdrName -> GenLocated SrcSpanAnnN RdrName
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Id
tv))
                                                        (Type -> LHsType (GhcPass 'Parsed)
nlHsCoreTy (Id -> Type
tyVarKind Id
tv))

        meth_RDR :: RdrName
meth_RDR = Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Id
meth_id
        loc_meth_RDR :: GenLocated SrcSpanAnnN RdrName
loc_meth_RDR = SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn RdrName
meth_RDR

        rhs_expr :: LHsExpr (GhcPass 'Parsed)
rhs_expr = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (Id -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName Id
coerceId)
                                      LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
`nlHsAppType`     Type
from_tau
                                      LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
`nlHsAppType`     Type
to_tau
                                      LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp`         LHsExpr (GhcPass 'Parsed)
LocatedA (HsExpr (GhcPass 'Parsed))
meth_app

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

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 -> [Id] -> [Type] -> Type -> TcM [FamInst]
gen_Newtype_fam_insts SrcSpan
loc' Class
cls [Id]
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 :: SrcSpanAnnN
locn      = SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc'
    cls_tvs :: [Id]
cls_tvs   = Class -> [Id]
classTyVars Class
cls
    in_scope :: InScopeSet
in_scope  = [Id] -> InScopeSet
mkInScopeSetList [Id]
inst_tvs
    lhs_env :: TvSubstEnv
lhs_env   = [Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs [Type]
inst_tys
    lhs_subst :: Subst
lhs_subst = InScopeSet -> TvSubstEnv -> Subst
mkTvSubst InScopeSet
in_scope TvSubstEnv
lhs_env
    rhs_env :: TvSubstEnv
rhs_env   = [Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs [Type]
underlying_inst_tys
    rhs_subst :: Subst
rhs_subst = InScopeSet -> TvSubstEnv -> Subst
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
        rep_tc_name <- LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (SrcSpanAnnN -> Name -> LocatedN Name
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn (TyCon -> Name
tyConName TyCon
fam_tc))
                                           [Type]
rep_lhs_tys
        let axiom = Role
-> Name
-> [Id]
-> [Id]
-> [Id]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_tc_name [Id]
rep_tvs' [] [Id]
rep_cvs'
                                    TyCon
fam_tc [Type]
rep_lhs_tys Type
rep_rhs_ty
        checkFamPatBinders fam_tc (rep_tvs' ++ rep_cvs') emptyVarSet rep_lhs_tys rep_rhs_ty
        -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv
        checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
        newFamInst SynFamilyInst axiom
      where
        fam_tvs :: [Id]
fam_tvs     = TyCon -> [Id]
tyConTyVars TyCon
fam_tc
        (Subst
_, [Type]
rep_lhs_tys) = Subst -> [Id] -> (Subst, [Type])
substATBndrs Subst
lhs_subst [Id]
fam_tvs
        (Subst
_, [Type]
rep_rhs_tys) = Subst -> [Id] -> (Subst, [Type])
substATBndrs Subst
rhs_subst [Id]
fam_tvs
        rep_rhs_ty :: Type
rep_rhs_ty  = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
rep_rhs_tys
        rep_tcvs :: [Id]
rep_tcvs    = [Type] -> [Id]
tyCoVarsOfTypesList [Type]
rep_lhs_tys
        ([Id]
rep_tvs, [Id]
rep_cvs) = (Id -> Bool) -> [Id] -> ([Id], [Id])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Id -> Bool
isTyVar [Id]
rep_tcvs
        rep_tvs' :: [Id]
rep_tvs'    = [Id] -> [Id]
scopedSort [Id]
rep_tvs
        rep_cvs' :: [Id]
rep_cvs'    = [Id] -> [Id]
scopedSort [Id]
rep_cvs

nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType :: LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
nlHsAppType LHsExpr (GhcPass 'Parsed)
e Type
s = HsExpr (GhcPass 'Parsed) -> LocatedA (HsExpr (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (XAppTypeE (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsWcType (NoGhcTc (GhcPass 'Parsed))
-> HsExpr (GhcPass 'Parsed)
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType XAppTypeE (GhcPass 'Parsed)
EpToken "@"
forall a. NoAnn a => a
noAnn LHsExpr (GhcPass 'Parsed)
e LHsWcType (NoGhcTc (GhcPass 'Parsed))
HsWildCardBndrs
  (GhcPass 'Parsed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
hs_ty)
  where
    hs_ty :: HsWildCardBndrs
  (GhcPass 'Parsed)
  (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
hs_ty = GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
-> HsWildCardBndrs
     (GhcPass 'Parsed)
     (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
 -> HsWildCardBndrs
      (GhcPass 'Parsed)
      (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))))
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
-> HsWildCardBndrs
     (GhcPass 'Parsed)
     (GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
forall a b. (a -> b) -> a -> b
$ PprPrec -> LHsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec (LHsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed))
-> LHsType (GhcPass 'Parsed) -> LHsType (GhcPass 'Parsed)
forall a b. (a -> b) -> a -> b
$ Type -> LHsType (GhcPass 'Parsed)
nlHsCoreTy Type
s

nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
nlHsCoreTy :: Type -> LHsType (GhcPass 'Parsed)
nlHsCoreTy = HsType (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
forall e a. HasAnnotation e => a -> GenLocated e a
noLocA (HsType (GhcPass 'Parsed)
 -> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
-> (Type -> HsType (GhcPass 'Parsed))
-> Type
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XXType (GhcPass 'Parsed) -> HsType (GhcPass 'Parsed)
Type -> HsType (GhcPass 'Parsed)
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 -> [Id] -> [Type] -> Type -> Id -> Pair Type
mkCoerceClassMethEqn Class
cls [Id]
inst_tvs [Type]
inst_tys Type
rhs_ty Id
id
  = Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
rhs_subst Type
user_meth_ty)
         (HasDebugCallStack => Subst -> Type -> Type
Subst -> Type -> Type
substTy Subst
lhs_subst Type
user_meth_ty)
  where
    cls_tvs :: [Id]
cls_tvs = Class -> [Id]
classTyVars Class
cls
    in_scope :: InScopeSet
in_scope = [Id] -> InScopeSet
mkInScopeSetList [Id]
inst_tvs
    lhs_subst :: Subst
lhs_subst = InScopeSet -> TvSubstEnv -> Subst
mkTvSubst InScopeSet
in_scope ([Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs [Type]
inst_tys)
    rhs_subst :: Subst
rhs_subst = InScopeSet -> TvSubstEnv -> Subst
mkTvSubst InScopeSet
in_scope ([Id] -> [Type] -> TvSubstEnv
HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs ([Type] -> Type -> [Type]
forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty))
    ([Id]
_class_tvs, Type
_class_constraint, Type
user_meth_ty)
      = Type -> ([Id], Type, Type)
tcSplitMethodTy (Id -> Type
varType Id
id)

{-
************************************************************************
*                                                                      *
\subsection{Generating extra binds (@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 :: SrcSpan -> AuxBindSpec
                       -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal :: SrcSpan
-> AuxBindSpec
-> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBindSpecOriginal SrcSpan
loc AuxBindSpec
spec
  = (AuxBindSpec -> LHsBind (GhcPass 'Parsed)
gen_bind AuxBindSpec
spec,
     SrcSpanAnnA
-> Sig (GhcPass 'Parsed)
-> GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (XTypeSig (GhcPass 'Parsed)
-> [LIdP (GhcPass 'Parsed)]
-> LHsSigWcType (GhcPass 'Parsed)
-> Sig (GhcPass 'Parsed)
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig XTypeSig (GhcPass 'Parsed)
AnnSig
forall a. NoAnn a => a
noAnn [SrcSpanAnnN -> RdrName -> GenLocated SrcSpanAnnN RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnN
locn (AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
spec)]
           (SrcSpan -> AuxBindSpec -> LHsSigWcType (GhcPass 'Parsed)
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
spec)))
  where
    loca :: SrcSpanAnnA
loca = SrcSpan -> SrcSpanAnnA
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
    locn :: SrcSpanAnnN
locn = SrcSpan -> SrcSpanAnnN
forall e. HasAnnotation e => SrcSpan -> e
noAnnSrcSpan SrcSpan
loc
    gen_bind :: AuxBindSpec -> LHsBind GhcPs
    gen_bind :: AuxBindSpec -> LHsBind (GhcPass 'Parsed)
gen_bind (DerivTag2Con TyCon
_ RdrName
tag2con_RDR)
      = Int
-> SrcSpan
-> RdrName
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindSE Int
0 SrcSpan
loc RdrName
tag2con_RDR
           [([RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
intDataCon_RDR [RdrName
a_RDR]],
              LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
tagToEnum_RDR) LHsExpr (GhcPass 'Parsed)
a_Expr)]

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

    gen_bind (DerivDataDataType TyCon
tycon RdrName
dataT_RDR [RdrName]
dataC_RDRs)
      = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
dataT_RDR LHsExpr (GhcPass 'Parsed)
rhs
      where
        tc_name :: Name
tc_name = TyCon -> Name
tyConName TyCon
tycon
        tc_name_string :: FastString
tc_name_string = OccName -> FastString
occNameFS (Name -> OccName
forall a. NamedThing a => a -> OccName
getOccName Name
tc_name)
        definition_mod_name :: FastString
definition_mod_name = ModuleName -> FastString
moduleNameFS (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (String -> Maybe Module -> Module
forall a. HasDebugCallStack => 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))
        rhs :: LHsExpr (GhcPass 'Parsed)
rhs = IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdP (GhcPass 'Parsed)
RdrName
mkDataType_RDR
              LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (FastString -> HsLit (GhcPass 'Parsed)
forall (p :: Pass). FastString -> HsLit (GhcPass p)
mkHsStringFS ([FastString] -> FastString
concatFS [FastString
definition_mod_name, String -> FastString
fsLit String
".", FastString
tc_name_string]))
              LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList ((RdrName -> LocatedA (HsExpr (GhcPass 'Parsed)))
-> [RdrName] -> [LocatedA (HsExpr (GhcPass 'Parsed))]
forall a b. (a -> b) -> [a] -> [b]
map IdP (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
RdrName -> LocatedA (HsExpr (GhcPass 'Parsed))
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 (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
dataC_RDR LHsExpr (GhcPass 'Parsed)
rhs
      where
        rhs :: LHsExpr (GhcPass 'Parsed)
rhs = IdP (GhcPass 'Parsed)
-> [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdP (GhcPass 'Parsed)
RdrName
mkConstrTag_RDR [LHsExpr (GhcPass 'Parsed)]
[LocatedA (HsExpr (GhcPass 'Parsed))]
constr_args

        constr_args :: [LocatedA (HsExpr (GhcPass 'Parsed))]