{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Deriv.Generate (
AuxBindSpec(..),
gen_Eq_binds,
gen_Ord_binds,
gen_Enum_binds,
gen_Bounded_binds,
gen_Ix_binds,
gen_Show_binds,
gen_Read_binds,
gen_Data_binds,
gen_Lift_binds,
gen_Newtype_binds,
gen_Newtype_fam_insts,
mkCoerceClassMethEqn,
genAuxBinds,
ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
getPossibleDataCons,
DerivInstTys(..), buildDataConInstArgEnv,
derivDataConInstArgTys, substDerivInstTys, zonkDerivInstTys
) where
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Tc.TyCl.Class ( substATBndrs )
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Builtin.Names
import GHC.Builtin.Names.TH
import GHC.Types.Id.Make ( coerceId )
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Zonk
import GHC.Tc.Validity ( checkValidCoAxBranch )
import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Core.Type
import GHC.Core.Class
import GHC.Types.Unique.FM ( lookupUFM, listToUFM )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Lexeme
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Bag
import Data.List ( find, partition, intersperse )
import GHC.Data.Maybe ( expectJust )
import GHC.Unit.Module
data AuxBindSpec
= DerivTag2Con
TyCon
RdrName
| DerivMaxTag
TyCon
RdrName
| DerivDataDataType
TyCon
RdrName
[RdrName]
| DerivDataConstr
DataCon
RdrName
RdrName
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
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
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
method_binds, 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 = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataCon -> Bool
isNullarySrcDataCon) [DataCon]
all_cons
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
(forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
ah_RDR) RdrName
neInt_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
bh_RDR))))
[ forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (HsLit (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
nlLitPat (forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
NoSourceText Integer
1)) LHsExpr (GhcPass 'Parsed)
false_Expr
, forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (
LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a_RDR)
(let non_nullary_pats :: [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
non_nullary_pats = forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> LMatch (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed)))
pats_etc [DataCon]
non_nullary_cons
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons
then [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 forall a. [a] -> [a] -> [a]
++ [forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat LHsExpr (GhcPass 'Parsed)
true_Expr]))
]
method_binds :: Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
method_binds = forall a. a -> Bag a
unitBag LHsBind (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 (forall a b. a -> b -> a
const LHsExpr (GhcPass 'Parsed)
true_Expr) [([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
LocatedA (HsExpr (GhcPass 'Parsed)))]
binds
where
binds :: [([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
LocatedA (HsExpr (GhcPass 'Parsed)))]
binds
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
all_cons = []
| [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 <- forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
, LPat (GhcPass 'Parsed)
con1_pat <- forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat 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 <- forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat 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)
con1_pat, LPat (GhcPass 'Parsed)
con2_pat], LocatedA (HsExpr (GhcPass 'Parsed))
eq_expr)]
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all DataCon -> Bool
isNullarySrcDataCon [DataCon]
all_cons
= [([LPat (GhcPass 'Parsed)
a_Pat, LPat (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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
ah_RDR) RdrName
eqInt_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
bh_RDR)))]
| Bool
otherwise
= [([LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat], LHsExpr (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
= forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
and_Expr (forall a b c d.
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)
where
nested_eq :: Type -> RdrName -> RdrName -> LHsExpr (GhcPass 'Parsed)
nested_eq Type
ty RdrName
a RdrName
b = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (Type
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
eq_Expr Type
ty (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a) (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 <- forall (t :: * -> *) a. Foldable t => t a -> Int
length [Type]
tys_needed
, [RdrName]
as_needed <- forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
, [RdrName]
bs_needed <- 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 <- forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
, LPat (GhcPass 'Parsed)
con1_pat <- forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat 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 <- forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat 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
= forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
con1_pat (LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
con2_pat LocatedA (HsExpr (GhcPass 'Parsed))
fields_eq_expr])
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
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
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
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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
tycon_data_cons
then ( forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
2 SrcSpan
loc RdrName
compare_RDR (forall a b. a -> b -> a
const LHsExpr (GhcPass 'Parsed)
eqTag_Expr) []
, forall a. Bag a
emptyBag)
else ( forall a. a -> Bag a
unitBag (OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp OrdOp
OrdCompare)
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
other_ops
, forall a. Bag a
aux_binds)
where
aux_binds :: Bag a
aux_binds = forall a. Bag a
emptyBag
other_ops :: Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
other_ops
| (Int
last_tag forall a. Num a => a -> a -> a
- Int
first_tag) forall a. Ord a => a -> a -> Bool
<= Int
2
Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons
= forall a. [a] -> Bag a
listToBag [OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp OrdOp
OrdLT, LHsBind (GhcPass 'Parsed)
lE, LHsBind (GhcPass 'Parsed)
gT, LHsBind (GhcPass 'Parsed)
gE]
| Bool
otherwise
= forall a. Bag a
emptyBag
negate_expr :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
negate_expr = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
not_RDR)
lE :: LHsBind (GhcPass 'Parsed)
lE = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
le_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] forall a b. (a -> b) -> a -> b
$
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
negate_expr (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
lt_RDR) LHsExpr (GhcPass 'Parsed)
b_Expr) LHsExpr (GhcPass 'Parsed)
a_Expr)
gT :: LHsBind (GhcPass 'Parsed)
gT = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
gt_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] forall a b. (a -> b) -> a -> b
$
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
lt_RDR) LHsExpr (GhcPass 'Parsed)
b_Expr) LHsExpr (GhcPass 'Parsed)
a_Expr
gE :: LHsBind (GhcPass 'Parsed)
gE = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
ge_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] forall a b. (a -> b) -> a -> b
$
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
negate_expr (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 forall a. Num a => a -> a -> a
- Int
fIRST_TAG
tycon_data_cons :: [DataCon]
tycon_data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
single_con_type :: Bool
single_con_type = forall a. [a] -> Bool
isSingleton [DataCon]
tycon_data_cons
(DataCon
first_con : [DataCon]
_) = [DataCon]
tycon_data_cons
(DataCon
last_con : [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) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
isNullarySrcDataCon [DataCon]
tycon_data_cons
mkOrdOp :: OrdOp -> LHsBind GhcPs
mkOrdOp :: OrdOp -> LHsBind (GhcPass 'Parsed)
mkOrdOp OrdOp
op
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc (OrdOp -> RdrName
ordMethRdr OrdOp
op) [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat]
(OrdOp -> LHsExpr (GhcPass 'Parsed)
mkOrdOpRhs OrdOp
op)
mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
mkOrdOpRhs :: OrdOp -> LHsExpr (GhcPass 'Parsed)
mkOrdOpRhs OrdOp
op
| [DataCon]
nullary_cons forall a. [a] -> Int -> Bool
`lengthAtMost` Int
2
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a_RDR) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt OrdOp
op) [DataCon]
tycon_data_cons
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons
= OrdOp -> LHsExpr (GhcPass 'Parsed)
mkTagCmp OrdOp
op
| Bool
otherwise
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a_RDR) forall a b. (a -> b) -> a -> b
$
(forall a b. (a -> b) -> [a] -> [b]
map (OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt OrdOp
op) [DataCon]
non_nullary_cons
forall a. [a] -> [a] -> [a]
++ [forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
mkTagCmp OrdOp
op)])
mkOrdOpAlt :: OrdOp -> DataCon
-> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt :: OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkOrdOpAlt OrdOp
op DataCon
data_con
= forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat (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 = forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
data_con) [RdrName]
as_RDRs
data_con_RDR :: RdrName
data_con_RDR = 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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con ]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
first_tag
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
, forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
last_tag
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
, forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
first_tag forall a. Num a => a -> a -> a
+ Int
1
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [ forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat (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
, forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]
| Int
tag forall a. Eq a => a -> a -> Bool
== Int
last_tag forall a. Num a => a -> a -> a
- Int
1
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [ forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat (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
, forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) ]
| Int
tag forall a. Ord a => a -> a -> Bool
> Int
last_tag forall a. Integral a => a -> a -> a
`div` Int
2
= [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] 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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
bh_RDR) RdrName
ltInt_RDR LocatedA (HsExpr (GhcPass 'Parsed))
tag_lit)
(OrdOp -> LHsExpr (GhcPass 'Parsed)
gtResult OrdOp
op) forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
, forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (GhcPass 'Parsed)
nlWildPat (OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) ]
| Bool
otherwise
= [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] 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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
bh_RDR) RdrName
gtInt_RDR LocatedA (HsExpr (GhcPass 'Parsed))
tag_lit)
(OrdOp -> LHsExpr (GhcPass 'Parsed)
ltResult OrdOp
op) forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR) [ OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
, forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt LPat (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
= forall a an. a -> LocatedAn an a
noLocA (forall p. XLitE p -> HsLit p -> HsExpr p
HsLit EpAnnCO
noComments (forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
NoSourceText (forall a. Integral a => a -> Integer
toInteger Int
tag)))
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt :: OrdOp
-> DataCon -> LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))
mkInnerEqAlt OrdOp
op DataCon
data_con
= forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed) 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 = forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
bs_needed :: [RdrName]
bs_needed = forall a. Int -> [a] -> [a]
take (DataCon -> Int
dataConSourceArity DataCon
data_con) [RdrName]
bs_RDRs
mkTagCmp :: OrdOp -> LHsExpr GhcPs
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)] 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
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
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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a) (OrdOp -> RdrName
ordMethRdr OrdOp
op) (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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]
_ = forall a. String -> a
panic String
"mkCompareFields"
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
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 LocatedA (HsExpr (GhcPass 'Parsed))
lt LocatedA (HsExpr (GhcPass 'Parsed))
eq LocatedA (HsExpr (GhcPass 'Parsed))
gt
| Bool
otherwise
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
compare_RDR) LHsExpr (GhcPass 'Parsed)
a_expr) LHsExpr (GhcPass 'Parsed)
b_expr))
[forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat (GhcPass 'Parsed)
nlNullaryConPat RdrName
ltTag_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
lt,
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat (GhcPass 'Parsed)
nlNullaryConPat RdrName
eqTag_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
eq,
forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat (GhcPass 'Parsed)
nlNullaryConPat RdrName
gtTag_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
gt]
where
a_expr :: LHsExpr (GhcPass 'Parsed)
a_expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdGhcP 'Parsed
a
b_expr :: LHsExpr (GhcPass 'Parsed)
b_expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a
b_expr :: LHsExpr (GhcPass 'Parsed)
b_expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b
unliftedCompare :: RdrName -> RdrName
-> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
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 (forall {p} {a} {an}.
(XRec (NoGhcTc p) (HsSigType (NoGhcTc p))
~ GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)),
NoGhcTc p ~ GhcPass 'Parsed, XExprWithTySig p ~ EpAnn a) =>
XRec p (HsExpr p) -> LocatedAn an (HsExpr p)
ascribeBool 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 forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (forall {p} {a} {an}.
(XRec (NoGhcTc p) (HsSigType (NoGhcTc p))
~ GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)),
NoGhcTc p ~ GhcPass 'Parsed, XExprWithTySig p ~ EpAnn a) =>
XRec p (HsExpr p) -> LocatedAn an (HsExpr p)
ascribeBool 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) -> LocatedAn an (HsExpr p)
ascribeBool XRec p (HsExpr p)
e = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig forall a. EpAnn a
noAnn XRec p (HsExpr p)
e
forall a b. (a -> b) -> a -> b
$ forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs forall a b. (a -> b) -> a -> b
$ forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed)
mkHsImplicitSigType
forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted RdrName
boolTyCon_RDR
nlConWildPat :: DataCon -> LPat GhcPs
nlConWildPat :: DataCon -> LPat (GhcPass 'Parsed)
nlConWildPat DataCon
con = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ ConPat
{ pat_con_ext :: XConPat (GhcPass 'Parsed)
pat_con_ext = forall a. EpAnn a
noAnn
, pat_con :: XRec (GhcPass 'Parsed) (ConLikeP (GhcPass 'Parsed))
pat_con = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
, pat_args :: HsConPatDetails (GhcPass 'Parsed)
pat_args = forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon forall a b. (a -> b) -> a -> b
$ HsRecFields
{ rec_flds :: [LHsRecField
(GhcPass 'Parsed) (GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed)))]
rec_flds = []
, rec_dotdot :: Maybe (Located Int)
rec_dotdot = forall a. Maybe a
Nothing }
}
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
RdrName
tag2con_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
loc TyCon
tycon
RdrName
maxtag_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_maxtag_rdr_name SrcSpan
loc TyCon
tycon
forall (m :: * -> *) a. Monad m => a -> m a
return ( RdrName
-> RdrName
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
method_binds RdrName
tag2con_RDR RdrName
maxtag_RDR
, RdrName -> RdrName -> Bag AuxBindSpec
aux_binds RdrName
tag2con_RDR RdrName
maxtag_RDR )
where
method_binds :: RdrName
-> RdrName
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
method_binds RdrName
tag2con_RDR RdrName
maxtag_RDR = forall a. [a] -> Bag a
listToBag
[ 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
, RdrName -> RdrName -> LHsBind (GhcPass 'Parsed)
enum_from_then RdrName
tag2con_RDR RdrName
maxtag_RDR
, LHsBind (GhcPass 'Parsed)
from_enum
]
aux_binds :: RdrName -> RdrName -> Bag AuxBindSpec
aux_binds RdrName
tag2con_RDR RdrName
maxtag_RDR = 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 = 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
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
succ_RDR [LPat (GhcPass 'Parsed)
a_Pat] forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
eq_RDR [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
maxtag_RDR,
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [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")
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
tag2con_RDR)
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
plus_RDR [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
ah_RDR],
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
1]))
pred_enum :: RdrName -> LHsBind (GhcPass 'Parsed)
pred_enum RdrName
tag2con_RDR
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
pred_RDR [LPat (GhcPass 'Parsed)
a_Pat] forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
eq_RDR [forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0,
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [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")
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
tag2con_RDR)
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
plus_RDR
[ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
ah_RDR]
, forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
noExtField
(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
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
toEnum_RDR [LPat (GhcPass 'Parsed)
a_Pat] forall a b. (a -> b) -> a -> b
$
LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
and_RDR
[forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
ge_RDR [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a_RDR, forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0],
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
le_RDR [ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a_RDR
, forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
maxtag_RDR]])
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
tag2con_RDR [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
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFrom_RDR [LPat (GhcPass 'Parsed)
a_Pat] forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] forall a b. (a -> b) -> a -> b
$
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
map_RDR
[forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
tag2con_RDR,
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
enum_from_to_Expr
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
ah_RDR])
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
maxtag_RDR))]
enum_from_then :: RdrName -> RdrName -> LHsBind (GhcPass 'Parsed)
enum_from_then RdrName
tag2con_RDR RdrName
maxtag_RDR
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFromThen_RDR [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] 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)] forall a b. (a -> b) -> a -> b
$
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
map_RDR [RdrName
tag2con_RDR]) forall a b. (a -> b) -> a -> b
$
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
enum_from_then_to_Expr
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
ah_RDR])
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
bh_RDR])
(LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsIf (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
gt_RDR [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
ah_RDR],
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
bh_RDR]])
(forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0)
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
maxtag_RDR)
))
from_enum :: LHsBind (GhcPass 'Parsed)
from_enum
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
fromEnum_RDR [LPat (GhcPass 'Parsed)
a_Pat] forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] forall a b. (a -> b) -> a -> b
$
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
ah_RDR])
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
= (forall a. [a] -> Bag a
listToBag [ LHsBind (GhcPass 'Parsed)
min_bound_enum, LHsBind (GhcPass 'Parsed)
max_bound_enum ], forall a. Bag a
emptyBag)
| Bool
otherwise
= forall a. HasCallStack => Bool -> a -> a
assert (forall a. [a] -> Bool
isSingleton [DataCon]
data_cons)
(forall a. [a] -> Bag a
listToBag [ LHsBind (GhcPass 'Parsed)
min_bound_1con, LHsBind (GhcPass 'Parsed)
max_bound_1con ], forall a. Bag a
emptyBag)
where
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
min_bound_enum :: LHsBind (GhcPass 'Parsed)
min_bound_enum = SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
data_con_N_RDR)
data_con_1 :: DataCon
data_con_1 = forall a. [a] -> a
head [DataCon]
data_cons
data_con_N :: DataCon
data_con_N = forall a. [a] -> a
last [DataCon]
data_cons
data_con_1_RDR :: RdrName
data_con_1_RDR = forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con_1
data_con_N_RDR :: RdrName
data_con_N_RDR = forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con_N
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 forall a b. (a -> b) -> a -> b
$
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
data_con_1_RDR (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 forall a b. (a -> b) -> a -> b
$
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
data_con_1_RDR (forall a. Int -> a -> [a]
replicate Int
arity RdrName
maxBound_RDR)
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
RdrName
tag2con_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
loc TyCon
tycon
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if TyCon -> Bool
isEnumerationTyCon TyCon
tycon
then (RdrName
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
enum_ixes RdrName
tag2con_RDR, forall a. [a] -> Bag a
listToBag
[ TyCon -> RdrName -> AuxBindSpec
DerivTag2Con TyCon
tycon RdrName
tag2con_RDR
])
else (Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
single_con_ixes, forall a. Bag a
emptyBag)
where
enum_ixes :: RdrName
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
enum_ixes RdrName
tag2con_RDR = forall a. [a] -> Bag a
listToBag
[ RdrName -> LHsBind (GhcPass 'Parsed)
enum_range RdrName
tag2con_RDR
, LHsBind (GhcPass 'Parsed)
enum_index
, LHsBind (GhcPass 'Parsed)
enum_inRange
]
enum_range :: RdrName -> LHsBind (GhcPass 'Parsed)
enum_range RdrName
tag2con_RDR
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] Boxity
Boxed] forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] forall a b. (a -> b) -> a -> b
$
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
map_RDR [RdrName
tag2con_RDR]) forall a b. (a -> b) -> a -> b
$
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
enum_from_to_Expr
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
ah_RDR])
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [RdrName
bh_RDR]))
enum_index :: LHsBind (GhcPass 'Parsed)
enum_index
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
[forall a an. a -> LocatedAn an a
noLocA (forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat forall a. EpAnn a
noAnn (forall a an. a -> LocatedAn an 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)
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 = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
intDataCon_RDR [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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
dh_RDR) RdrName
minusInt_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
ah_RDR))
[forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
c_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
rhs]
))
)
enum_inRange :: LHsBind (GhcPass 'Parsed)
enum_inRange
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR [[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
b_Pat] Boxity
Boxed, LPat (GhcPass 'Parsed)
c_Pat] 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)] (
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
and_RDR
[ LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
ch_RDR) RdrName
geInt_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
ah_RDR)
, LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
ch_RDR) RdrName
leInt_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
bh_RDR)
]
)))
single_con_ixes :: Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
single_con_ixes
= forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)
single_con_range, LHsBind (GhcPass 'Parsed)
single_con_index, LHsBind (GhcPass 'Parsed)
single_con_inRange]
data_con :: DataCon
data_con
= case TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tycon of
Maybe DataCon
Nothing -> forall a. String -> a
panic String
"get_Ix_binds"
Just DataCon
dc -> DataCon
dc
con_arity :: Int
con_arity = DataCon -> Int
dataConSourceArity DataCon
data_con
data_con_RDR :: RdrName
data_con_RDR = forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
as_needed :: [RdrName]
as_needed = forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
bs_needed :: [RdrName]
bs_needed = forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
bs_RDRs
cs_needed :: [RdrName]
cs_needed = 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 = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
data_con_RDR [RdrName]
cs_needed
single_con_range :: LHsBind (GhcPass 'Parsed)
single_con_range
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR
[[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed] forall a b. (a -> b) -> a -> b
$
forall a an. a -> LocatedAn an a
noLocA (HsDoFlavour
-> [ExprLStmt (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> HsExpr (GhcPass 'Parsed)
mkHsComp HsDoFlavour
ListComp [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts LHsExpr (GhcPass 'Parsed)
con_expr)
where
stmts :: [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
stmts = forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_range" forall {an}.
RdrName
-> RdrName
-> RdrName
-> LocatedAn
an
(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
-> LocatedAn
an
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
mk_qual RdrName
a RdrName
b RdrName
c = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat (GhcPass 'Parsed)
-> LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (bodyR (GhcPass 'Parsed)))
mkPsBindStmt forall a. EpAnn a
noAnn (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
c)
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
range_RDR)
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [RdrName
a,RdrName
b] forall a. EpAnn a
noAnn))
single_con_index :: LHsBind (GhcPass 'Parsed)
single_con_index
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
[[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed,
[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
cs_needed]
([(RdrName, RdrName, RdrName)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_index (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed))
where
mk_index :: [(RdrName, RdrName, RdrName)]
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_index [] = forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0
mk_index [(RdrName
l,RdrName
u,RdrName
i)] = forall {p :: Pass} {a}.
(IdGhcP p ~ RdrName, XExplicitTuple (GhcPass p) ~ EpAnn a,
Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn), 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 (
forall {p :: Pass} {a}.
(IdGhcP p ~ RdrName, XExplicitTuple (GhcPass p) ~ EpAnn a,
Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn), 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 (
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
unsafeRangeSize_RDR)
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [RdrName
l,RdrName
u] forall a. EpAnn 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
= forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
unsafeIndex_RDR [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [RdrName
l,RdrName
u] forall a. EpAnn a
noAnn, forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
i]
single_con_inRange :: LHsBind (GhcPass 'Parsed)
single_con_inRange
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR
[[LPat (GhcPass 'Parsed)] -> Boxity -> LPat (GhcPass 'Parsed)
nlTuplePat [[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
as_needed, [RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
bs_needed] Boxity
Boxed,
[RdrName] -> LPat (GhcPass 'Parsed)
con_pat [RdrName]
cs_needed] forall a b. (a -> b) -> a -> b
$
if Int
con_arity forall a. Eq a => a -> a -> Bool
== Int
0
then LHsExpr (GhcPass 'Parsed)
true_Expr
else forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
and_Expr (forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_inRange" forall {p :: Pass} {a}.
(IdGhcP p ~ RdrName, XExplicitTuple (GhcPass p) ~ EpAnn a,
Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn), 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
= forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
inRange_RDR [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
[IdP (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsVarTuple [RdrName
a,RdrName
b] forall a. EpAnn a
noAnn, forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
c]
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})
= (forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)
read_prec, LHsBind (GhcPass 'Parsed)
default_readlist, LHsBind (GhcPass 'Parsed)
default_readlistprec], 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 (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
readListDefault_RDR)
default_readlistprec :: LHsBind (GhcPass 'Parsed)
default_readlistprec
= SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
readListPrec_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
readListPrecDefault_RDR)
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
([DataCon]
nullary_cons, [DataCon]
non_nullary_cons) = 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 | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons
= forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
pfail_RDR
| Bool
otherwise
= forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
parens_RDR)
(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 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 = 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 forall a. Maybe a
Nothing) (forall {a} {an} {idL :: Pass}.
NamedThing a =>
a
-> [LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
match_con DataCon
con forall a. [a] -> [a] -> [a]
++ [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
LocatedA (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))
mkLastStmt (forall {id :: Pass} {thing}.
(Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn),
IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr DataCon
con [])])]
[DataCon]
_ -> [forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
choose_RDR)
([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList (forall a b. (a -> b) -> [a] -> [b]
map forall {p :: Pass} {a} {thing}.
(Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn), IdGhcP p ~ RdrName,
XExplicitTuple (GhcPass p) ~ EpAnn a, NamedThing thing,
IsPass p) =>
thing -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_pair [DataCon]
nullary_cons))]
match_con :: a
-> [LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
match_con a
con | String -> Bool
isSym String
con_str = [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
con_str]
| Bool
otherwise = forall {an} {idL :: Pass}.
String
-> [LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ident_h_pat String
con_str
where
con_str :: String
con_str = forall a. NamedThing a => a -> String
data_con_str a
con
mk_pair :: thing -> LHsExpr (GhcPass p)
mk_pair thing
con = forall (p :: Pass).
[LHsExpr (GhcPass p)]
-> XExplicitTuple (GhcPass p) -> LHsExpr (GhcPass p)
mkLHsTupleExpr [forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (forall a. NamedThing a => a -> String
data_con_str thing
con)),
forall {id :: Pass} {thing}.
(Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn),
IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr thing
con []] forall a. EpAnn a
noAnn
read_non_nullary_con :: DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
read_non_nullary_con DataCon
data_con
| Bool
is_infix = Integer
-> [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_parser Integer
infix_prec [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
infix_stmts LocatedA (HsExpr (GhcPass 'Parsed))
body
| Bool
is_record = Integer
-> [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_parser Integer
record_prec [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
record_stmts LocatedA (HsExpr (GhcPass 'Parsed))
body
| Bool
otherwise = LocatedA (HsExpr (GhcPass 'Parsed))
prefix_parser
where
body :: LocatedA (HsExpr (GhcPass 'Parsed))
body = forall {id :: Pass} {thing}.
(Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn),
IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
result_expr DataCon
data_con [RdrName]
as_needed
con_str :: String
con_str = forall a. NamedThing a => a -> String
data_con_str DataCon
data_con
prefix_parser :: LocatedA (HsExpr (GhcPass 'Parsed))
prefix_parser = Integer
-> [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedA (HsExpr (GhcPass 'Parsed))
mk_parser Integer
prefix_prec [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
prefix_stmts LocatedA (HsExpr (GhcPass 'Parsed))
body
read_prefix_con :: [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_prefix_con
| String -> Bool
isSym String
con_str = [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"(", forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
con_str, forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
")"]
| Bool
otherwise = forall {an} {idL :: Pass}.
String
-> [LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ident_h_pat String
con_str
read_infix_con :: [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_infix_con
| String -> Bool
isSym String
con_str = [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
con_str]
| Bool
otherwise = [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"`"] forall a. [a] -> [a] -> [a]
++ forall {an} {idL :: Pass}.
String
-> [LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ident_h_pat String
con_str forall a. [a] -> [a] -> [a]
++ [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"`"]
prefix_stmts :: [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
prefix_stmts
= [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_prefix_con forall a. [a] -> [a] -> [a]
++ [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_args
infix_stmts :: [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
infix_stmts
= [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_a1]
forall a. [a] -> [a] -> [a]
++ [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_infix_con
forall a. [a] -> [a] -> [a]
++ [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_a2]
record_stmts :: [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
record_stmts
= [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_prefix_con
forall a. [a] -> [a] -> [a]
++ [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"{"]
forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
","] [[LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]]
field_stmts)
forall a. [a] -> [a] -> [a]
++ [forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
"}"]
field_stmts :: [[LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]]
field_stmts = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"lbl_stmts" forall {an}.
FastString
-> RdrName
-> [LocatedAn
an
(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 = forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
dc_nm :: Name
dc_nm = 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 forall a. [a] -> Int -> Bool
`lengthExceeds` Int
0
as_needed :: [RdrName]
as_needed = forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
read_args :: [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_args = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Read_binds" forall {an}.
RdrName
-> Type
-> LocatedAn
an
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_arg [RdrName]
as_needed (DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
data_con DerivInstTys
dit)
(LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_a1:LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_a2:[LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
_) = [LocatedAn
AnnListItem
(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 forall a. Num a => a -> a -> a
+ Integer
1
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 LocatedA (HsExpr (GhcPass 'Parsed))
e1 RdrName
alt_RDR LocatedA (HsExpr (GhcPass 'Parsed))
e2
mk_parser :: Integer
-> [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> LHsExpr (GhcPass 'Parsed)
mk_parser Integer
p [LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ss LocatedA (HsExpr (GhcPass 'Parsed))
b = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
prec_RDR [forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
p
, HsDoFlavour
-> [ExprLStmt (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlHsDo (Maybe ModuleName -> HsDoFlavour
DoExpr forall a. Maybe a
Nothing) ([LocatedAn
AnnListItem
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ss forall a. [a] -> [a] -> [a]
++ [forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ 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 -> [IdGhcP p] -> LHsExpr (GhcPass p)
con_app thing
con [IdGhcP p]
as = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps (forall thing. NamedThing thing => thing -> RdrName
getRdrName thing
con) [IdGhcP p]
as
result_expr :: thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
result_expr thing
con [IdGhcP id]
as = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
returnM_RDR) (forall {id :: Pass} {thing}.
(Anno (IdGhcP id) ~ SrcSpanAnn' (EpAnn NameAnn),
IdGhcP id ~ RdrName, NamedThing thing, IsPass id) =>
thing
-> [IdGhcP id] -> GenLocated SrcSpanAnnA (HsExpr (GhcPass id))
con_app thing
con [IdGhcP id]
as)
ident_h_pat :: String
-> [LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
ident_h_pat String
s | Just (String
ss, Char
'#') <- forall a. [a] -> Maybe ([a], a)
snocView String
s = [ forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
ident_pat String
ss, forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
"#" ]
| Bool
otherwise = [ forall {an} {idL :: Pass}.
String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
ident_pat String
s ]
bindLex :: LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
bindLex LocatedA (HsExpr (GhcPass 'Parsed))
pat = forall a an. a -> LocatedAn an a
noLocA (forall (bodyR :: * -> *) (idL :: Pass).
LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (bodyR (GhcPass 'Parsed)))
mkBodyStmt (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
expectP_RDR) LocatedA (HsExpr (GhcPass 'Parsed))
pat))
ident_pat :: String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
ident_pat String
s = forall {an} {idL :: Pass}.
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
bindLex forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
ident_RDR [forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]
symbol_pat :: String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
symbol_pat String
s = forall {an} {idL :: Pass}.
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
bindLex forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
symbol_RDR [forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]
read_punc :: String
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_punc String
c = forall {an} {idL :: Pass}.
LocatedA (HsExpr (GhcPass 'Parsed))
-> LocatedAn
an
(StmtLR
(GhcPass idL)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
bindLex forall a b. (a -> b) -> a -> b
$ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
punc_RDR [forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
c)]
data_con_str :: a -> String
data_con_str a
con = OccName -> String
occNameString (forall a. NamedThing a => a -> OccName
getOccName a
con)
read_arg :: RdrName
-> Type
-> LocatedAn
an
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))
read_arg RdrName
a Type
ty = forall a. HasCallStack => Bool -> a -> a
assert (Bool -> Bool
not (HasDebugCallStack => Type -> Bool
isUnliftedType Type
ty)) forall a b. (a -> b) -> a -> b
$
forall a an. a -> LocatedAn an a
noLocA (forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat (GhcPass 'Parsed)
-> LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (bodyR (GhcPass 'Parsed)))
mkPsBindStmt forall a. EpAnn a
noAnn (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
a) (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
step_RDR [RdrName
readPrec_RDR]))
read_field :: FastString
-> RdrName
-> [LocatedAn
an
(StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (HsExpr (GhcPass 'Parsed))))]
read_field FastString
lbl RdrName
a =
[forall a an. a -> LocatedAn an a
noLocA
(forall (bodyR :: * -> *).
EpAnn [AddEpAnn]
-> LPat (GhcPass 'Parsed)
-> LocatedA (bodyR (GhcPass 'Parsed))
-> StmtLR
(GhcPass 'Parsed)
(GhcPass 'Parsed)
(LocatedA (bodyR (GhcPass 'Parsed)))
mkPsBindStmt forall a. EpAnn a
noAnn
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
a)
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
LocatedA (HsExpr (GhcPass 'Parsed))
read_field
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
reset_RDR [RdrName
readPrec_RDR])
)
)
]
where
lbl_str :: String
lbl_str = FastString -> String
unpackFS FastString
lbl
mk_read_field :: IdGhcP p -> String -> LHsExpr (GhcPass p)
mk_read_field IdGhcP p
read_field_rdr String
lbl
= forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps IdGhcP p
read_field_rdr [forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
lbl)]
read_field :: LocatedA (HsExpr (GhcPass 'Parsed))
read_field
| String -> Bool
isSym String
lbl_str
= forall {p :: Pass} {a}.
(Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), IsPass p) =>
IdGhcP p -> String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field RdrName
readSymField_RDR String
lbl_str
| Just (String
ss, Char
'#') <- forall a. [a] -> Maybe ([a], a)
snocView String
lbl_str
= forall {p :: Pass} {a}.
(Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), IsPass p) =>
IdGhcP p -> String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field RdrName
readFieldHash_RDR String
ss
| Bool
otherwise
= forall {p :: Pass} {a}.
(Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), IsPass p) =>
IdGhcP p -> String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
mk_read_field RdrName
readField_RDR String
lbl_str
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 })
= (forall a. a -> Bag a
unitBag LHsBind (GhcPass 'Parsed)
shows_prec, 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 forall a. a -> a
id (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 = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
showCommaSpace_RDR
pats_etc :: DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
LocatedA (HsExpr (GhcPass 'Parsed)))
pats_etc DataCon
data_con
| Bool
nullary_con =
forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RdrName]
bs_needed)
([LPat (GhcPass 'Parsed)
nlWildPat, LPat (GhcPass 'Parsed)
con_pat], String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
op_con_str)
| Bool
otherwise =
([LPat (GhcPass 'Parsed)
a_Pat, LPat (GhcPass 'Parsed)
con_pat],
LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
showParen_Expr (LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
a_Expr RdrName
ge_RDR (forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit
(forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
noExtField (forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
con_prec_plus_one))))
(forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr [LocatedA (HsExpr (GhcPass 'Parsed))]
show_thingies)))
where
data_con_RDR :: RdrName
data_con_RDR = 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 = 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
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 forall a. Eq a => a -> a -> Bool
== Int
0
labels :: [FastString]
labels = forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
lab_fields :: Int
lab_fields = forall (t :: * -> *) a. Foldable t => t a -> Int
length [FastString]
labels
record_syntax :: Bool
record_syntax = Int
lab_fields forall a. Ord a => a -> a -> Bool
> Int
0
dc_nm :: Name
dc_nm = forall a. NamedThing a => a -> Name
getName DataCon
data_con
dc_occ_nm :: OccName
dc_occ_nm = 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
" " forall a. [a] -> [a] -> [a]
++ String
backquote_str 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 forall a. [a] -> [a] -> [a]
++ String
" {") forall a. a -> [a] -> [a]
:
[LocatedA (HsExpr (GhcPass 'Parsed))]
show_record_args 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 forall a. [a] -> [a] -> [a]
++ String
" ") 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 forall a. [a] -> [a] -> [a]
++ String
" = ")
where
nm :: String
nm = String -> String
wrapOpParens (FastString -> String
unpackFS FastString
l)
show_args :: [LocatedA (HsExpr (GhcPass 'Parsed))]
show_args = forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Show_binds" RdrName -> Type -> LHsExpr (GhcPass 'Parsed)
show_arg [RdrName]
bs_needed [Type]
arg_tys
(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 = forall a. a -> [a] -> [a]
intersperse (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
showSpace_RDR) [LocatedA (HsExpr (GhcPass 'Parsed))]
show_args
show_record_args :: [LocatedA (HsExpr (GhcPass 'Parsed))]
show_record_args = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$
forall a. a -> [a] -> [a]
intersperse [LocatedA (HsExpr (GhcPass 'Parsed))
comma_space] 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) <- forall a b. 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
isUnliftedType Type
arg_ty
= LocatedA (HsExpr (GhcPass 'Parsed)) -> LHsExpr (GhcPass 'Parsed)
with_conv forall a b. (a -> b) -> a -> b
$
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps 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 = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 = forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
"Show" [(Type, String)]
postfixModTbl Type
arg_ty
with_conv :: LocatedA (HsExpr (GhcPass 'Parsed)) -> LHsExpr (GhcPass 'Parsed)
with_conv LocatedA (HsExpr (GhcPass 'Parsed))
expr
| (Just String
conv) <- forall a. [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, String)]
primConvTbl Type
arg_ty =
[LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr
[ String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app (String
"(" forall a. [a] -> [a] -> [a]
++ String
conv forall a. [a] -> [a] -> [a]
++ String
" ")
, LocatedA (HsExpr (GhcPass 'Parsed))
expr
, String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
")"
]
| Bool
otherwise = LocatedA (HsExpr (GhcPass 'Parsed))
expr
is_infix :: Bool
is_infix = DataCon -> Bool
dataConIsInfix DataCon
data_con
con_prec_plus_one :: Integer
con_prec_plus_one = Integer
1 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
| Bool
otherwise = Integer
con_prec_plus_one
wrapOpParens :: String -> String
wrapOpParens :: String -> String
wrapOpParens String
s | String -> Bool
isSym String
s = Char
'(' forall a. a -> [a] -> [a]
: String
s 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
'`' forall a. a -> [a] -> [a]
: String
s 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
mk_showString_app :: String -> LHsExpr GhcPs
mk_showString_app :: String -> LHsExpr (GhcPass 'Parsed)
mk_showString_app String
str = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
showString_RDR) (forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
str))
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
= forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
showsPrec_RDR [forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
noExtField (forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
p)), LHsExpr (GhcPass 'Parsed)
x]
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
mk_shows_app LHsExpr (GhcPass 'Parsed)
x = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
maxPrecedence forall a. Num a => a -> a -> a
+ Integer
1
getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
nm
= case Name -> Fixity
get_fixity Name
nm of
Fixity SourceText
_ Int
x FixityDirection
_assoc -> forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x
gen_Data_binds :: SrcSpan
-> DerivInstTys
-> TcM (LHsBinds GhcPs,
Bag AuxBindSpec)
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 {
RdrName
dataT_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name SrcSpan
loc TyCon
rep_tc
; [RdrName]
dataC_RDRs <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name SrcSpan
loc) [DataCon]
data_cons
; forall (f :: * -> *) a. Applicative f => a -> f a
pure ( forall a. [a] -> Bag a
listToBag [ LHsBind (GhcPass 'Parsed)
gfoldl_bind, LHsBind (GhcPass 'Parsed)
gunfold_bind
, [RdrName] -> LHsBind (GhcPass 'Parsed)
toCon_bind [RdrName]
dataC_RDRs, RdrName -> LHsBind (GhcPass 'Parsed)
dataTypeOf_bind RdrName
dataT_RDR ]
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
gcast_binds
, forall a. [a] -> Bag a
listToBag
( TyCon -> RdrName -> [RdrName] -> AuxBindSpec
DerivDataDataType TyCon
rep_tc RdrName
dataT_RDR [RdrName]
dataC_RDRs
forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\DataCon
data_con RdrName
dataC_RDR ->
DataCon -> RdrName -> RdrName -> AuxBindSpec
DerivDataConstr DataCon
data_con RdrName
dataC_RDR RdrName
dataT_RDR)
[DataCon]
data_cons [RdrName]
dataC_RDRs )
) }
where
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
n_cons :: Int
n_cons = forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
data_cons
one_constr :: Bool
one_constr = Int
n_cons forall a. Eq a => a -> a -> Bool
== Int
1
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 forall a. a -> a
id (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
= ([forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
k_RDR, LPat (GhcPass 'Parsed)
z_Pat, RdrName -> [RdrName] -> LPat (GhcPass 'Parsed)
nlConVarPat RdrName
con_name [RdrName]
as_needed],
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 forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (forall {p :: Pass}.
(IdGhcP p ~ RdrName,
XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
~ NoExtField,
Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn), 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 = forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
as_needed :: [RdrName]
as_needed = 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 = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp LocatedA (HsExpr (GhcPass 'Parsed))
e RdrName
k_RDR (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
v))
gunfold_bind :: LHsBind (GhcPass 'Parsed)
gunfold_bind = SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc
RdrName
gunfold_RDR
[LPat (GhcPass 'Parsed)
k_Pat, LPat (GhcPass 'Parsed)
z_Pat, if Bool
one_constr then LPat (GhcPass 'Parsed)
nlWildPat else LPat (GhcPass 'Parsed)
c_Pat]
LocatedA (HsExpr (GhcPass 'Parsed))
gunfold_rhs
gunfold_rhs :: LocatedA (HsExpr (GhcPass 'Parsed))
gunfold_rhs
| Bool
one_constr = DataCon -> LocatedA (HsExpr (GhcPass 'Parsed))
mk_unfold_rhs (forall a. [a] -> a
head [DataCon]
data_cons)
| Bool
otherwise = LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
conIndex_RDR forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr (GhcPass 'Parsed)
c_Expr)
(forall a b. (a -> b) -> [a] -> [b]
map DataCon
-> LMatch (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 = forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat (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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(LHsExpr (GhcPass 'Parsed)
z_Expr forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (forall {p :: Pass}.
(IdGhcP p ~ RdrName,
XMG (GhcPass p) (GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
~ NoExtField,
Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn NameAnn), IsPass p) =>
DataCon -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
eta_expand_data_con DataCon
dc))
(forall a. Int -> a -> [a]
replicate (DataCon -> Int
dataConSourceArity DataCon
dc) (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
k_RDR))
eta_expand_data_con :: DataCon -> LHsExpr (GhcPass p)
eta_expand_data_con DataCon
dc =
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [GenLocated SrcSpanAnnA (Pat (GhcPass p))]
eta_expand_pats
(forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (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 = forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a b. (a -> b) -> [a] -> [b]
map 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 = 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
| Int
tagforall a. Num a => a -> a -> a
-Int
fIRST_TAG forall a. Eq a => a -> a -> Bool
== Int
n_consforall a. Num a => a -> a -> a
-Int
1 = LPat (GhcPass 'Parsed)
nlWildPat
| Bool
otherwise = RdrName -> [LPat (GhcPass 'Parsed)] -> LPat (GhcPass 'Parsed)
nlConPat RdrName
intDataCon_RDR
[HsLit (GhcPass 'Parsed) -> LPat (GhcPass 'Parsed)
nlLitPat (forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
NoSourceText (forall a. Integral a => a -> Integer
toInteger Int
tag))]
where
tag :: Int
tag = DataCon -> Int
dataConTag DataCon
dc
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 forall a. a -> a
id
(forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {p :: Pass} {a}.
(Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn 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], forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar IdGhcP p
con_name)
dataTypeOf_bind :: RdrName -> LHsBind (GhcPass 'Parsed)
dataTypeOf_bind RdrName
dataT_RDR
= SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind
SrcSpan
loc
RdrName
dataTypeOf_RDR
[LPat (GhcPass 'Parsed)
nlWildPat]
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
dataT_RDR)
tycon_kind :: Type
tycon_kind = case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
rep_tc of
Just (TyCon
fam_tc, [Type]
_) -> TyCon -> Type
tyConKind TyCon
fam_tc
Maybe (TyCon, [Type])
Nothing -> TyCon -> Type
tyConKind TyCon
rep_tc
gcast_binds :: Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
gcast_binds | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
`tcEqKind` Type
kind1 = RdrName
-> RdrName
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
mk_gcast RdrName
dataCast1_RDR RdrName
gcast1_RDR
| Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
`tcEqKind` Type
kind2 = RdrName
-> RdrName
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
mk_gcast RdrName
dataCast2_RDR RdrName
gcast2_RDR
| Bool
otherwise = forall a. Bag a
emptyBag
mk_gcast :: RdrName
-> RdrName
-> Bag
(GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)))
mk_gcast RdrName
dataCast_RDR RdrName
gcast_RDR
= forall a. a -> Bag a
unitBag (SrcSpan
-> RdrName
-> [LPat (GhcPass 'Parsed)]
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
dataCast_RDR [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
f_RDR]
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
gcast_RDR forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
f_RDR))
kind1, kind2 :: Kind
kind1 :: Type
kind1 = Type
typeToTypeKind
kind2 :: Type
kind2 = Type
liftedTypeKind Type -> Type -> Type
`mkVisFunTyMany` Type
kind1
gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,
mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
constr_RDR, dataType_RDR,
eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , neInt_RDR ,
eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR ,
eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,
eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR ,
eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR,
eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR,
eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
word8ToWord_RDR , int8ToInt_RDR ,
word16ToWord_RDR, int16ToInt_RDR,
word32ToWord_RDR, int32ToInt_RDR
:: RdrName
gfoldl_RDR :: RdrName
gfoldl_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"gfoldl")
gunfold_RDR :: RdrName
gunfold_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"gunfold")
toConstr_RDR :: RdrName
toConstr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"toConstr")
dataTypeOf_RDR :: RdrName
dataTypeOf_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"dataTypeOf")
dataCast1_RDR :: RdrName
dataCast1_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"dataCast1")
dataCast2_RDR :: RdrName
dataCast2_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"dataCast2")
gcast1_RDR :: RdrName
gcast1_RDR = Module -> FastString -> RdrName
varQual_RDR Module
tYPEABLE (String -> FastString
fsLit String
"gcast1")
gcast2_RDR :: RdrName
gcast2_RDR = Module -> FastString -> RdrName
varQual_RDR Module
tYPEABLE (String -> FastString
fsLit String
"gcast2")
mkConstrTag_RDR :: RdrName
mkConstrTag_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"mkConstrTag")
constr_RDR :: RdrName
constr_RDR = Module -> FastString -> RdrName
tcQual_RDR Module
gENERICS (String -> FastString
fsLit String
"Constr")
mkDataType_RDR :: RdrName
mkDataType_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"mkDataType")
dataType_RDR :: RdrName
dataType_RDR = Module -> FastString -> RdrName
tcQual_RDR Module
gENERICS (String -> FastString
fsLit String
"DataType")
conIndex_RDR :: RdrName
conIndex_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gENERICS (String -> FastString
fsLit String
"constrIndex")
prefix_RDR :: RdrName
prefix_RDR = Module -> FastString -> RdrName
dataQual_RDR Module
gENERICS (String -> FastString
fsLit String
"Prefix")
infix_RDR :: RdrName
infix_RDR = Module -> FastString -> RdrName
dataQual_RDR Module
gENERICS (String -> FastString
fsLit String
"Infix")
eqChar_RDR :: RdrName
eqChar_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqChar#")
ltChar_RDR :: RdrName
ltChar_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltChar#")
leChar_RDR :: RdrName
leChar_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leChar#")
gtChar_RDR :: RdrName
gtChar_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtChar#")
geChar_RDR :: RdrName
geChar_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geChar#")
eqInt_RDR :: RdrName
eqInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"==#")
neInt_RDR :: RdrName
neInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"/=#")
ltInt_RDR :: RdrName
ltInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"<#" )
leInt_RDR :: RdrName
leInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"<=#")
gtInt_RDR :: RdrName
gtInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
">#" )
geInt_RDR :: RdrName
geInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
">=#")
eqInt8_RDR :: RdrName
eqInt8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt8#")
ltInt8_RDR :: RdrName
ltInt8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt8#" )
leInt8_RDR :: RdrName
leInt8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leInt8#")
gtInt8_RDR :: RdrName
gtInt8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt8#" )
geInt8_RDR :: RdrName
geInt8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geInt8#")
eqInt16_RDR :: RdrName
eqInt16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt16#")
ltInt16_RDR :: RdrName
ltInt16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt16#" )
leInt16_RDR :: RdrName
leInt16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leInt16#")
gtInt16_RDR :: RdrName
gtInt16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt16#" )
geInt16_RDR :: RdrName
geInt16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geInt16#")
eqInt32_RDR :: RdrName
eqInt32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt32#")
ltInt32_RDR :: RdrName
ltInt32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt32#" )
leInt32_RDR :: RdrName
leInt32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leInt32#")
gtInt32_RDR :: RdrName
gtInt32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt32#" )
geInt32_RDR :: RdrName
geInt32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geInt32#")
eqInt64_RDR :: RdrName
eqInt64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqInt64#")
ltInt64_RDR :: RdrName
ltInt64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltInt64#" )
leInt64_RDR :: RdrName
leInt64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leInt64#")
gtInt64_RDR :: RdrName
gtInt64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtInt64#" )
geInt64_RDR :: RdrName
geInt64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geInt64#")
eqWord_RDR :: RdrName
eqWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord#")
ltWord_RDR :: RdrName
ltWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord#")
leWord_RDR :: RdrName
leWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leWord#")
gtWord_RDR :: RdrName
gtWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord#")
geWord_RDR :: RdrName
geWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geWord#")
eqWord8_RDR :: RdrName
eqWord8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord8#")
ltWord8_RDR :: RdrName
ltWord8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord8#" )
leWord8_RDR :: RdrName
leWord8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leWord8#")
gtWord8_RDR :: RdrName
gtWord8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord8#" )
geWord8_RDR :: RdrName
geWord8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geWord8#")
eqWord16_RDR :: RdrName
eqWord16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord16#")
ltWord16_RDR :: RdrName
ltWord16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord16#" )
leWord16_RDR :: RdrName
leWord16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leWord16#")
gtWord16_RDR :: RdrName
gtWord16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord16#" )
geWord16_RDR :: RdrName
geWord16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geWord16#")
eqWord32_RDR :: RdrName
eqWord32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord32#")
ltWord32_RDR :: RdrName
ltWord32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord32#" )
leWord32_RDR :: RdrName
leWord32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leWord32#")
gtWord32_RDR :: RdrName
gtWord32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord32#" )
geWord32_RDR :: RdrName
geWord32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geWord32#")
eqWord64_RDR :: RdrName
eqWord64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqWord64#")
ltWord64_RDR :: RdrName
ltWord64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltWord64#" )
leWord64_RDR :: RdrName
leWord64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leWord64#")
gtWord64_RDR :: RdrName
gtWord64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtWord64#" )
geWord64_RDR :: RdrName
geWord64_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geWord64#")
eqAddr_RDR :: RdrName
eqAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqAddr#")
ltAddr_RDR :: RdrName
ltAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltAddr#")
leAddr_RDR :: RdrName
leAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leAddr#")
gtAddr_RDR :: RdrName
gtAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtAddr#")
geAddr_RDR :: RdrName
geAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geAddr#")
eqFloat_RDR :: RdrName
eqFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqFloat#")
ltFloat_RDR :: RdrName
ltFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltFloat#")
leFloat_RDR :: RdrName
leFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leFloat#")
gtFloat_RDR :: RdrName
gtFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtFloat#")
geFloat_RDR :: RdrName
geFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geFloat#")
eqDouble_RDR :: RdrName
eqDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"==##")
ltDouble_RDR :: RdrName
ltDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"<##" )
leDouble_RDR :: RdrName
leDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"<=##")
gtDouble_RDR :: RdrName
gtDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
">##" )
geDouble_RDR :: RdrName
geDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
">=##")
word8ToWord_RDR :: RdrName
word8ToWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"word8ToWord#")
int8ToInt_RDR :: RdrName
int8ToInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"int8ToInt#")
word16ToWord_RDR :: RdrName
word16ToWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"word16ToWord#")
int16ToInt_RDR :: RdrName
int16ToInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"int16ToInt#")
word32ToWord_RDR :: RdrName
word32ToWord_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"word32ToWord#")
int32ToInt_RDR :: RdrName
int32ToInt_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"int32ToInt#")
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 }) =
(forall a. [a] -> Bag a
listToBag [LHsBind (GhcPass 'Parsed)
lift_bind, LHsBind (GhcPass 'Parsed)
liftTyped_bind], 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 (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
pure_Expr)
(forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {an}.
(LocatedA (HsExpr (GhcPass 'Parsed)) -> a)
-> (RdrName
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> HsSplice (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
LocatedAn an a)
pats_etc LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_untyped_bracket IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsSplice (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 (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
unsafeCodeCoerce_Expr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr (GhcPass 'Parsed)
pure_Expr)
(forall a b. (a -> b) -> [a] -> [b]
map (forall {a} {an}.
(LocatedA (HsExpr (GhcPass 'Parsed)) -> a)
-> (RdrName
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> HsSplice (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
LocatedAn an a)
pats_etc LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_typed_bracket IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsSplice (GhcPass 'Parsed)
mk_tsplice Name
liftTypedName) [DataCon]
data_cons)
mk_untyped_bracket :: LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_untyped_bracket = forall p. XUntypedBracket p -> HsQuote p -> HsExpr p
HsUntypedBracket forall a. EpAnn a
noAnn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall p. XExpBr p -> LHsExpr p -> HsQuote p
ExpBr NoExtField
noExtField
mk_typed_bracket :: LHsExpr (GhcPass 'Parsed) -> HsExpr (GhcPass 'Parsed)
mk_typed_bracket = forall p. XTypedBracket p -> LHsExpr p -> HsExpr p
HsTypedBracket forall a. EpAnn a
noAnn
mk_usplice :: IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsSplice (GhcPass 'Parsed)
mk_usplice = forall id.
XUntypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsUntypedSplice forall a. EpAnn a
EpAnnNotUsed SpliceDecoration
DollarSplice
mk_tsplice :: IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> HsSplice (GhcPass 'Parsed)
mk_tsplice = forall id.
XTypedSplice id
-> SpliceDecoration -> IdP id -> LHsExpr id -> HsSplice id
HsTypedSplice forall a. EpAnn a
EpAnnNotUsed SpliceDecoration
DollarSplice
data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
pats_etc :: (LocatedA (HsExpr (GhcPass 'Parsed)) -> a)
-> (RdrName
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> HsSplice (GhcPass 'Parsed))
-> Name
-> DataCon
-> ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))],
LocatedAn an a)
pats_etc LocatedA (HsExpr (GhcPass 'Parsed)) -> a
mk_bracket RdrName
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> HsSplice (GhcPass 'Parsed)
mk_splice Name
lift_name DataCon
data_con
= ([LPat (GhcPass 'Parsed)
con_pat], LocatedAn an 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 = 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 = forall a. Int -> [a] -> [a]
take Int
con_arity [RdrName]
as_RDRs
lift_Expr :: LocatedAn an a
lift_Expr = forall a an. a -> LocatedAn an a
noLocA (LocatedA (HsExpr (GhcPass 'Parsed)) -> a
mk_bracket LHsExpr (GhcPass 'Parsed)
br_body)
br_body :: LHsExpr (GhcPass 'Parsed)
br_body = 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))
(forall a b. (a -> b) -> [a] -> [b]
map RdrName -> LHsExpr (GhcPass 'Parsed)
lift_var [RdrName]
as_needed)
lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
lift_var RdrName
x = forall a an. a -> LocatedAn an a
noLocA (forall p. XSpliceE p -> HsSplice p -> HsExpr p
HsSpliceE forall a. EpAnn a
EpAnnNotUsed (RdrName
-> LocatedA (HsExpr (GhcPass 'Parsed))
-> HsSplice (GhcPass 'Parsed)
mk_splice RdrName
x (forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
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 = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps (Name -> RdrName
Exact Name
lift_name) [forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
x]
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> (LHsBinds GhcPs, [LSig GhcPs])
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
= (forall a. [a] -> Bag a
listToBag [GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
binds, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs)
where
([GenLocated
SrcSpanAnnA (HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed))]
binds, [GenLocated SrcSpanAnnA (Sig (GhcPass 'Parsed))]
sigs) = forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip Id -> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
mk_bind_and_sig (Class -> [Id]
classMethods Class
cls)
underlying_inst_tys :: [Type]
underlying_inst_tys :: [Type]
underlying_inst_tys = forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty
locn :: SrcSpanAnn' (EpAnn NameAnn)
locn = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
loca :: SrcSpanAnnA
loca = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
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
= (
LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind LocatedAn NameAnn RdrName
loc_meth_RDR [forall (p :: Pass) (body :: * -> *).
(Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns) =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkSimpleMatch
(forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedAn NameAnn RdrName
loc_meth_RDR)
[] LHsExpr (GhcPass 'Parsed)
rhs_expr]
,
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca forall a b. (a -> b) -> a -> b
$ forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig forall a. EpAnn a
noAnn Bool
False [LocatedAn NameAnn RdrName
loc_meth_RDR]
forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca forall a b. (a -> b) -> a -> b
$ EpAnnForallTy
-> [LHsTyVarBndr Specificity (GhcPass 'Parsed)]
-> LHsType (GhcPass 'Parsed)
-> HsSigType (GhcPass 'Parsed)
mkHsExplicitSigType forall a. EpAnn a
noAnn
(forall a b. (a -> b) -> [a] -> [b]
map forall flag. VarBndr Id flag -> LHsTyVarBndr flag (GhcPass 'Parsed)
mk_hs_tvb [TcInvisTVBinder]
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
([TcInvisTVBinder]
to_tvbs, Type
to_rho) = Type -> ([TcInvisTVBinder], Type)
tcSplitForAllInvisTVBinders Type
to_ty
([Type]
_, Type
to_tau) = Type -> ([Type], Type)
tcSplitPhiTy Type
to_rho
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) = forall a an. a -> LocatedAn an a
noLocA forall a b. (a -> b) -> a -> b
$ forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar forall a. EpAnn a
noAnn
flag
flag
(forall a an. a -> LocatedAn an a
noLocA (forall thing. NamedThing thing => thing -> RdrName
getRdrName Id
tv))
(Type -> LHsType (GhcPass 'Parsed)
nlHsCoreTy (Id -> Type
tyVarKind Id
tv))
meth_RDR :: RdrName
meth_RDR = forall thing. NamedThing thing => thing -> RdrName
getRdrName Id
meth_id
loc_meth_RDR :: LocatedAn NameAnn RdrName
loc_meth_RDR = forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn RdrName
meth_RDR
rhs_expr :: LHsExpr (GhcPass 'Parsed)
rhs_expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar (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
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LocatedA (HsExpr (GhcPass 'Parsed))
meth_app
meth_app :: LocatedA (HsExpr (GhcPass 'Parsed))
meth_app = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
nlHsAppType (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
meth_RDR) forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> [Type]
filterOutInferredTypes (Class -> TyCon
classTyCon Class
cls) [Type]
underlying_inst_tys
gen_Newtype_fam_insts :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> TcM [FamInst]
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
= forall a. HasCallStack => Bool -> a -> a
assert (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyCon -> Bool
isDataFamilyTyCon) [TyCon]
ats) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyCon -> TcM FamInst
mk_atf_inst [TyCon]
ats
where
underlying_inst_tys :: [Type]
underlying_inst_tys :: [Type]
underlying_inst_tys = forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty
ats :: [TyCon]
ats = Class -> [TyCon]
classATs Class
cls
locn :: SrcSpanAnn' (EpAnn NameAnn)
locn = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc'
cls_tvs :: [Id]
cls_tvs = Class -> [Id]
classTyVars Class
cls
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet forall a b. (a -> b) -> a -> b
$ [Id] -> VarSet
mkVarSet [Id]
inst_tvs
lhs_env :: TvSubstEnv
lhs_env = HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs [Type]
inst_tys
lhs_subst :: TCvSubst
lhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
lhs_env
rhs_env :: TvSubstEnv
rhs_env = HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs [Type]
underlying_inst_tys
rhs_subst :: TCvSubst
rhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
rhs_env
mk_atf_inst :: TyCon -> TcM FamInst
mk_atf_inst :: TyCon -> TcM FamInst
mk_atf_inst TyCon
fam_tc = do
Name
rep_tc_name <- LocatedN Name -> [Type] -> TcM Name
newFamInstTyConName (forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn (TyCon -> Name
tyConName TyCon
fam_tc))
[Type]
rep_lhs_tys
let axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [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
TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch TyCon
fam_tc (CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
axiom)
FamFlavor -> CoAxiom Unbranched -> TcM FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
axiom
where
fam_tvs :: [Id]
fam_tvs = TyCon -> [Id]
tyConTyVars TyCon
fam_tc
(TCvSubst
_, [Type]
rep_lhs_tys) = TCvSubst -> [Id] -> (TCvSubst, [Type])
substATBndrs TCvSubst
lhs_subst [Id]
fam_tvs
(TCvSubst
_, [Type]
rep_rhs_tys) = TCvSubst -> [Id] -> (TCvSubst, [Type])
substATBndrs TCvSubst
rhs_subst [Id]
fam_tvs
rep_rhs_ty :: Type
rep_rhs_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
rep_rhs_tys
rep_tcvs :: [Id]
rep_tcvs = [Type] -> [Id]
tyCoVarsOfTypesList [Type]
rep_lhs_tys
([Id]
rep_tvs, [Id]
rep_cvs) = 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 = forall a an. a -> LocatedAn an a
noLocA (forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType SrcSpan
noSrcSpan LHsExpr (GhcPass 'Parsed)
e HsWildCardBndrs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
hs_ty)
where
hs_ty :: HsWildCardBndrs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed)))
hs_ty = forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs forall a b. (a -> b) -> a -> b
$ forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec forall a b. (a -> b) -> a -> b
$ Type -> LHsType (GhcPass 'Parsed)
nlHsCoreTy Type
s
nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
nlHsCoreTy :: Type -> LHsType (GhcPass 'Parsed)
nlHsCoreTy = forall a an. a -> LocatedAn an a
noLocA forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall pass. XXType pass -> HsType pass
XHsType
mkCoerceClassMethEqn :: Class
-> [TyVar]
-> [Type]
-> Type
-> Id
-> Pair Type
mkCoerceClassMethEqn :: Class -> [Id] -> [Type] -> Type -> Id -> Pair Type
mkCoerceClassMethEqn Class
cls [Id]
inst_tvs [Type]
inst_tys Type
rhs_ty Id
id
= forall a. a -> a -> Pair a
Pair (HasDebugCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
rhs_subst Type
user_meth_ty)
(HasDebugCallStack => TCvSubst -> Type -> Type
substTy TCvSubst
lhs_subst Type
user_meth_ty)
where
cls_tvs :: [Id]
cls_tvs = Class -> [Id]
classTyVars Class
cls
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet forall a b. (a -> b) -> a -> b
$ [Id] -> VarSet
mkVarSet [Id]
inst_tvs
lhs_subst :: TCvSubst
lhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope (HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs [Type]
inst_tys)
rhs_subst :: TCvSubst
rhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope (HasDebugCallStack => [Id] -> [Type] -> TvSubstEnv
zipTyEnv [Id]
cls_tvs (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)
genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal :: DynFlags
-> SrcSpan
-> AuxBindSpec
-> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBindSpecOriginal DynFlags
dflags SrcSpan
loc AuxBindSpec
spec
= (AuxBindSpec -> LHsBind (GhcPass 'Parsed)
gen_bind AuxBindSpec
spec,
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig forall a. EpAnn a
noAnn [forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn (AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
spec)]
(SrcSpan -> AuxBindSpec -> LHsSigWcType (GhcPass 'Parsed)
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
spec)))
where
loca :: SrcSpanAnnA
loca = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
locn :: SrcSpanAnn' (EpAnn NameAnn)
locn = forall ann. SrcSpan -> SrcAnn ann
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]],
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar 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 = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
intDataCon_RDR)
(forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
NoSourceText Integer
max_tag))
max_tag :: Integer
max_tag = case (TyCon -> [DataCon]
tyConDataCons TyCon
tycon) of
[DataCon]
data_cons -> forall a. Integral a => a -> Integer
toInteger ((forall (t :: * -> *) a. Foldable t => t a -> Int
length [DataCon]
data_cons) 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 :: String
tc_name_string = OccName -> String
occNameString (forall a. NamedThing a => a -> OccName
getOccName Name
tc_name)
definition_mod_name :: String
definition_mod_name = ModuleName -> String
moduleNameString (forall unit. GenModule unit -> ModuleName
moduleName (forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"gen_bind DerivDataDataType" forall a b. (a -> b) -> a -> b
$ Name -> Maybe Module
nameModule_maybe Name
tc_name))
ctx :: SDocContext
ctx = DynFlags -> SDocContext
initDefaultSDocContext DynFlags
dflags
rhs :: LHsExpr (GhcPass 'Parsed)
rhs = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
mkDataType_RDR
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (String -> SDoc
text String
definition_mod_name SDoc -> SDoc -> SDoc
<> SDoc
dot SDoc -> SDoc -> SDoc
<> String -> SDoc
text String
tc_name_string)))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList (forall a b. (a -> b) -> [a] -> [b]
map 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 = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsApps RdrName
mkConstrTag_RDR [LocatedA (HsExpr (GhcPass 'Parsed))]
constr_args
constr_args :: [LocatedA (HsExpr (GhcPass 'Parsed))]
constr_args
= [ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
dataT_RDR
, forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (OccName -> String
occNameString OccName
dc_occ))
, forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit (forall a. Integral a => a -> Integer
toInteger (DataCon -> Int
dataConTag DataCon
dc))
, [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nlList [LocatedA (HsExpr (GhcPass 'Parsed))]
labels
, forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
fixity ]
labels :: [LocatedA (HsExpr (GhcPass 'Parsed))]
labels = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FastString
flLabel)
(DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
dc_occ :: OccName
dc_occ = forall a. NamedThing a => a -> OccName
getOccName DataCon
dc
is_infix :: Bool
is_infix = OccName -> Bool
isDataSymOcc OccName
dc_occ
fixity :: RdrName
fixity | Bool
is_infix = RdrName
infix_RDR
| Bool
otherwise = RdrName
prefix_RDR
genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup :: SrcSpan
-> RdrName
-> AuxBindSpec
-> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBindSpecDup SrcSpan
loc RdrName
original_rdr_name AuxBindSpec
dup_spec
= (SrcSpan
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsBind (GhcPass 'Parsed)
mkHsVarBind SrcSpan
loc RdrName
dup_rdr_name (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
original_rdr_name),
forall l e. l -> e -> GenLocated l e
L SrcSpanAnnA
loca (forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig forall a. EpAnn a
noAnn [forall l e. l -> e -> GenLocated l e
L SrcSpanAnn' (EpAnn NameAnn)
locn RdrName
dup_rdr_name]
(SrcSpan -> AuxBindSpec -> LHsSigWcType (GhcPass 'Parsed)
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
dup_spec)))
where
loca :: SrcSpanAnnA
loca = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
locn :: SrcSpanAnn' (EpAnn NameAnn)
locn = forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc
dup_rdr_name :: RdrName
dup_rdr_name = AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
dup_spec
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType (GhcPass 'Parsed)
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
spec = case AuxBindSpec
spec of
DerivTag2Con TyCon
tycon RdrName
_
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
-> HsWildCardBndrs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)))
mk_sig forall a b. (a -> b) -> a -> b
$ forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) forall a b. (a -> b) -> a -> b
$
forall pass. XXType pass -> HsType pass
XHsType forall a b. (a -> b) -> a -> b
$ [Id] -> Type -> Type
mkSpecForAllTys (TyCon -> [Id]
tyConTyVars TyCon
tycon) forall a b. (a -> b) -> a -> b
$
Type
intTy Type -> Type -> Type
`mkVisFunTyMany` TyCon -> Type
mkParentType TyCon
tycon
DerivMaxTag TyCon
_ RdrName
_
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
-> HsWildCardBndrs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)))
mk_sig (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) (forall pass. XXType pass -> HsType pass
XHsType Type
intTy))
DerivDataDataType TyCon
_ RdrName
_ [RdrName]
_
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
-> HsWildCardBndrs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)))
mk_sig (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted RdrName
dataType_RDR)
DerivDataConstr DataCon
_ RdrName
_ RdrName
_
-> GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
-> HsWildCardBndrs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)))
mk_sig (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
PromotionFlag -> IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar PromotionFlag
NotPromoted RdrName
constr_RDR)
where
mk_sig :: GenLocated SrcSpanAnnA (HsType (GhcPass 'Parsed))
-> HsWildCardBndrs
(GhcPass 'Parsed)
(GenLocated SrcSpanAnnA (HsSigType (GhcPass 'Parsed)))
mk_sig = forall thing. thing -> HsWildCardBndrs (GhcPass 'Parsed) thing
mkHsWildCardBndrs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType (GhcPass 'Parsed) -> HsSigType (GhcPass 'Parsed)
mkHsImplicitSigType
genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec
-> Bag (LHsBind GhcPs, LSig GhcPs)
genAuxBinds :: DynFlags
-> SrcSpan
-> Bag AuxBindSpec
-> Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBinds DynFlags
dflags SrcSpan
loc = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AuxBindSpec
-> (OccEnv RdrName,
Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)))
-> (OccEnv RdrName,
Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)))
gen_aux_bind_spec (forall a. OccEnv a
emptyOccEnv, forall a. Bag a
emptyBag)
where
gen_aux_bind_spec :: AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
gen_aux_bind_spec :: AuxBindSpec
-> (OccEnv RdrName,
Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)))
-> (OccEnv RdrName,
Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed)))
gen_aux_bind_spec AuxBindSpec
spec (OccEnv RdrName
original_rdr_name_env, Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
spec_bag) =
case forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv RdrName
original_rdr_name_env OccName
spec_occ of
Maybe RdrName
Nothing
-> ( forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv RdrName
original_rdr_name_env OccName
spec_occ RdrName
spec_rdr_name
, DynFlags
-> SrcSpan
-> AuxBindSpec
-> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBindSpecOriginal DynFlags
dflags SrcSpan
loc AuxBindSpec
spec forall a. a -> Bag a -> Bag a
`consBag` Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
spec_bag )
Just RdrName
original_rdr_name
-> ( OccEnv RdrName
original_rdr_name_env
, SrcSpan
-> RdrName
-> AuxBindSpec
-> (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
genAuxBindSpecDup SrcSpan
loc RdrName
original_rdr_name AuxBindSpec
spec forall a. a -> Bag a -> Bag a
`consBag` Bag (LHsBind (GhcPass 'Parsed), LSig (GhcPass 'Parsed))
spec_bag )
where
spec_rdr_name :: RdrName
spec_rdr_name = AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
spec
spec_occ :: OccName
spec_occ = RdrName -> OccName
rdrNameOcc RdrName
spec_rdr_name
mkParentType :: TyCon -> Type
mkParentType :: TyCon -> Type
mkParentType TyCon
tc
= case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tc of
Maybe (TyCon, [Type])
Nothing -> TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([Id] -> [Type]
mkTyVarTys (TyCon -> [Id]
tyConTyVars TyCon
tc))
Just (TyCon
fam_tc,[Type]
tys) -> TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
tys
mkFunBindSE :: Arity -> SrcSpan -> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE :: Int
-> SrcSpan
-> RdrName
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindSE Int
arity SrcSpan
loc RdrName
fun [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs
= Int
-> LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindSE Int
arity (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun) [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches
where
matches :: [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches = [forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun))
(forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
p) LocatedA (HsExpr (GhcPass 'Parsed))
e
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
| ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
p,LocatedA (HsExpr (GhcPass 'Parsed))
e) <-[([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs]
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind :: LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBind fun :: LocatedAn NameAnn RdrName
fun@(L SrcSpanAnn' (EpAnn NameAnn)
loc RdrName
_fun_rdr) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
= forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnn' (EpAnn NameAnn)
loc) (Origin
-> LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)
mkFunBind Origin
Generated LocatedAn NameAnn RdrName
fun [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches)
mkFunBindEC :: Arity -> SrcSpan -> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC :: Int
-> SrcSpan
-> RdrName
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkFunBindEC Int
arity SrcSpan
loc RdrName
fun LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs
= Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
arity LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun) [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches
where
matches :: [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches = [ forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs (forall l e. l -> e -> GenLocated l e
L (forall ann. SrcSpan -> SrcAnn ann
noAnnSrcSpan SrcSpan
loc) RdrName
fun))
(forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
p) LocatedA (HsExpr (GhcPass 'Parsed))
e
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds
| ([GenLocated SrcSpanAnnA (Pat (GhcPass 'Parsed))]
p,LocatedA (HsExpr (GhcPass 'Parsed))
e) <- [([LPat (GhcPass 'Parsed)], LHsExpr (GhcPass 'Parsed))]
pats_and_exprs ]
mkRdrFunBindEC :: Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LocatedN RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC :: Int
-> (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))
-> LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindEC Int
arity LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all fun :: LocatedAn NameAnn RdrName
fun@(L SrcSpanAnn' (EpAnn NameAnn)
loc RdrName
_fun_rdr) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
= forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnn' (EpAnn NameAnn)
loc) (Origin
-> LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)
mkFunBind Origin
Generated LocatedAn NameAnn RdrName
fun [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches')
where
matches' :: [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
then [forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedAn NameAnn RdrName
fun)
(forall a. Int -> a -> [a]
replicate (Int
arity forall a. Num a => a -> a -> a
- Int
1) LPat (GhcPass 'Parsed)
nlWildPat forall a. [a] -> [a] -> [a]
++ [LPat (GhcPass 'Parsed)
z_Pat])
(LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
catch_all forall a b. (a -> b) -> a -> b
$ LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase LHsExpr (GhcPass 'Parsed)
z_Expr [])
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds]
else [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE :: Int
-> LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsBind (GhcPass 'Parsed)
mkRdrFunBindSE Int
arity fun :: LocatedAn NameAnn RdrName
fun@(L SrcSpanAnn' (EpAnn NameAnn)
loc RdrName
fun_rdr) [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
= forall l e. l -> e -> GenLocated l e
L (forall a ann. SrcSpanAnn' a -> SrcAnn ann
na2la SrcSpanAnn' (EpAnn NameAnn)
loc) (Origin
-> LocatedAn NameAnn RdrName
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> HsBindLR (GhcPass 'Parsed) (GhcPass 'Parsed)
mkFunBind Origin
Generated LocatedAn NameAnn RdrName
fun [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches')
where
matches' :: [GenLocated
SrcSpanAnnA
(Match (GhcPass 'Parsed) (LocatedA (HsExpr (GhcPass 'Parsed))))]
matches' = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
then [forall (p :: Pass).
IsPass p =>
HsMatchContext (GhcPass p)
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> HsLocalBinds (GhcPass p)
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (forall p. LIdP (NoGhcTc p) -> HsMatchContext p
mkPrefixFunRhs LocatedAn NameAnn RdrName
fun)
(forall a. Int -> a -> [a]
replicate Int
arity LPat (GhcPass 'Parsed)
nlWildPat)
(String -> LHsExpr (GhcPass 'Parsed)
error_Expr String
str) forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds]
else [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
matches
str :: String
str = String
"Void " forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
fun_rdr)
box :: String
-> LHsExpr GhcPs
-> Type
-> LHsExpr GhcPs
box :: String
-> LHsExpr (GhcPass 'Parsed) -> Type -> LHsExpr (GhcPass 'Parsed)
box String
cls_str LHsExpr (GhcPass 'Parsed)
arg Type
arg_ty = forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
cls_str [(Type, LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))]
boxConTbl Type
arg_ty LHsExpr (GhcPass 'Parsed)
arg
primOrdOps :: String
-> Type
-> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps :: String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
str Type
ty = forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
str [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl Type
ty
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
= [(Type
charPrimTy , (RdrName
ltChar_RDR , RdrName
leChar_RDR
, RdrName
eqChar_RDR , RdrName
geChar_RDR , RdrName
gtChar_RDR ))
,(Type
intPrimTy , (RdrName
ltInt_RDR , RdrName
leInt_RDR
, RdrName
eqInt_RDR , RdrName
geInt_RDR , RdrName
gtInt_RDR ))
,(Type
int8PrimTy , (RdrName
ltInt8_RDR , RdrName
leInt8_RDR
, RdrName
eqInt8_RDR , RdrName
geInt8_RDR , RdrName
gtInt8_RDR ))
,(Type
int16PrimTy , (RdrName
ltInt16_RDR , RdrName
leInt16_RDR
, RdrName
eqInt16_RDR , RdrName
geInt16_RDR , RdrName
gtInt16_RDR ))
,(Type
int32PrimTy , (RdrName
ltInt32_RDR , RdrName
leInt32_RDR
, RdrName
eqInt32_RDR , RdrName
geInt32_RDR , RdrName
gtInt32_RDR ))
,(Type
int64PrimTy , (RdrName
ltInt64_RDR , RdrName
leInt64_RDR
, RdrName
eqInt64_RDR , RdrName
geInt64_RDR , RdrName
gtInt64_RDR ))
,(Type
wordPrimTy , (RdrName
ltWord_RDR , RdrName
leWord_RDR
, RdrName
eqWord_RDR , RdrName
geWord_RDR , RdrName
gtWord_RDR ))
,(Type
word8PrimTy , (RdrName
ltWord8_RDR , RdrName
leWord8_RDR
, RdrName
eqWord8_RDR , RdrName
geWord8_RDR , RdrName
gtWord8_RDR ))
,(Type
word16PrimTy, (RdrName
ltWord16_RDR, RdrName
leWord16_RDR
, RdrName
eqWord16_RDR, RdrName
geWord16_RDR, RdrName
gtWord16_RDR ))
,(Type
word32PrimTy, (RdrName
ltWord32_RDR, RdrName
leWord32_RDR
, RdrName
eqWord32_RDR, RdrName
geWord32_RDR, RdrName
gtWord32_RDR ))
,(Type
word64PrimTy, (RdrName
ltWord64_RDR, RdrName
leWord64_RDR
, RdrName
eqWord64_RDR, RdrName
geWord64_RDR, RdrName
gtWord64_RDR ))
,(Type
addrPrimTy , (RdrName
ltAddr_RDR , RdrName
leAddr_RDR
, RdrName
eqAddr_RDR , RdrName
geAddr_RDR , RdrName
gtAddr_RDR ))
,(Type
floatPrimTy , (RdrName
ltFloat_RDR , RdrName
leFloat_RDR
, RdrName
eqFloat_RDR , RdrName
geFloat_RDR , RdrName
gtFloat_RDR ))
,(Type
doublePrimTy, (RdrName
ltDouble_RDR, RdrName
leDouble_RDR
, RdrName
eqDouble_RDR, RdrName
geDouble_RDR, RdrName
gtDouble_RDR)) ]
boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
boxConTbl :: [(Type, LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))]
boxConTbl =
[ (Type
charPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
charDataCon))
, (Type
intPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon))
, (Type
wordPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon ))
, (Type
floatPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
floatDataCon ))
, (Type
doublePrimTy, forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
doubleDataCon))
, (Type
int8PrimTy,
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
int8ToInt_RDR))
, (Type
word8PrimTy,
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
word8ToWord_RDR))
, (Type
int16PrimTy,
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
int16ToInt_RDR))
, (Type
word16PrimTy,
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
word16ToWord_RDR))
, (Type
int32PrimTy,
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
int32ToInt_RDR))
, (Type
word32PrimTy,
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar forall a b. (a -> b) -> a -> b
$ forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
word32ToWord_RDR))
]
postfixModTbl :: [(Type, String)]
postfixModTbl :: [(Type, String)]
postfixModTbl
= [(Type
charPrimTy , String
"#" )
,(Type
intPrimTy , String
"#" )
,(Type
wordPrimTy , String
"##")
,(Type
floatPrimTy , String
"#" )
,(Type
doublePrimTy, String
"##")
,(Type
int8PrimTy, String
"#")
,(Type
word8PrimTy, String
"##")
,(Type
int16PrimTy, String
"#")
,(Type
word16PrimTy, String
"##")
,(Type
int32PrimTy, String
"#")
,(Type
word32PrimTy, String
"##")
]
primConvTbl :: [(Type, String)]
primConvTbl :: [(Type, String)]
primConvTbl =
[ (Type
int8PrimTy, String
"intToInt8#")
, (Type
word8PrimTy, String
"wordToWord8#")
, (Type
int16PrimTy, String
"intToInt16#")
, (Type
word16PrimTy, String
"wordToWord16#")
, (Type
int32PrimTy, String
"intToInt32#")
, (Type
word32PrimTy, String
"wordToWord32#")
]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl :: [(Type, LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed))]
litConTbl
= [(Type
charPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
charPrimL_RDR))
,(Type
intPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
intPrimL_RDR)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
toInteger_RDR))
,(Type
wordPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
wordPrimL_RDR)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
toInteger_RDR))
,(Type
addrPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
stringPrimL_RDR)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
map_RDR)
(RdrName
compose_RDR forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)
`nlHsApps`
[ forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
fromIntegral_RDR
, forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
fromEnum_RDR
])))
,(Type
floatPrimTy , forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
floatPrimL_RDR)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
toRational_RDR))
,(Type
doublePrimTy, forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
doublePrimL_RDR)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
toRational_RDR))
]
assoc_ty_id :: HasCallStack => String
-> [(Type,a)]
-> Type
-> a
assoc_ty_id :: forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
cls_str [(Type, a)]
tbl Type
ty
| Just a
a <- forall a. [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, a)]
tbl Type
ty = a
a
| Bool
otherwise =
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Error in deriving:"
(String -> SDoc
text String
"Can't derive" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
cls_str SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"for primitive type" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Type
ty)
assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe :: forall a. [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, a)]
tbl Type
ty = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Type
t, a
_) -> Type
t Type -> Type -> Bool
`eqType` Type
ty) [(Type, a)]
tbl
and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
and_Expr LHsExpr (GhcPass 'Parsed)
a LHsExpr (GhcPass 'Parsed)
b = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
a RdrName
and_RDR LHsExpr (GhcPass 'Parsed)
b
eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr :: Type
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
eq_Expr Type
ty LHsExpr (GhcPass 'Parsed)
a LHsExpr (GhcPass 'Parsed)
b
| Bool -> Bool
not (HasDebugCallStack => Type -> Bool
isUnliftedType Type
ty) = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
a RdrName
eq_RDR LHsExpr (GhcPass 'Parsed)
b
| Bool
otherwise = LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
a RdrName
prim_eq LHsExpr (GhcPass 'Parsed)
b
where
(RdrName
_, RdrName
_, RdrName
prim_eq, RdrName
_, RdrName
_) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Eq" Type
ty
untag_Expr :: [(RdrName, RdrName)]
-> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr :: [(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [] LHsExpr (GhcPass 'Parsed)
expr = LHsExpr (GhcPass 'Parsed)
expr
untag_Expr ((RdrName
untag_this, RdrName
put_tag_here) : [(RdrName, RdrName)]
more) LHsExpr (GhcPass 'Parsed)
expr
= LHsExpr (GhcPass 'Parsed)
-> [LMatch (GhcPass 'Parsed) (LHsExpr (GhcPass 'Parsed))]
-> LHsExpr (GhcPass 'Parsed)
nlHsCase (forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)
nlHsVarApps RdrName
dataToTag_RDR [RdrName
untag_this]))
[forall (p :: Pass) (body :: * -> *).
(Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA) =>
LPat (GhcPass p)
-> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
put_tag_here) ([(RdrName, RdrName)]
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
untag_Expr [(RdrName, RdrName)]
more LHsExpr (GhcPass 'Parsed)
expr)]
enum_from_to_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
enum_from_then_to_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
enum_from_to_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
enum_from_to_Expr LHsExpr (GhcPass 'Parsed)
f LHsExpr (GhcPass 'Parsed)
t2 = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
enumFromTo_RDR) LHsExpr (GhcPass 'Parsed)
f) LHsExpr (GhcPass 'Parsed)
t2
enum_from_then_to_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
enum_from_then_to_Expr LHsExpr (GhcPass 'Parsed)
f LHsExpr (GhcPass 'Parsed)
t LHsExpr (GhcPass 'Parsed)
t2 = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
enumFromThenTo_RDR) LHsExpr (GhcPass 'Parsed)
f) LHsExpr (GhcPass 'Parsed)
t) LHsExpr (GhcPass 'Parsed)
t2
showParen_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
showParen_Expr :: LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
showParen_Expr LHsExpr (GhcPass 'Parsed)
e1 LHsExpr (GhcPass 'Parsed)
e2 = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
showParen_RDR) LHsExpr (GhcPass 'Parsed)
e1) LHsExpr (GhcPass 'Parsed)
e2
nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr :: [LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr [] = forall a. String -> a
panic String
"nested_compose_expr"
nested_compose_Expr [LHsExpr (GhcPass 'Parsed)
e] = LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
parenify LHsExpr (GhcPass 'Parsed)
e
nested_compose_Expr (LHsExpr (GhcPass 'Parsed)
e:[LHsExpr (GhcPass 'Parsed)]
es)
= forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
compose_RDR) (LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
parenify LHsExpr (GhcPass 'Parsed)
e)) ([LHsExpr (GhcPass 'Parsed)] -> LHsExpr (GhcPass 'Parsed)
nested_compose_Expr [LHsExpr (GhcPass 'Parsed)]
es)
error_Expr :: String -> LHsExpr GhcPs
error_Expr :: String -> LHsExpr (GhcPass 'Parsed)
error_Expr String
string = forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
error_RDR) (forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
string))
illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
illegal_Expr :: String -> String -> String -> LHsExpr (GhcPass 'Parsed)
illegal_Expr String
meth String
tp String
msg =
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
error_RDR) (forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String
meth forall a. [a] -> [a] -> [a]
++ Char
'{'forall a. a -> [a] -> [a]
:String
tp forall a. [a] -> [a] -> [a]
++ String
"}: " forall a. [a] -> [a] -> [a]
++ String
msg)))
illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
illegal_toEnum_tag :: String -> RdrName -> LHsExpr (GhcPass 'Parsed)
illegal_toEnum_tag String
tp RdrName
maxtag =
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
error_RDR)
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
append_RDR)
(forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String
"toEnum{" forall a. [a] -> [a] -> [a]
++ String
tp forall a. [a] -> [a] -> [a]
++ String
"}: tag ("))))
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
showsPrec_RDR)
(forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a_RDR))
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
append_RDR)
(forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
") is outside of enumeration's range (0,")))
(forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
showsPrec_RDR)
(forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
(forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
maxtag))
(forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
")"))))))
parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
parenify :: LHsExpr (GhcPass 'Parsed) -> LHsExpr (GhcPass 'Parsed)
parenify e :: LHsExpr (GhcPass 'Parsed)
e@(L SrcSpanAnnA
_ (HsVar XVar (GhcPass 'Parsed)
_ LIdP (GhcPass 'Parsed)
_)) = LHsExpr (GhcPass 'Parsed)
e
parenify LHsExpr (GhcPass 'Parsed)
e = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar LHsExpr (GhcPass 'Parsed)
e
genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp :: LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
op LHsExpr (GhcPass 'Parsed)
e2 = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
op LHsExpr (GhcPass 'Parsed)
e2)
genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp :: LHsExpr (GhcPass 'Parsed)
-> RdrName
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
genPrimOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
op LHsExpr (GhcPass 'Parsed)
e2 = forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
tagToEnum_RDR) (LHsExpr (GhcPass 'Parsed)
-> IdP (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
-> LHsExpr (GhcPass 'Parsed)
nlHsOpApp LHsExpr (GhcPass 'Parsed)
e1 RdrName
op LHsExpr (GhcPass 'Parsed)
e2))
a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
:: RdrName
a_RDR :: RdrName
a_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"a")
b_RDR :: RdrName
b_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"b")
c_RDR :: RdrName
c_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"c")
d_RDR :: RdrName
d_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"d")
f_RDR :: RdrName
f_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"f")
k_RDR :: RdrName
k_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"k")
z_RDR :: RdrName
z_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"z")
ah_RDR :: RdrName
ah_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"a#")
bh_RDR :: RdrName
bh_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"b#")
ch_RDR :: RdrName
ch_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"c#")
dh_RDR :: RdrName
dh_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"d#")
as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
as_RDRs :: [RdrName]
as_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"a"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
i)) | Int
i <- [(Int
1::Int) .. ] ]
bs_RDRs :: [RdrName]
bs_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"b"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
i)) | Int
i <- [(Int
1::Int) .. ] ]
cs_RDRs :: [RdrName]
cs_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"c"forall a. [a] -> [a] -> [a]
++forall a. Show a => a -> String
show Int
i)) | Int
i <- [(Int
1::Int) .. ] ]
a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs
a_Expr :: LHsExpr (GhcPass 'Parsed)
a_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
a_RDR
b_Expr :: LHsExpr (GhcPass 'Parsed)
b_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
b_RDR
c_Expr :: LHsExpr (GhcPass 'Parsed)
c_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
c_RDR
z_Expr :: LHsExpr (GhcPass 'Parsed)
z_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
z_RDR
ltTag_Expr :: LHsExpr (GhcPass 'Parsed)
ltTag_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
ltTag_RDR
eqTag_Expr :: LHsExpr (GhcPass 'Parsed)
eqTag_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
eqTag_RDR
gtTag_Expr :: LHsExpr (GhcPass 'Parsed)
gtTag_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
gtTag_RDR
false_Expr :: LHsExpr (GhcPass 'Parsed)
false_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
false_RDR
true_Expr :: LHsExpr (GhcPass 'Parsed)
true_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
true_RDR
pure_Expr :: LHsExpr (GhcPass 'Parsed)
pure_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
pure_RDR
unsafeCodeCoerce_Expr :: LHsExpr (GhcPass 'Parsed)
unsafeCodeCoerce_Expr = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
nlHsVar RdrName
unsafeCodeCoerce_RDR
a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
a_Pat :: LPat (GhcPass 'Parsed)
a_Pat = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
a_RDR
b_Pat :: LPat (GhcPass 'Parsed)
b_Pat = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
b_RDR
c_Pat :: LPat (GhcPass 'Parsed)
c_Pat = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
c_RDR
d_Pat :: LPat (GhcPass 'Parsed)
d_Pat = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
d_RDR
k_Pat :: LPat (GhcPass 'Parsed)
k_Pat = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
k_RDR
z_Pat :: LPat (GhcPass 'Parsed)
z_Pat = forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LPat (GhcPass p)
nlVarPat RdrName
z_RDR
minusInt_RDR, tagToEnum_RDR :: RdrName
minusInt_RDR :: RdrName
minusInt_RDR = forall thing. NamedThing thing => thing -> RdrName
getRdrName (PrimOp -> Id
primOpId PrimOp
IntSubOp )
tagToEnum_RDR :: RdrName
tagToEnum_RDR = forall thing. NamedThing thing => thing -> RdrName
getRdrName (PrimOp -> Id
primOpId PrimOp
TagToEnumOp)
new_tag2con_rdr_name, new_maxtag_rdr_name
:: SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
dflags TyCon
tycon = SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
dflags TyCon
tycon OccName -> OccName
mkTag2ConOcc
new_maxtag_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_maxtag_rdr_name SrcSpan
dflags TyCon
tycon = SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
dflags TyCon
tycon OccName -> OccName
mkMaxTagOcc
new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name SrcSpan
dflags TyCon
tycon = SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
dflags TyCon
tycon OccName -> OccName
mkDataTOcc
new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name SrcSpan
dflags DataCon
dc = SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
new_dc_deriv_rdr_name SrcSpan
dflags DataCon
dc OccName -> OccName
mkDataCOcc
new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name SrcSpan
loc TyCon
tycon OccName -> OccName
occ_fun
= SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName SrcSpan
loc (TyCon -> Name
tyConName TyCon
tycon) OccName -> OccName
occ_fun
new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
new_dc_deriv_rdr_name SrcSpan
loc DataCon
dc OccName -> OccName
occ_fun
= SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName SrcSpan
loc (DataCon -> Name
dataConName DataCon
dc) OccName -> OccName
occ_fun
newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName SrcSpan
loc Name
parent OccName -> OccName
occ_fun = do
Unique
uniq <- forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Name -> RdrName
Exact forall a b. (a -> b) -> a -> b
$ Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt Unique
uniq (OccName -> OccName
occ_fun (Name -> OccName
nameOccName Name
parent)) SrcSpan
loc
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args = forall a. (a -> Bool) -> [a] -> [a]
filter DataCon -> Bool
isPossible forall a b. (a -> b) -> a -> b
$ TyCon -> [DataCon]
tyConDataCons TyCon
tycon
where
isPossible :: DataCon -> Bool
isPossible DataCon
dc = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ [Type] -> DataCon -> Bool
dataConCannotMatch (DataCon -> [Type] -> [Type]
dataConInstUnivs DataCon
dc [Type]
tycon_args) DataCon
dc
data DerivInstTys = DerivInstTys
{ DerivInstTys -> [Type]
dit_cls_tys :: [Type]
, DerivInstTys -> TyCon
dit_tc :: TyCon
, DerivInstTys -> [Type]
dit_tc_args :: [Type]
, DerivInstTys -> TyCon
dit_rep_tc :: TyCon
, DerivInstTys -> [Type]
dit_rep_tc_args :: [Type]
, DerivInstTys -> DataConEnv [Type]
dit_dc_inst_arg_env :: DataConEnv [Type]
}
instance Outputable DerivInstTys where
ppr :: DerivInstTys -> SDoc
ppr (DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys, dit_tc :: DerivInstTys -> TyCon
dit_tc = TyCon
tc, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc, dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args
, dit_dc_inst_arg_env :: DerivInstTys -> DataConEnv [Type]
dit_dc_inst_arg_env = DataConEnv [Type]
dc_inst_arg_env })
= SDoc -> Int -> SDoc -> SDoc
hang (String -> SDoc
text String
"DerivInstTys")
Int
2 ([SDoc] -> SDoc
vcat [ String -> SDoc
text String
"dit_cls_tys" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
cls_tys
, String -> SDoc
text String
"dit_tc" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
tc
, String -> SDoc
text String
"dit_tc_args" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
tc_args
, String -> SDoc
text String
"dit_rep_tc" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr TyCon
rep_tc
, String -> SDoc
text String
"dit_rep_tc_args" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr [Type]
rep_tc_args
, String -> SDoc
text String
"dit_dc_inst_arg_env" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr DataConEnv [Type]
dc_inst_arg_env ])
derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys DataCon
dc DerivInstTys
dit =
case forall key elt. Uniquable key => UniqFM key elt -> key -> Maybe elt
lookupUFM (DerivInstTys -> DataConEnv [Type]
dit_dc_inst_arg_env DerivInstTys
dit) DataCon
dc of
Just [Type]
inst_arg_tys -> [Type]
inst_arg_tys
Maybe [Type]
Nothing -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"derivDataConInstArgTys" (forall a. Outputable a => a -> SDoc
ppr DataCon
dc)
buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args =
forall key elt. Uniquable key => [(key, elt)] -> UniqFM key elt
listToUFM [ (DataCon
dc, [Type]
inst_arg_tys)
| DataCon
dc <- TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
, let ([Id]
_, [Type]
_, [Type]
inst_arg_tys) =
DataCon -> [Type] -> ([Id], [Type], [Type])
dataConInstSig DataCon
dc forall a b. (a -> b) -> a -> b
$ DataCon -> [Type] -> [Type]
dataConInstUnivs DataCon
dc [Type]
rep_tc_args
]
substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys
substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys
substDerivInstTys TCvSubst
subst
dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc, dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args })
| TCvSubst -> Bool
isEmptyTCvSubst TCvSubst
subst
= DerivInstTys
dit
| Bool
otherwise
= DerivInstTys
dit{ dit_cls_tys :: [Type]
dit_cls_tys = [Type]
cls_tys'
, dit_tc_args :: [Type]
dit_tc_args = [Type]
tc_args'
, dit_rep_tc_args :: [Type]
dit_rep_tc_args = [Type]
rep_tc_args'
, dit_dc_inst_arg_env :: DataConEnv [Type]
dit_dc_inst_arg_env = TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args'
}
where
cls_tys' :: [Type]
cls_tys' = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
cls_tys
tc_args' :: [Type]
tc_args' = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
tc_args
rep_tc_args' :: [Type]
rep_tc_args' = HasDebugCallStack => TCvSubst -> [Type] -> [Type]
substTys TCvSubst
subst [Type]
rep_tc_args
zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys
zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys
zonkDerivInstTys ZonkEnv
ze dit :: DerivInstTys
dit@(DerivInstTys { dit_cls_tys :: DerivInstTys -> [Type]
dit_cls_tys = [Type]
cls_tys
, dit_tc_args :: DerivInstTys -> [Type]
dit_tc_args = [Type]
tc_args
, dit_rep_tc :: DerivInstTys -> TyCon
dit_rep_tc = TyCon
rep_tc
, dit_rep_tc_args :: DerivInstTys -> [Type]
dit_rep_tc_args = [Type]
rep_tc_args }) = do
[Type]
cls_tys' <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
cls_tys
[Type]
tc_args' <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
tc_args
[Type]
rep_tc_args' <- ZonkEnv -> [Type] -> TcM [Type]
zonkTcTypesToTypesX ZonkEnv
ze [Type]
rep_tc_args
forall (f :: * -> *) a. Applicative f => a -> f a
pure DerivInstTys
dit{ dit_cls_tys :: [Type]
dit_cls_tys = [Type]
cls_tys'
, dit_tc_args :: [Type]
dit_tc_args = [Type]
tc_args'
, dit_rep_tc_args :: [Type]
dit_rep_tc_args = [Type]
rep_tc_args'
, dit_dc_inst_arg_env :: DataConEnv [Type]
dit_dc_inst_arg_env = TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv TyCon
rep_tc [Type]
rep_tc_args'
}