{-# LANGUAGE CPP, ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Tc.Deriv.Generate (
BagDerivStuff, DerivStuff(..),
gen_Eq_binds,
gen_Ord_binds,
gen_Enum_binds,
gen_Bounded_binds,
gen_Ix_binds,
gen_Show_binds,
gen_Read_binds,
gen_Data_binds,
gen_Lift_binds,
gen_Newtype_binds,
mkCoerceClassMethEqn,
genAuxBinds,
ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
getPossibleDataCons, tyConInstArgTys
) where
#include "GhclibHsVersions.h"
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Builtin.Utils
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Builtin.Names
import GHC.Builtin.Names.TH
import GHC.Types.Id.Make ( coerceId )
import GHC.Builtin.PrimOps
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Validity ( checkValidCoAxBranch )
import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Core.Type
import GHC.Core.Multiplicity
import GHC.Core.Class
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Lexeme
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Bag
import Data.List ( find, partition, intersperse )
type BagDerivStuff = Bag DerivStuff
data AuxBindSpec
= 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
data DerivStuff
= DerivAuxBind AuxBindSpec
| DerivFamInst FamInst
gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Eq_binds SrcSpan
loc TyCon
tycon [Type]
tycon_args = do
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bag (Located (HsBindLR GhcPs GhcPs))
method_binds, BagDerivStuff
forall a. Bag a
emptyBag)
where
all_cons :: [DataCon]
all_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
([DataCon]
nullary_cons, [DataCon]
non_nullary_cons) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
isNullarySrcDataCon [DataCon]
all_cons
([DataCon]
tag_match_cons, [DataCon]
pat_match_cons) = ([DataCon]
nullary_cons, [DataCon]
non_nullary_cons)
no_tag_match_cons :: Bool
no_tag_match_cons = [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
tag_match_cons
fall_through_eqn :: [([Located (Pat (GhcPass 'Parsed))] , LHsExpr GhcPs)]
fall_through_eqn :: [([Located (Pat GhcPs)], LHsExpr GhcPs)]
fall_through_eqn
| Bool
no_tag_match_cons
= case [DataCon]
pat_match_cons of
[] -> []
[DataCon
_] -> []
[DataCon]
_ ->
[([Located (Pat GhcPs)
LPat GhcPs
nlWildPat, Located (Pat GhcPs)
LPat GhcPs
nlWildPat], LHsExpr GhcPs
false_Expr)]
| Bool
otherwise
= [([Located (Pat GhcPs)
LPat GhcPs
a_Pat, Located (Pat GhcPs)
LPat GhcPs
b_Pat],
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR,RdrName
ah_RDR), (RdrName
b_RDR,RdrName
bh_RDR)]
(LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
ah_RDR) RdrName
eqInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
bh_RDR)))]
method_binds :: Bag (Located (HsBindLR GhcPs GhcPs))
method_binds = Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
eq_bind
eq_bind :: LHsBind GhcPs
eq_bind
= Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
2 SrcSpan
loc RdrName
eq_RDR (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a b. a -> b -> a
const Located (HsExpr GhcPs)
LHsExpr GhcPs
true_Expr)
((DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs)))
-> [DataCon] -> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
pats_etc [DataCon]
pat_match_cons
[([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
-> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
-> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
forall a. [a] -> [a] -> [a]
++ [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
[([Located (Pat GhcPs)], LHsExpr GhcPs)]
fall_through_eqn)
pats_etc :: DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
pats_etc DataCon
data_con
= let
con1_pat :: LPat GhcPs
con1_pat = LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
con2_pat :: LPat GhcPs
con2_pat = LPat GhcPs -> LPat GhcPs
forall (name :: Pass). LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat (LPat GhcPs -> LPat GhcPs) -> LPat GhcPs -> LPat GhcPs
forall a b. (a -> b) -> a -> b
$ RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
con_arity :: Arity
con_arity = [Scaled Type] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Scaled Type]
tys_needed
as_needed :: [RdrName]
as_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
as_RDRs
bs_needed :: [RdrName]
bs_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
bs_RDRs
tys_needed :: [Scaled Type]
tys_needed = DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
data_con
in
([Located (Pat GhcPs)
LPat GhcPs
con1_pat, Located (Pat GhcPs)
LPat GhcPs
con2_pat], [Type] -> [RdrName] -> [RdrName] -> Located (HsExpr GhcPs)
nested_eq_expr ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
tys_needed) [RdrName]
as_needed [RdrName]
bs_needed)
where
nested_eq_expr :: [Type] -> [RdrName] -> [RdrName] -> Located (HsExpr GhcPs)
nested_eq_expr [] [] [] = Located (HsExpr GhcPs)
LHsExpr GhcPs
true_Expr
nested_eq_expr [Type]
tys [RdrName]
as [RdrName]
bs
= (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> [Located (HsExpr GhcPs)] -> Located (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr (String
-> (Type -> RdrName -> RdrName -> Located (HsExpr GhcPs))
-> [Type]
-> [RdrName]
-> [RdrName]
-> [Located (HsExpr GhcPs)]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"nested_eq" Type -> RdrName -> RdrName -> Located (HsExpr GhcPs)
nested_eq [Type]
tys [RdrName]
as [RdrName]
bs)
where
nested_eq :: Type -> RdrName -> RdrName -> LHsExpr GhcPs
nested_eq Type
ty RdrName
a RdrName
b = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr Type
ty (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a) (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b))
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 GhcPs
ltResult OrdOp
OrdCompare = LHsExpr GhcPs
ltTag_Expr
ltResult OrdOp
OrdLT = LHsExpr GhcPs
true_Expr
ltResult OrdOp
OrdLE = LHsExpr GhcPs
true_Expr
ltResult OrdOp
OrdGE = LHsExpr GhcPs
false_Expr
ltResult OrdOp
OrdGT = LHsExpr GhcPs
false_Expr
eqResult :: OrdOp -> LHsExpr GhcPs
eqResult :: OrdOp -> LHsExpr GhcPs
eqResult OrdOp
OrdCompare = LHsExpr GhcPs
eqTag_Expr
eqResult OrdOp
OrdLT = LHsExpr GhcPs
false_Expr
eqResult OrdOp
OrdLE = LHsExpr GhcPs
true_Expr
eqResult OrdOp
OrdGE = LHsExpr GhcPs
true_Expr
eqResult OrdOp
OrdGT = LHsExpr GhcPs
false_Expr
gtResult :: OrdOp -> LHsExpr GhcPs
gtResult :: OrdOp -> LHsExpr GhcPs
gtResult OrdOp
OrdCompare = LHsExpr GhcPs
gtTag_Expr
gtResult OrdOp
OrdLT = LHsExpr GhcPs
false_Expr
gtResult OrdOp
OrdLE = LHsExpr GhcPs
false_Expr
gtResult OrdOp
OrdGE = LHsExpr GhcPs
true_Expr
gtResult OrdOp
OrdGT = LHsExpr GhcPs
true_Expr
gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ord_binds SrcSpan
loc TyCon
tycon [Type]
tycon_args = do
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff))
-> (Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
forall a b. (a -> b) -> a -> b
$ if [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
tycon_data_cons
then ( Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag (Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs)))
-> Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a b. (a -> b) -> a -> b
$ Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
2 SrcSpan
loc RdrName
compare_RDR (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a b. a -> b -> a
const Located (HsExpr GhcPs)
LHsExpr GhcPs
eqTag_Expr) []
, BagDerivStuff
forall a. Bag a
emptyBag)
else ( Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag (OrdOp -> LHsBind GhcPs
mkOrdOp OrdOp
OrdCompare)
Bag (Located (HsBindLR GhcPs GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (Located (HsBindLR GhcPs GhcPs))
other_ops
, BagDerivStuff
forall a. Bag a
aux_binds)
where
aux_binds :: Bag a
aux_binds = Bag a
forall a. Bag a
emptyBag
other_ops :: Bag (Located (HsBindLR GhcPs GhcPs))
other_ops
| (Arity
last_tag Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
first_tag) Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
<= Arity
2
Bool -> Bool -> Bool
|| [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons
= [Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [OrdOp -> LHsBind GhcPs
mkOrdOp OrdOp
OrdLT, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
lE, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
gT, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
gE]
| Bool
otherwise
= Bag (Located (HsBindLR GhcPs GhcPs))
forall a. Bag a
emptyBag
negate_expr :: LHsExpr GhcPs -> LHsExpr GhcPs
negate_expr = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
not_RDR)
lE :: LHsBind GhcPs
lE = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
le_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
negate_expr (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
lt_RDR) LHsExpr GhcPs
b_Expr) LHsExpr GhcPs
a_Expr)
gT :: LHsBind GhcPs
gT = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
gt_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
lt_RDR) LHsExpr GhcPs
b_Expr) LHsExpr GhcPs
a_Expr
gE :: LHsBind GhcPs
gE = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
ge_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
negate_expr (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
lt_RDR) LHsExpr GhcPs
a_Expr) LHsExpr GhcPs
b_Expr)
get_tag :: DataCon -> Arity
get_tag DataCon
con = DataCon -> Arity
dataConTag DataCon
con Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
fIRST_TAG
tycon_data_cons :: [DataCon]
tycon_data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
single_con_type :: Bool
single_con_type = [DataCon] -> Bool
forall a. [a] -> Bool
isSingleton [DataCon]
tycon_data_cons
(DataCon
first_con : [DataCon]
_) = [DataCon]
tycon_data_cons
(DataCon
last_con : [DataCon]
_) = [DataCon] -> [DataCon]
forall a. [a] -> [a]
reverse [DataCon]
tycon_data_cons
first_tag :: Arity
first_tag = DataCon -> Arity
get_tag DataCon
first_con
last_tag :: Arity
last_tag = DataCon -> Arity
get_tag DataCon
last_con
([DataCon]
nullary_cons, [DataCon]
non_nullary_cons) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
isNullarySrcDataCon [DataCon]
tycon_data_cons
mkOrdOp :: OrdOp -> LHsBind GhcPs
mkOrdOp :: OrdOp -> LHsBind GhcPs
mkOrdOp OrdOp
op
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc (OrdOp -> RdrName
ordMethRdr OrdOp
op) [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat]
(OrdOp -> LHsExpr GhcPs
mkOrdOpRhs OrdOp
op)
mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
mkOrdOpRhs OrdOp
op
| [DataCon]
nullary_cons [DataCon] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthAtMost` Arity
2
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a_RDR) ([LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
(DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt OrdOp
op) [DataCon]
tycon_data_cons
| [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
non_nullary_cons
= OrdOp -> LHsExpr GhcPs
mkTagCmp OrdOp
op
| Bool
otherwise
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a_RDR) ([LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs)
-> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
((DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map (OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt OrdOp
op) [DataCon]
non_nullary_cons
[Located (Match GhcPs (Located (HsExpr GhcPs)))]
-> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
-> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
mkTagCmp OrdOp
op)])
mkOrdOpAlt :: OrdOp -> DataCon
-> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt OrdOp
op DataCon
data_con
= LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed)
(OrdOp -> DataCon -> Located (HsExpr GhcPs)
mkInnerRhs OrdOp
op DataCon
data_con)
where
as_needed :: [RdrName]
as_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
data_con) [RdrName]
as_RDRs
data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
mkInnerRhs :: OrdOp -> DataCon -> Located (HsExpr GhcPs)
mkInnerRhs OrdOp
op DataCon
data_con
| Bool
single_con_type
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con ]
| Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
first_tag
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
, LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) ]
| Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
last_tag
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
, LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) ]
| Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
first_tag Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
+ Arity
1
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR) [ LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat GhcPs
nlConWildPat DataCon
first_con)
(OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op)
, OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
, LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) ]
| Arity
tag Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
last_tag Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR) [ LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (DataCon -> LPat GhcPs
nlConWildPat DataCon
last_con)
(OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op)
, OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
, LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) ]
| Arity
tag Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
last_tag Arity -> Arity -> Arity
forall a. Integral a => a -> a -> a
`div` Arity
2
= [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
bh_RDR) RdrName
ltInt_RDR Located (HsExpr GhcPs)
LHsExpr GhcPs
tag_lit)
(OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
, LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) ]
| Bool
otherwise
= [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
bh_RDR) RdrName
gtInt_RDR Located (HsExpr GhcPs)
LHsExpr GhcPs
tag_lit)
(OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR) [ OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
, LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt LPat GhcPs
nlWildPat (OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op) ]
where
tag :: Arity
tag = DataCon -> Arity
get_tag DataCon
data_con
tag_lit :: Located (HsExpr GhcPs)
tag_lit = HsExpr GhcPs -> Located (HsExpr GhcPs)
forall e. e -> Located e
noLoc (XLitE GhcPs -> HsLit GhcPs -> HsExpr GhcPs
forall p. XLitE p -> HsLit p -> HsExpr p
HsLit NoExtField
XLitE GhcPs
noExtField (XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim GhcPs
NoSourceText (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger Arity
tag)))
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt OrdOp
op DataCon
data_con
= LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed) (Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs)))
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
OrdOp -> [Type] -> LHsExpr GhcPs
mkCompareFields OrdOp
op ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
data_con)
where
data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
bs_needed :: [RdrName]
bs_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
data_con) [RdrName]
bs_RDRs
mkTagCmp :: OrdOp -> LHsExpr GhcPs
mkTagCmp :: OrdOp -> LHsExpr GhcPs
mkTagCmp OrdOp
op =
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR),(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp Type
intPrimTy OrdOp
op RdrName
ah_RDR RdrName
bh_RDR
mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
mkCompareFields OrdOp
op [Type]
tys
= [Type] -> [RdrName] -> [RdrName] -> Located (HsExpr GhcPs)
go [Type]
tys [RdrName]
as_RDRs [RdrName]
bs_RDRs
where
go :: [Type] -> [RdrName] -> [RdrName] -> Located (HsExpr GhcPs)
go [] [RdrName]
_ [RdrName]
_ = OrdOp -> LHsExpr GhcPs
eqResult OrdOp
op
go [Type
ty] (RdrName
a:[RdrName]
_) (RdrName
b:[RdrName]
_)
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty = Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
| Bool
otherwise = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a) (OrdOp -> RdrName
ordMethRdr OrdOp
op) (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b)
go (Type
ty:[Type]
tys) (RdrName
a:[RdrName]
as) (RdrName
b:[RdrName]
bs) = Type
-> RdrName
-> RdrName
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
mk_compare Type
ty RdrName
a RdrName
b
(OrdOp -> LHsExpr GhcPs
ltResult OrdOp
op)
([Type] -> [RdrName] -> [RdrName] -> Located (HsExpr GhcPs)
go [Type]
tys [RdrName]
as [RdrName]
bs)
(OrdOp -> LHsExpr GhcPs
gtResult OrdOp
op)
go [Type]
_ [RdrName]
_ [RdrName]
_ = String -> Located (HsExpr GhcPs)
forall a. String -> a
panic String
"mkCompareFields"
mk_compare :: Type
-> RdrName
-> RdrName
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
mk_compare Type
ty RdrName
a RdrName
b Located (HsExpr GhcPs)
lt Located (HsExpr GhcPs)
eq Located (HsExpr GhcPs)
gt
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty
= RdrName
-> RdrName
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr GhcPs
a_expr LHsExpr GhcPs
b_expr Located (HsExpr GhcPs)
LHsExpr GhcPs
lt Located (HsExpr GhcPs)
LHsExpr GhcPs
eq Located (HsExpr GhcPs)
LHsExpr GhcPs
gt
| Bool
otherwise
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
compare_RDR) LHsExpr GhcPs
a_expr) LHsExpr GhcPs
b_expr))
[LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
ltTag_RDR) Located (HsExpr GhcPs)
lt,
LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
eqTag_RDR) Located (HsExpr GhcPs)
eq,
LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (RdrName -> LPat GhcPs
nlNullaryConPat RdrName
gtTag_RDR) Located (HsExpr GhcPs)
gt]
where
a_expr :: LHsExpr GhcPs
a_expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a
b_expr :: LHsExpr GhcPs
b_expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b
(RdrName
lt_op, RdrName
_, RdrName
eq_op, RdrName
_, RdrName
_) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Ord" Type
ty
unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp Type
ty OrdOp
op RdrName
a RdrName
b
= case OrdOp
op of
OrdOp
OrdCompare -> RdrName
-> RdrName
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr GhcPs
a_expr LHsExpr GhcPs
b_expr
LHsExpr GhcPs
ltTag_Expr LHsExpr GhcPs
eqTag_Expr LHsExpr GhcPs
gtTag_Expr
OrdOp
OrdLT -> RdrName -> LHsExpr GhcPs
wrap RdrName
lt_op
OrdOp
OrdLE -> RdrName -> LHsExpr GhcPs
wrap RdrName
le_op
OrdOp
OrdGE -> RdrName -> LHsExpr GhcPs
wrap RdrName
ge_op
OrdOp
OrdGT -> RdrName -> LHsExpr GhcPs
wrap RdrName
gt_op
where
(RdrName
lt_op, RdrName
le_op, RdrName
eq_op, RdrName
ge_op, RdrName
gt_op) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Ord" Type
ty
wrap :: RdrName -> LHsExpr GhcPs
wrap RdrName
prim_op = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a_expr RdrName
prim_op LHsExpr GhcPs
b_expr
a_expr :: LHsExpr GhcPs
a_expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a
b_expr :: LHsExpr GhcPs
b_expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b
unliftedCompare :: RdrName -> RdrName
-> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare :: RdrName
-> RdrName
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare RdrName
lt_op RdrName
eq_op LHsExpr GhcPs
a_expr LHsExpr GhcPs
b_expr LHsExpr GhcPs
lt LHsExpr GhcPs
eq LHsExpr GhcPs
gt
= LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> Located (HsExpr GhcPs)
forall p.
(XExprWithTySig p ~ NoExtField, NoGhcTc p ~ GhcPs) =>
XRec p (HsExpr p) -> Located (HsExpr p)
ascribeBool (LHsExpr GhcPs -> Located (HsExpr GhcPs))
-> LHsExpr GhcPs -> Located (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a_expr RdrName
lt_op LHsExpr GhcPs
b_expr) LHsExpr GhcPs
lt (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (LHsExpr GhcPs -> Located (HsExpr GhcPs)
forall p.
(XExprWithTySig p ~ NoExtField, NoGhcTc p ~ GhcPs) =>
XRec p (HsExpr p) -> Located (HsExpr p)
ascribeBool (LHsExpr GhcPs -> Located (HsExpr GhcPs))
-> LHsExpr GhcPs -> Located (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a_expr RdrName
eq_op LHsExpr GhcPs
b_expr) LHsExpr GhcPs
eq LHsExpr GhcPs
gt
where
ascribeBool :: XRec p (HsExpr p) -> Located (HsExpr p)
ascribeBool XRec p (HsExpr p)
e = HsExpr p -> Located (HsExpr p)
forall e. e -> Located e
noLoc (HsExpr p -> Located (HsExpr p)) -> HsExpr p -> Located (HsExpr p)
forall a b. (a -> b) -> a -> b
$ XExprWithTySig p
-> XRec p (HsExpr p) -> LHsSigWcType (NoGhcTc p) -> HsExpr p
forall p.
XExprWithTySig p
-> LHsExpr p -> LHsSigWcType (NoGhcTc p) -> HsExpr p
ExprWithTySig NoExtField
XExprWithTySig p
noExtField XRec p (HsExpr p)
e
(LHsSigWcType (NoGhcTc p) -> HsExpr p)
-> LHsSigWcType (NoGhcTc p) -> HsExpr p
forall a b. (a -> b) -> a -> b
$ Located (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (Located (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs)))
-> Located (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ HsSigType GhcPs -> Located (HsSigType GhcPs)
forall e. e -> Located e
noLoc (HsSigType GhcPs -> Located (HsSigType GhcPs))
-> HsSigType GhcPs -> Located (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType
(LHsType GhcPs -> HsSigType GhcPs)
-> LHsType GhcPs -> HsSigType GhcPs
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar RdrName
IdP GhcPs
boolTyCon_RDR
nlConWildPat :: DataCon -> LPat GhcPs
nlConWildPat :: DataCon -> LPat GhcPs
nlConWildPat DataCon
con = Pat GhcPs -> Located (Pat GhcPs)
forall e. e -> Located e
noLoc (Pat GhcPs -> Located (Pat GhcPs))
-> Pat GhcPs -> Located (Pat GhcPs)
forall a b. (a -> b) -> a -> b
$ ConPat :: forall p.
XConPat p -> XRec p (ConLikeP p) -> HsConPatDetails p -> Pat p
ConPat
{ pat_con_ext :: XConPat GhcPs
pat_con_ext = NoExtField
XConPat GhcPs
noExtField
, pat_con :: XRec GhcPs (ConLikeP GhcPs)
pat_con = RdrName -> Located RdrName
forall e. e -> Located e
noLoc (RdrName -> Located RdrName) -> RdrName -> Located RdrName
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
, pat_args :: HsConPatDetails GhcPs
pat_args = HsRecFields GhcPs (Located (Pat GhcPs))
-> HsConDetails
(HsPatSigType GhcPs)
(Located (Pat GhcPs))
(HsRecFields GhcPs (Located (Pat GhcPs)))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
RecCon (HsRecFields GhcPs (Located (Pat GhcPs))
-> HsConDetails
(HsPatSigType GhcPs)
(Located (Pat GhcPs))
(HsRecFields GhcPs (Located (Pat GhcPs))))
-> HsRecFields GhcPs (Located (Pat GhcPs))
-> HsConDetails
(HsPatSigType GhcPs)
(Located (Pat GhcPs))
(HsRecFields GhcPs (Located (Pat GhcPs)))
forall a b. (a -> b) -> a -> b
$ HsRecFields :: forall p arg.
[LHsRecField p arg] -> Maybe (Located Arity) -> HsRecFields p arg
HsRecFields
{ rec_flds :: [LHsRecField GhcPs (Located (Pat GhcPs))]
rec_flds = []
, rec_dotdot :: Maybe (Located Arity)
rec_dotdot = Maybe (Located Arity)
forall a. Maybe a
Nothing }
}
gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Enum_binds SrcSpan
loc TyCon
tycon [Type]
_ = 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
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
return ( RdrName -> RdrName -> Bag (Located (HsBindLR GhcPs GhcPs))
method_binds RdrName
tag2con_RDR RdrName
maxtag_RDR
, RdrName -> RdrName -> BagDerivStuff
aux_binds RdrName
tag2con_RDR RdrName
maxtag_RDR )
where
method_binds :: RdrName -> RdrName -> Bag (Located (HsBindLR GhcPs GhcPs))
method_binds RdrName
tag2con_RDR RdrName
maxtag_RDR = [Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag
[ RdrName -> RdrName -> LHsBind GhcPs
succ_enum RdrName
tag2con_RDR RdrName
maxtag_RDR
, RdrName -> LHsBind GhcPs
pred_enum RdrName
tag2con_RDR
, RdrName -> RdrName -> LHsBind GhcPs
to_enum RdrName
tag2con_RDR RdrName
maxtag_RDR
, RdrName -> RdrName -> LHsBind GhcPs
enum_from RdrName
tag2con_RDR RdrName
maxtag_RDR
, RdrName -> RdrName -> LHsBind GhcPs
enum_from_then RdrName
tag2con_RDR RdrName
maxtag_RDR
, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
from_enum
]
aux_binds :: RdrName -> RdrName -> BagDerivStuff
aux_binds RdrName
tag2con_RDR RdrName
maxtag_RDR = [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ([DerivStuff] -> BagDerivStuff) -> [DerivStuff] -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ (AuxBindSpec -> DerivStuff) -> [AuxBindSpec] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map AuxBindSpec -> DerivStuff
DerivAuxBind
[ TyCon -> RdrName -> AuxBindSpec
DerivTag2Con TyCon
tycon RdrName
tag2con_RDR
, TyCon -> RdrName -> AuxBindSpec
DerivMaxTag TyCon
tycon RdrName
maxtag_RDR
]
occ_nm :: String
occ_nm = TyCon -> String
forall a. NamedThing a => a -> String
getOccString TyCon
tycon
succ_enum :: RdrName -> RdrName -> LHsBind GhcPs
succ_enum RdrName
tag2con_RDR RdrName
maxtag_RDR
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
succ_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
eq_RDR [IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
maxtag_RDR,
IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR]])
(String -> String -> String -> LHsExpr GhcPs
illegal_Expr String
"succ" String
occ_nm String
"tried to take `succ' of last tag in enumeration")
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
tag2con_RDR)
(IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
plus_RDR [IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR],
Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
1]))
pred_enum :: RdrName -> LHsBind GhcPs
pred_enum RdrName
tag2con_RDR
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
pred_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
eq_RDR [Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0,
IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR]])
(String -> String -> String -> LHsExpr GhcPs
illegal_Expr String
"pred" String
occ_nm String
"tried to take `pred' of first tag in enumeration")
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
tag2con_RDR)
(IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
plus_RDR
[ IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR]
, HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsInt GhcPs -> IntegralLit -> HsLit GhcPs
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
XHsInt GhcPs
noExtField
(Arity -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit (-Arity
1 :: Int)))]))
to_enum :: RdrName -> RdrName -> LHsBind GhcPs
to_enum RdrName
tag2con_RDR RdrName
maxtag_RDR
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
toEnum_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
and_RDR
[IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
ge_RDR [IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a_RDR, Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0],
IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
le_RDR [ IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a_RDR
, IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
maxtag_RDR]])
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
tag2con_RDR [RdrName
IdP GhcPs
a_RDR])
(String -> RdrName -> LHsExpr GhcPs
illegal_toEnum_tag String
occ_nm RdrName
maxtag_RDR)
enum_from :: RdrName -> RdrName -> LHsBind GhcPs
enum_from RdrName
tag2con_RDR RdrName
maxtag_RDR
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFrom_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
map_RDR
[IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
tag2con_RDR,
LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_to_Expr
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR])
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
maxtag_RDR))]
enum_from_then :: RdrName -> RdrName -> LHsBind GhcPs
enum_from_then RdrName
tag2con_RDR RdrName
maxtag_RDR
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
enumFromThen_RDR [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR), (RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
map_RDR [RdrName
IdP GhcPs
tag2con_RDR]) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_then_to_Expr
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR])
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
bh_RDR])
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsIf (IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
gt_RDR [IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR],
IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
bh_RDR]])
(Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0)
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
maxtag_RDR)
))
from_enum :: LHsBind GhcPs
from_enum
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
fromEnum_RDR [LPat GhcPs
a_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR])
gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Bounded_binds SrcSpan
loc TyCon
tycon [Type]
_
| TyCon -> Bool
isEnumerationTyCon TyCon
tycon
= ([Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [ Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
min_bound_enum, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
max_bound_enum ], BagDerivStuff
forall a. Bag a
emptyBag)
| Bool
otherwise
= ASSERT(isSingleton data_cons)
([Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [ Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
min_bound_1con, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
max_bound_1con ], BagDerivStuff
forall a. Bag a
emptyBag)
where
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
min_bound_enum :: LHsBind GhcPs
min_bound_enum = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
data_con_1_RDR)
max_bound_enum :: LHsBind GhcPs
max_bound_enum = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
maxBound_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
data_con_N_RDR)
data_con_1 :: DataCon
data_con_1 = [DataCon] -> DataCon
forall a. [a] -> a
head [DataCon]
data_cons
data_con_N :: DataCon
data_con_N = [DataCon] -> DataCon
forall a. [a] -> a
last [DataCon]
data_cons
data_con_1_RDR :: RdrName
data_con_1_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con_1
data_con_N_RDR :: RdrName
data_con_N_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con_N
arity :: Arity
arity = DataCon -> Arity
dataConSourceArity DataCon
data_con_1
min_bound_1con :: LHsBind GhcPs
min_bound_1con = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
minBound_RDR (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
data_con_1_RDR (Arity -> RdrName -> [RdrName]
forall a. Arity -> a -> [a]
replicate Arity
arity RdrName
minBound_RDR)
max_bound_1con :: LHsBind GhcPs
max_bound_1con = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
maxBound_RDR (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
data_con_1_RDR (Arity -> RdrName -> [RdrName]
forall a. Arity -> a -> [a]
replicate Arity
arity RdrName
maxBound_RDR)
gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ix_binds SrcSpan
loc TyCon
tycon [Type]
_ = do
RdrName
tag2con_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_tag2con_rdr_name SrcSpan
loc TyCon
tycon
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff))
-> (Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
forall a b. (a -> b) -> a -> b
$ if TyCon -> Bool
isEnumerationTyCon TyCon
tycon
then (RdrName -> Bag (Located (HsBindLR GhcPs GhcPs))
enum_ixes RdrName
tag2con_RDR, [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ([DerivStuff] -> BagDerivStuff) -> [DerivStuff] -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ (AuxBindSpec -> DerivStuff) -> [AuxBindSpec] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map AuxBindSpec -> DerivStuff
DerivAuxBind
[ TyCon -> RdrName -> AuxBindSpec
DerivTag2Con TyCon
tycon RdrName
tag2con_RDR
])
else (Bag (Located (HsBindLR GhcPs GhcPs))
single_con_ixes, BagDerivStuff
forall a. Bag a
emptyBag)
where
enum_ixes :: RdrName -> Bag (Located (HsBindLR GhcPs GhcPs))
enum_ixes RdrName
tag2con_RDR = [Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag
[ RdrName -> LHsBind GhcPs
enum_range RdrName
tag2con_RDR
, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
enum_index
, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
enum_inRange
]
enum_range :: RdrName -> LHsBind GhcPs
enum_range RdrName
tag2con_RDR
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR [[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] Boxity
Boxed] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
map_RDR [RdrName
IdP GhcPs
tag2con_RDR]) (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$
LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_to_Expr
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
ah_RDR])
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
bh_RDR]))
enum_index :: LHsBind GhcPs
enum_index
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
[Pat GhcPs -> Located (Pat GhcPs)
forall e. e -> Located e
noLoc (XAsPat GhcPs -> LIdP GhcPs -> LPat GhcPs -> Pat GhcPs
forall p. XAsPat p -> LIdP p -> LPat p -> Pat p
AsPat NoExtField
XAsPat GhcPs
noExtField (RdrName -> Located RdrName
forall e. e -> Located e
noLoc RdrName
c_RDR)
([LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [LPat GhcPs
a_Pat, LPat GhcPs
nlWildPat] Boxity
Boxed)),
LPat GhcPs
d_Pat] (
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
d_RDR, RdrName
dh_RDR)] (
let
rhs :: LHsExpr GhcPs
rhs = IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
intDataCon_RDR [RdrName
IdP GhcPs
c_RDR]
in
LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase
(LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
dh_RDR) RdrName
minusInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
ah_RDR))
[LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
c_RDR) Located (HsExpr GhcPs)
rhs]
))
)
enum_inRange :: LHsBind GhcPs
enum_inRange
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR [[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [LPat GhcPs
a_Pat, LPat GhcPs
b_Pat] Boxity
Boxed, LPat GhcPs
c_Pat] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
a_RDR, RdrName
ah_RDR)] (
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
b_RDR, RdrName
bh_RDR)] (
[(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName
c_RDR, RdrName
ch_RDR)] (
IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
and_RDR
[ LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
ch_RDR) RdrName
geInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
ah_RDR)
, LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
ch_RDR) RdrName
leInt_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
bh_RDR)
]
)))
single_con_ixes :: Bag (Located (HsBindLR GhcPs GhcPs))
single_con_ixes
= [Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
single_con_range, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
single_con_index, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
single_con_inRange]
data_con :: DataCon
data_con
= case TyCon -> Maybe DataCon
tyConSingleDataCon_maybe TyCon
tycon of
Maybe DataCon
Nothing -> String -> DataCon
forall a. String -> a
panic String
"get_Ix_binds"
Just DataCon
dc -> DataCon
dc
con_arity :: Arity
con_arity = DataCon -> Arity
dataConSourceArity DataCon
data_con
data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
as_needed :: [RdrName]
as_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
as_RDRs
bs_needed :: [RdrName]
bs_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
bs_RDRs
cs_needed :: [RdrName]
cs_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
cs_RDRs
con_pat :: [RdrName] -> LPat GhcPs
con_pat [RdrName]
xs = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
xs
con_expr :: LHsExpr GhcPs
con_expr = IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
data_con_RDR [RdrName]
[IdP GhcPs]
cs_needed
single_con_range :: LHsBind GhcPs
single_con_range
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
range_RDR
[[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [[RdrName] -> LPat GhcPs
con_pat [RdrName]
as_needed, [RdrName] -> LPat GhcPs
con_pat [RdrName]
bs_needed] Boxity
Boxed] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
HsExpr GhcPs -> Located (HsExpr GhcPs)
forall e. e -> Located e
noLoc (HsStmtContext GhcRn
-> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsComp HsStmtContext GhcRn
forall p. HsStmtContext p
ListComp [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
[ExprLStmt GhcPs]
stmts LHsExpr GhcPs
con_expr)
where
stmts :: [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
stmts = String
-> (RdrName
-> RdrName
-> RdrName
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_range" RdrName
-> RdrName
-> RdrName
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
mk_qual [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed
mk_qual :: RdrName
-> RdrName
-> RdrName
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
mk_qual RdrName
a RdrName
b RdrName
c = StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall e. e -> Located e
noLoc (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ LPat GhcPs
-> Located (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
forall (bodyR :: * -> *).
LPat GhcPs
-> Located (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))
mkPsBindStmt (IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
c)
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
range_RDR)
([IdP GhcPs] -> LHsExpr GhcPs
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP GhcPs
a,RdrName
IdP GhcPs
b]))
single_con_index :: LHsBind GhcPs
single_con_index
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
unsafeIndex_RDR
[[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [[RdrName] -> LPat GhcPs
con_pat [RdrName]
as_needed, [RdrName] -> LPat GhcPs
con_pat [RdrName]
bs_needed] Boxity
Boxed,
[RdrName] -> LPat GhcPs
con_pat [RdrName]
cs_needed]
([(RdrName, RdrName, RdrName)] -> Located (HsExpr GhcPs)
mk_index ([(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)]
forall a. [a] -> [a]
reverse ([(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)])
-> [(RdrName, RdrName, RdrName)] -> [(RdrName, RdrName, RdrName)]
forall a b. (a -> b) -> a -> b
$ [RdrName]
-> [RdrName] -> [RdrName] -> [(RdrName, RdrName, RdrName)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed))
where
mk_index :: [(RdrName, RdrName, RdrName)] -> Located (HsExpr GhcPs)
mk_index [] = Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0
mk_index [(RdrName
l,RdrName
u,RdrName
i)] = RdrName -> RdrName -> RdrName -> Located (HsExpr GhcPs)
forall (id :: Pass).
(IsPass id, IdGhcP id ~ RdrName) =>
RdrName -> RdrName -> RdrName -> Located (HsExpr (GhcPass id))
mk_one RdrName
l RdrName
u RdrName
i
mk_index ((RdrName
l,RdrName
u,RdrName
i) : [(RdrName, RdrName, RdrName)]
rest)
= LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (
RdrName -> RdrName -> RdrName -> Located (HsExpr GhcPs)
forall (id :: Pass).
(IsPass id, IdGhcP id ~ RdrName) =>
RdrName -> RdrName -> RdrName -> Located (HsExpr (GhcPass id))
mk_one RdrName
l RdrName
u RdrName
i
) RdrName
plus_RDR (
LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp (
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
unsafeRangeSize_RDR)
([IdP GhcPs] -> LHsExpr GhcPs
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP GhcPs
l,RdrName
IdP GhcPs
u]))
) RdrName
times_RDR ([(RdrName, RdrName, RdrName)] -> Located (HsExpr GhcPs)
mk_index [(RdrName, RdrName, RdrName)]
rest)
)
mk_one :: RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass id)
mk_one RdrName
l RdrName
u RdrName
i
= IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP (GhcPass id)
unsafeIndex_RDR [[IdP (GhcPass id)] -> LHsExpr (GhcPass id)
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP (GhcPass id)
l,RdrName
IdP (GhcPass id)
u], IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass id)
i]
single_con_inRange :: LHsBind GhcPs
single_con_inRange
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
inRange_RDR
[[LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat [[RdrName] -> LPat GhcPs
con_pat [RdrName]
as_needed, [RdrName] -> LPat GhcPs
con_pat [RdrName]
bs_needed] Boxity
Boxed,
[RdrName] -> LPat GhcPs
con_pat [RdrName]
cs_needed] (LHsExpr GhcPs -> LHsBind GhcPs) -> LHsExpr GhcPs -> LHsBind GhcPs
forall a b. (a -> b) -> a -> b
$
if Arity
con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
then LHsExpr GhcPs
true_Expr
else (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> [Located (HsExpr GhcPs)] -> Located (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr (String
-> (RdrName -> RdrName -> RdrName -> Located (HsExpr GhcPs))
-> [RdrName]
-> [RdrName]
-> [RdrName]
-> [Located (HsExpr GhcPs)]
forall a b c d.
String -> (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3Equal String
"single_con_inRange" RdrName -> RdrName -> RdrName -> Located (HsExpr GhcPs)
forall (id :: Pass).
(IsPass id, IdGhcP id ~ RdrName) =>
RdrName -> RdrName -> RdrName -> Located (HsExpr (GhcPass id))
in_range
[RdrName]
as_needed [RdrName]
bs_needed [RdrName]
cs_needed)
where
in_range :: RdrName -> RdrName -> RdrName -> LHsExpr (GhcPass id)
in_range RdrName
a RdrName
b RdrName
c = IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP (GhcPass id)
inRange_RDR [[IdP (GhcPass id)] -> LHsExpr (GhcPass id)
forall (a :: Pass). [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple [RdrName
IdP (GhcPass id)
a,RdrName
IdP (GhcPass id)
b], IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass id)
c]
gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
-> (LHsBinds GhcPs, BagDerivStuff)
gen_Read_binds :: (Name -> Fixity)
-> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Read_binds Name -> Fixity
get_fixity SrcSpan
loc TyCon
tycon [Type]
_
= ([Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
read_prec, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
default_readlist, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
default_readlistprec], BagDerivStuff
forall a. Bag a
emptyBag)
where
default_readlist :: LHsBind GhcPs
default_readlist
= SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
readList_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
readListDefault_RDR)
default_readlistprec :: LHsBind GhcPs
default_readlistprec
= SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
readListPrec_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
readListPrecDefault_RDR)
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
tycon
([DataCon]
nullary_cons, [DataCon]
non_nullary_cons) = (DataCon -> Bool) -> [DataCon] -> ([DataCon], [DataCon])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition DataCon -> Bool
isNullarySrcDataCon [DataCon]
data_cons
read_prec :: LHsBind GhcPs
read_prec = SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
readPrec_RDR Located (HsExpr GhcPs)
LHsExpr GhcPs
rhs
where
rhs :: Located (HsExpr GhcPs)
rhs | [DataCon] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DataCon]
data_cons
= IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
pfail_RDR
| Bool
otherwise
= LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
parens_RDR)
((Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> [Located (HsExpr GhcPs)] -> Located (HsExpr GhcPs)
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
mk_alt ([Located (HsExpr GhcPs)]
read_nullary_cons [Located (HsExpr GhcPs)]
-> [Located (HsExpr GhcPs)] -> [Located (HsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++
[Located (HsExpr GhcPs)]
read_non_nullary_cons))
read_non_nullary_cons :: [Located (HsExpr GhcPs)]
read_non_nullary_cons = (DataCon -> Located (HsExpr GhcPs))
-> [DataCon] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (HsExpr GhcPs)
read_non_nullary_con [DataCon]
non_nullary_cons
read_nullary_cons :: [Located (HsExpr GhcPs)]
read_nullary_cons
= case [DataCon]
nullary_cons of
[] -> []
[DataCon
con] -> [HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
nlHsDo (Maybe ModuleName -> HsStmtContext GhcRn
forall p. Maybe ModuleName -> HsStmtContext p
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing) (DataCon -> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a (idL :: Pass).
NamedThing a =>
a
-> [Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))]
match_con DataCon
con [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall e. e -> Located e
noLoc (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Located (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkLastStmt (DataCon -> [IdGhcP 'Parsed] -> Located (HsExpr GhcPs)
forall thing (id :: Pass).
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> Located (HsExpr (GhcPass id))
result_expr DataCon
con [])])]
[DataCon]
_ -> [LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
choose_RDR)
([LHsExpr GhcPs] -> LHsExpr GhcPs
nlList ((DataCon -> Located (HsExpr GhcPs))
-> [DataCon] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (HsExpr GhcPs)
forall thing (a :: Pass).
(NamedThing thing, IsPass a, IdGhcP a ~ RdrName) =>
thing -> Located (HsExpr (GhcPass a))
mk_pair [DataCon]
nullary_cons))]
match_con :: a
-> [Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))]
match_con a
con | String -> Bool
isSym String
con_str = [String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
symbol_pat String
con_str]
| Bool
otherwise = String
-> [Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))]
forall (idL :: Pass).
String
-> [Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))]
ident_h_pat String
con_str
where
con_str :: String
con_str = a -> String
forall a. NamedThing a => a -> String
data_con_str a
con
mk_pair :: thing -> LHsExpr (GhcPass a)
mk_pair thing
con = [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
forall (a :: Pass). [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsTupleExpr [HsLit (GhcPass a) -> LHsExpr (GhcPass a)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass a)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (thing -> String
forall a. NamedThing a => a -> String
data_con_str thing
con)),
thing -> [IdGhcP a] -> Located (HsExpr (GhcPass a))
forall thing (id :: Pass).
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> Located (HsExpr (GhcPass id))
result_expr thing
con []]
read_non_nullary_con :: DataCon -> Located (HsExpr GhcPs)
read_non_nullary_con DataCon
data_con
| Bool
is_infix = Integer
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
mk_parser Integer
infix_prec [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
infix_stmts Located (HsExpr GhcPs)
body
| Bool
is_record = Integer
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
mk_parser Integer
record_prec [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
record_stmts Located (HsExpr GhcPs)
body
| Bool
otherwise = Located (HsExpr GhcPs)
prefix_parser
where
body :: Located (HsExpr GhcPs)
body = DataCon -> [IdGhcP 'Parsed] -> Located (HsExpr GhcPs)
forall thing (id :: Pass).
(NamedThing thing, IsPass id, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> Located (HsExpr (GhcPass id))
result_expr DataCon
data_con [RdrName]
[IdGhcP 'Parsed]
as_needed
con_str :: String
con_str = DataCon -> String
forall a. NamedThing a => a -> String
data_con_str DataCon
data_con
prefix_parser :: Located (HsExpr GhcPs)
prefix_parser = Integer
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
mk_parser Integer
prefix_prec [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
prefix_stmts Located (HsExpr GhcPs)
body
read_prefix_con :: [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_prefix_con
| String -> Bool
isSym String
con_str = [String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
"(", String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
symbol_pat String
con_str, String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
")"]
| Bool
otherwise = String -> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall (idL :: Pass).
String
-> [Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))]
ident_h_pat String
con_str
read_infix_con :: [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_infix_con
| String -> Bool
isSym String
con_str = [String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
symbol_pat String
con_str]
| Bool
otherwise = [String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
"`"] [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ String -> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall (idL :: Pass).
String
-> [Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))]
ident_h_pat String
con_str [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
"`"]
prefix_stmts :: [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
prefix_stmts
= [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_prefix_con [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_args
infix_stmts :: [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
infix_stmts
= [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
read_a1]
[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_infix_con
[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
read_a2]
record_stmts :: [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
record_stmts
= [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_prefix_con
[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
"{"]
[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]]
-> [[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]]
forall a. a -> [a] -> [a]
intersperse [String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
","] [[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]]
field_stmts)
[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [String -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
"}"]
field_stmts :: [[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]]
field_stmts = String
-> (FastString
-> RdrName
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))])
-> [FastString]
-> [RdrName]
-> [[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"lbl_stmts" FastString
-> RdrName
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_field [FastString]
labels [RdrName]
as_needed
con_arity :: Arity
con_arity = DataCon -> Arity
dataConSourceArity DataCon
data_con
labels :: [FastString]
labels = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel ([FieldLabel] -> [FastString]) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
dc_nm :: Name
dc_nm = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con
is_infix :: Bool
is_infix = DataCon -> Bool
dataConIsInfix DataCon
data_con
is_record :: Bool
is_record = [FastString]
labels [FastString] -> Arity -> Bool
forall a. [a] -> Arity -> Bool
`lengthExceeds` Arity
0
as_needed :: [RdrName]
as_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
as_RDRs
read_args :: [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_args = String
-> (RdrName
-> Type -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))))
-> [RdrName]
-> [Type]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Read_binds" RdrName
-> Type -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
read_arg [RdrName]
as_needed ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing ([Scaled Type] -> [Type]) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
data_con)
(Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
read_a1:Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
read_a2:[Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
_) = [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_args
prefix_prec :: Integer
prefix_prec = Integer
appPrecedence
infix_prec :: Integer
infix_prec = (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
dc_nm
record_prec :: Integer
record_prec = Integer
appPrecedence Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
mk_alt :: Located (HsExpr GhcPs) -> Located (HsExpr GhcPs) -> LHsExpr GhcPs
mk_alt Located (HsExpr GhcPs)
e1 Located (HsExpr GhcPs)
e2 = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp Located (HsExpr GhcPs)
LHsExpr GhcPs
e1 RdrName
alt_RDR Located (HsExpr GhcPs)
LHsExpr GhcPs
e2
mk_parser :: Integer
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> Located (HsExpr GhcPs)
-> LHsExpr GhcPs
mk_parser Integer
p [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
ss Located (HsExpr GhcPs)
b = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
prec_RDR [Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
p
, HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
nlHsDo (Maybe ModuleName -> HsStmtContext GhcRn
forall p. Maybe ModuleName -> HsStmtContext p
DoExpr Maybe ModuleName
forall a. Maybe a
Nothing) ([Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
ss [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
forall a. [a] -> [a] -> [a]
++ [StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall e. e -> Located e
noLoc (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))))
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ Located (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
forall (idR :: Pass) (bodyR :: * -> *) (idL :: Pass).
IsPass idR =>
Located (bodyR (GhcPass idR))
-> StmtLR
(GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkLastStmt Located (HsExpr GhcPs)
b])]
con_app :: thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
con_app thing
con [IdGhcP id]
as = IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps (thing -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName thing
con) [IdP (GhcPass id)]
[IdGhcP id]
as
result_expr :: thing -> [IdGhcP id] -> LHsExpr (GhcPass id)
result_expr thing
con [IdGhcP id]
as = LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP (GhcPass id)
returnM_RDR) (thing -> [IdGhcP id] -> Located (HsExpr (GhcPass id))
forall thing (id :: Pass).
(NamedThing thing, IdGhcP id ~ RdrName) =>
thing -> [IdGhcP id] -> Located (HsExpr (GhcPass id))
con_app thing
con [IdGhcP id]
as)
ident_h_pat :: String
-> [Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))]
ident_h_pat String
s | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [ String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
ident_pat String
ss, String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
symbol_pat String
"#" ]
| Bool
otherwise = [ String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
ident_pat String
s ]
bindLex :: Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
bindLex Located (HsExpr GhcPs)
pat = StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall e. e -> Located e
noLoc (Located (HsExpr GhcPs)
-> StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs))
forall (bodyR :: * -> *) (idL :: Pass).
Located (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
mkBodyStmt (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
expectP_RDR) Located (HsExpr GhcPs)
LHsExpr GhcPs
pat))
ident_pat :: String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
ident_pat String
s = Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
bindLex (Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs))))
-> Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
ident_RDR [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]
symbol_pat :: String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
symbol_pat String
s = Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
bindLex (Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs))))
-> Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
symbol_RDR [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
s)]
read_punc :: String
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
read_punc String
c = Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall (idL :: Pass).
Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
bindLex (Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs))))
-> Located (HsExpr GhcPs)
-> Located (StmtLR (GhcPass idL) GhcPs (Located (HsExpr GhcPs)))
forall a b. (a -> b) -> a -> b
$ IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
punc_RDR [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
c)]
data_con_str :: a -> String
data_con_str a
con = OccName -> String
occNameString (a -> OccName
forall a. NamedThing a => a -> OccName
getOccName a
con)
read_arg :: RdrName
-> Type -> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
read_arg RdrName
a Type
ty = ASSERT( not (isUnliftedType ty) )
StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall e. e -> Located e
noLoc (LPat GhcPs
-> Located (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
forall (bodyR :: * -> *).
LPat GhcPs
-> Located (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))
mkPsBindStmt (IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
a) (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
step_RDR [RdrName
IdP GhcPs
readPrec_RDR]))
read_field :: FastString
-> RdrName
-> [Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))]
read_field FastString
lbl RdrName
a =
[StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
-> Located (StmtLR GhcPs GhcPs (Located (HsExpr GhcPs)))
forall e. e -> Located e
noLoc
(LPat GhcPs
-> Located (HsExpr GhcPs)
-> StmtLR GhcPs GhcPs (Located (HsExpr GhcPs))
forall (bodyR :: * -> *).
LPat GhcPs
-> Located (bodyR GhcPs)
-> StmtLR GhcPs GhcPs (Located (bodyR GhcPs))
mkPsBindStmt
(IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
a)
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
Located (HsExpr GhcPs)
LHsExpr GhcPs
read_field
(IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
reset_RDR [RdrName
IdP GhcPs
readPrec_RDR])
)
)
]
where
lbl_str :: String
lbl_str = FastString -> String
unpackFS FastString
lbl
mk_read_field :: IdGhcP id -> String -> LHsExpr (GhcPass id)
mk_read_field IdGhcP id
read_field_rdr String
lbl
= IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps IdP (GhcPass id)
IdGhcP id
read_field_rdr [HsLit (GhcPass id) -> LHsExpr (GhcPass id)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit (GhcPass id)
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
lbl)]
read_field :: Located (HsExpr GhcPs)
read_field
| String -> Bool
isSym String
lbl_str
= IdGhcP 'Parsed -> String -> Located (HsExpr GhcPs)
forall (id :: Pass).
IsPass id =>
IdGhcP id -> String -> Located (HsExpr (GhcPass id))
mk_read_field RdrName
IdGhcP 'Parsed
readSymField_RDR String
lbl_str
| Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
lbl_str
= IdGhcP 'Parsed -> String -> Located (HsExpr GhcPs)
forall (id :: Pass).
IsPass id =>
IdGhcP id -> String -> Located (HsExpr (GhcPass id))
mk_read_field RdrName
IdGhcP 'Parsed
readFieldHash_RDR String
ss
| Bool
otherwise
= IdGhcP 'Parsed -> String -> Located (HsExpr GhcPs)
forall (id :: Pass).
IsPass id =>
IdGhcP id -> String -> Located (HsExpr (GhcPass id))
mk_read_field RdrName
IdGhcP 'Parsed
readField_RDR String
lbl_str
gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
-> (LHsBinds GhcPs, BagDerivStuff)
gen_Show_binds :: (Name -> Fixity)
-> SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Show_binds Name -> Fixity
get_fixity SrcSpan
loc TyCon
tycon [Type]
tycon_args
= (Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
shows_prec, BagDerivStuff
forall a. Bag a
emptyBag)
where
data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
shows_prec :: LHsBind GhcPs
shows_prec = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
2 SrcSpan
loc RdrName
showsPrec_RDR LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id ((DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs)))
-> [DataCon] -> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
pats_etc [DataCon]
data_cons)
comma_space :: LHsExpr GhcPs
comma_space = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
showCommaSpace_RDR
pats_etc :: DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
pats_etc DataCon
data_con
| Bool
nullary_con =
ASSERT(null bs_needed)
([Located (Pat GhcPs)
LPat GhcPs
nlWildPat, Located (Pat GhcPs)
LPat GhcPs
con_pat], String -> LHsExpr GhcPs
mk_showString_app String
op_con_str)
| Bool
otherwise =
([Located (Pat GhcPs)
LPat GhcPs
a_Pat, Located (Pat GhcPs)
LPat GhcPs
con_pat],
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
showParen_Expr (LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
a_Expr RdrName
ge_RDR (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit
(XHsInt GhcPs -> IntegralLit -> HsLit GhcPs
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
XHsInt GhcPs
noExtField (Integer -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
con_prec_plus_one))))
(LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar ([LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
show_thingies)))
where
data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
con_arity :: Arity
con_arity = DataCon -> Arity
dataConSourceArity DataCon
data_con
bs_needed :: [RdrName]
bs_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
bs_RDRs
arg_tys :: [Scaled Type]
arg_tys = DataCon -> [Scaled Type]
dataConOrigArgTys DataCon
data_con
con_pat :: LPat GhcPs
con_pat = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
bs_needed
nullary_con :: Bool
nullary_con = Arity
con_arity Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
0
labels :: [FastString]
labels = (FieldLabel -> FastString) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> FastString
flLabel ([FieldLabel] -> [FastString]) -> [FieldLabel] -> [FastString]
forall a b. (a -> b) -> a -> b
$ DataCon -> [FieldLabel]
dataConFieldLabels DataCon
data_con
lab_fields :: Arity
lab_fields = [FastString] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [FastString]
labels
record_syntax :: Bool
record_syntax = Arity
lab_fields Arity -> Arity -> Bool
forall a. Ord a => a -> a -> Bool
> Arity
0
dc_nm :: Name
dc_nm = DataCon -> Name
forall a. NamedThing a => a -> Name
getName DataCon
data_con
dc_occ_nm :: OccName
dc_occ_nm = DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
data_con
con_str :: String
con_str = OccName -> String
occNameString OccName
dc_occ_nm
op_con_str :: String
op_con_str = String -> String
wrapOpParens String
con_str
backquote_str :: String
backquote_str = String -> String
wrapOpBackquotes String
con_str
show_thingies :: [Located (HsExpr GhcPs)]
show_thingies
| Bool
is_infix = [Located (HsExpr GhcPs)
show_arg1, String -> LHsExpr GhcPs
mk_showString_app (String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
backquote_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "), Located (HsExpr GhcPs)
show_arg2]
| Bool
record_syntax = String -> LHsExpr GhcPs
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" {") Located (HsExpr GhcPs)
-> [Located (HsExpr GhcPs)] -> [Located (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
:
[Located (HsExpr GhcPs)]
show_record_args [Located (HsExpr GhcPs)]
-> [Located (HsExpr GhcPs)] -> [Located (HsExpr GhcPs)]
forall a. [a] -> [a] -> [a]
++ [String -> LHsExpr GhcPs
mk_showString_app String
"}"]
| Bool
otherwise = String -> LHsExpr GhcPs
mk_showString_app (String
op_con_str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ") Located (HsExpr GhcPs)
-> [Located (HsExpr GhcPs)] -> [Located (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
: [Located (HsExpr GhcPs)]
show_prefix_args
show_label :: FastString -> LHsExpr GhcPs
show_label FastString
l = String -> LHsExpr GhcPs
mk_showString_app (String
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = ")
where
nm :: String
nm = String -> String
wrapOpParens (FastString -> String
unpackFS FastString
l)
show_args :: [Located (HsExpr GhcPs)]
show_args = String
-> (RdrName -> Type -> Located (HsExpr GhcPs))
-> [RdrName]
-> [Type]
-> [Located (HsExpr GhcPs)]
forall a b c. String -> (a -> b -> c) -> [a] -> [b] -> [c]
zipWithEqual String
"gen_Show_binds" RdrName -> Type -> Located (HsExpr GhcPs)
RdrName -> Type -> LHsExpr GhcPs
show_arg [RdrName]
bs_needed ((Scaled Type -> Type) -> [Scaled Type] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Scaled Type -> Type
forall a. Scaled a -> a
scaledThing [Scaled Type]
arg_tys)
(Located (HsExpr GhcPs)
show_arg1:Located (HsExpr GhcPs)
show_arg2:[Located (HsExpr GhcPs)]
_) = [Located (HsExpr GhcPs)]
show_args
show_prefix_args :: [Located (HsExpr GhcPs)]
show_prefix_args = Located (HsExpr GhcPs)
-> [Located (HsExpr GhcPs)] -> [Located (HsExpr GhcPs)]
forall a. a -> [a] -> [a]
intersperse (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
showSpace_RDR) [Located (HsExpr GhcPs)]
show_args
show_record_args :: [Located (HsExpr GhcPs)]
show_record_args = [[Located (HsExpr GhcPs)]] -> [Located (HsExpr GhcPs)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Located (HsExpr GhcPs)]] -> [Located (HsExpr GhcPs)])
-> [[Located (HsExpr GhcPs)]] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> a -> b
$
[Located (HsExpr GhcPs)]
-> [[Located (HsExpr GhcPs)]] -> [[Located (HsExpr GhcPs)]]
forall a. a -> [a] -> [a]
intersperse [Located (HsExpr GhcPs)
comma_space] ([[Located (HsExpr GhcPs)]] -> [[Located (HsExpr GhcPs)]])
-> [[Located (HsExpr GhcPs)]] -> [[Located (HsExpr GhcPs)]]
forall a b. (a -> b) -> a -> b
$
[ [FastString -> Located (HsExpr GhcPs)
show_label FastString
lbl, Located (HsExpr GhcPs)
arg]
| (FastString
lbl,Located (HsExpr GhcPs)
arg) <- String
-> [FastString]
-> [Located (HsExpr GhcPs)]
-> [(FastString, Located (HsExpr GhcPs))]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"gen_Show_binds"
[FastString]
labels [Located (HsExpr GhcPs)]
show_args ]
show_arg :: RdrName -> Type -> LHsExpr GhcPs
show_arg :: RdrName -> Type -> LHsExpr GhcPs
show_arg RdrName
b Type
arg_ty
| HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
arg_ty
= Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
with_conv (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
compose_RDR
[LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app LHsExpr GhcPs
boxed_arg, String -> LHsExpr GhcPs
mk_showString_app String
postfixMod]
| Bool
otherwise
= Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_showsPrec_app Integer
arg_prec LHsExpr GhcPs
arg
where
arg :: LHsExpr GhcPs
arg = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b
boxed_arg :: LHsExpr GhcPs
boxed_arg = String -> LHsExpr GhcPs -> Type -> LHsExpr GhcPs
box String
"Show" LHsExpr GhcPs
arg Type
arg_ty
postfixMod :: String
postfixMod = String -> [(Type, String)] -> Type -> String
forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
"Show" [(Type, String)]
postfixModTbl Type
arg_ty
with_conv :: Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
with_conv Located (HsExpr GhcPs)
expr
| (Just String
conv) <- [(Type, String)] -> Type -> Maybe String
forall a. [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, String)]
primConvTbl Type
arg_ty =
[LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr
[ String -> LHsExpr GhcPs
mk_showString_app (String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
conv String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ")
, Located (HsExpr GhcPs)
LHsExpr GhcPs
expr
, String -> LHsExpr GhcPs
mk_showString_app String
")"
]
| Bool
otherwise = Located (HsExpr GhcPs)
expr
is_infix :: Bool
is_infix = DataCon -> Bool
dataConIsInfix DataCon
data_con
con_prec_plus_one :: Integer
con_prec_plus_one = Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Bool -> (Name -> Fixity) -> Name -> Integer
getPrec Bool
is_infix Name -> Fixity
get_fixity Name
dc_nm
arg_prec :: Integer
arg_prec | Bool
record_syntax = Integer
0
| Bool
otherwise = Integer
con_prec_plus_one
wrapOpParens :: String -> String
wrapOpParens :: String -> String
wrapOpParens String
s | String -> Bool
isSym String
s = Char
'(' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
| Bool
otherwise = String
s
wrapOpBackquotes :: String -> String
wrapOpBackquotes :: String -> String
wrapOpBackquotes String
s | String -> Bool
isSym String
s = String
s
| Bool
otherwise = Char
'`' Char -> String -> String
forall a. a -> [a] -> [a]
: String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"`"
isSym :: String -> Bool
isSym :: String -> Bool
isSym String
"" = Bool
False
isSym (Char
c : String
_) = Char -> Bool
startsVarSym Char
c Bool -> Bool -> Bool
|| Char -> Bool
startsConSym Char
c
mk_showString_app :: String -> LHsExpr GhcPs
mk_showString_app :: String -> LHsExpr GhcPs
mk_showString_app String
str = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
showString_RDR) (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
str))
mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_showsPrec_app Integer
p LHsExpr GhcPs
x
= IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
showsPrec_RDR [HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsInt GhcPs -> IntegralLit -> HsLit GhcPs
forall x. XHsInt x -> IntegralLit -> HsLit x
HsInt NoExtField
XHsInt GhcPs
noExtField (Integer -> IntegralLit
forall a. Integral a => a -> IntegralLit
mkIntegralLit Integer
p)), LHsExpr GhcPs
x]
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app LHsExpr GhcPs
x = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
shows_RDR) LHsExpr GhcPs
x
getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
getPrec Bool
is_infix Name -> Fixity
get_fixity Name
nm
| Bool -> Bool
not Bool
is_infix = Integer
appPrecedence
| Bool
otherwise = (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
nm
appPrecedence :: Integer
appPrecedence :: Integer
appPrecedence = Arity -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Arity
maxPrecedence Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence Name -> Fixity
get_fixity Name
nm
= case Name -> Fixity
get_fixity Name
nm of
Fixity SourceText
_ Arity
x FixityDirection
_assoc -> Arity -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Arity
x
gen_Data_binds :: SrcSpan
-> TyCon
-> [Type]
-> TcM (LHsBinds GhcPs,
BagDerivStuff)
gen_Data_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Data_binds SrcSpan
loc TyCon
rep_tc [Type]
_
= do {
RdrName
dataT_RDR <- SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name SrcSpan
loc TyCon
rep_tc
; [RdrName]
dataC_RDRs <- (DataCon -> TcM RdrName)
-> [DataCon] -> IOEnv (Env TcGblEnv TcLclEnv) [RdrName]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name SrcSpan
loc) [DataCon]
data_cons
; (Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), BagDerivStuff)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( [Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [ Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
gfoldl_bind, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
gunfold_bind
, [RdrName] -> LHsBind GhcPs
toCon_bind [RdrName]
dataC_RDRs, RdrName -> LHsBind GhcPs
dataTypeOf_bind RdrName
dataT_RDR ]
Bag (Located (HsBindLR GhcPs GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. Bag a -> Bag a -> Bag a
`unionBags` Bag (Located (HsBindLR GhcPs GhcPs))
gcast_binds
, [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ([DerivStuff] -> BagDerivStuff) -> [DerivStuff] -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ (AuxBindSpec -> DerivStuff) -> [AuxBindSpec] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map AuxBindSpec -> DerivStuff
DerivAuxBind
( TyCon -> RdrName -> [RdrName] -> AuxBindSpec
DerivDataDataType TyCon
rep_tc RdrName
dataT_RDR [RdrName]
dataC_RDRs
AuxBindSpec -> [AuxBindSpec] -> [AuxBindSpec]
forall a. a -> [a] -> [a]
: (DataCon -> RdrName -> AuxBindSpec)
-> [DataCon] -> [RdrName] -> [AuxBindSpec]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\DataCon
data_con RdrName
dataC_RDR ->
DataCon -> RdrName -> RdrName -> AuxBindSpec
DerivDataConstr DataCon
data_con RdrName
dataC_RDR RdrName
dataT_RDR)
[DataCon]
data_cons [RdrName]
dataC_RDRs )
) }
where
data_cons :: [DataCon]
data_cons = TyCon -> [DataCon]
tyConDataCons TyCon
rep_tc
n_cons :: Arity
n_cons = [DataCon] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [DataCon]
data_cons
one_constr :: Bool
one_constr = Arity
n_cons Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
1
gfoldl_bind :: LHsBind GhcPs
gfoldl_bind = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
3 SrcSpan
loc RdrName
gfoldl_RDR LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id ((DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs)))
-> [DataCon] -> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
gfoldl_eqn [DataCon]
data_cons)
gfoldl_eqn :: DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
gfoldl_eqn DataCon
con
= ([IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
k_RDR, Located (Pat GhcPs)
LPat GhcPs
z_Pat, RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
con_name [RdrName]
as_needed],
(Located (HsExpr GhcPs) -> RdrName -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs) -> [RdrName] -> Located (HsExpr GhcPs)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Located (HsExpr GhcPs) -> RdrName -> Located (HsExpr GhcPs)
mk_k_app (LHsExpr GhcPs
z_Expr LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> Located (HsExpr GhcPs)
forall (p :: Pass).
(IsPass p, IdGhcP p ~ RdrName,
XMG (GhcPass p) (Located (HsExpr (GhcPass p))) ~ NoExtField) =>
DataCon -> Located (HsExpr (GhcPass p))
eta_expand_data_con DataCon
con)) [RdrName]
as_needed)
where
con_name :: RdrName
con_name :: RdrName
con_name = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
con
as_needed :: [RdrName]
as_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
con) [RdrName]
as_RDRs
mk_k_app :: Located (HsExpr GhcPs) -> RdrName -> LHsExpr GhcPs
mk_k_app Located (HsExpr GhcPs)
e RdrName
v = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp Located (HsExpr GhcPs)
LHsExpr GhcPs
e RdrName
IdP GhcPs
k_RDR (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
v))
gunfold_bind :: LHsBind GhcPs
gunfold_bind = SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc
RdrName
gunfold_RDR
[LPat GhcPs
k_Pat, LPat GhcPs
z_Pat, if Bool
one_constr then LPat GhcPs
nlWildPat else LPat GhcPs
c_Pat]
Located (HsExpr GhcPs)
LHsExpr GhcPs
gunfold_rhs
gunfold_rhs :: Located (HsExpr GhcPs)
gunfold_rhs
| Bool
one_constr = DataCon -> Located (HsExpr GhcPs)
mk_unfold_rhs ([DataCon] -> DataCon
forall a. [a] -> a
head [DataCon]
data_cons)
| Bool
otherwise = LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
conIndex_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` LHsExpr GhcPs
c_Expr)
((DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs))))
-> [DataCon] -> [Located (Match GhcPs (Located (HsExpr GhcPs)))]
forall a b. (a -> b) -> [a] -> [b]
map DataCon -> Located (Match GhcPs (Located (HsExpr GhcPs)))
DataCon -> LMatch GhcPs (Located (HsExpr GhcPs))
gunfold_alt [DataCon]
data_cons)
gunfold_alt :: DataCon -> LMatch GhcPs (Located (HsExpr GhcPs))
gunfold_alt DataCon
dc = LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (DataCon -> Located (Pat GhcPs)
mk_unfold_pat DataCon
dc) (DataCon -> Located (HsExpr GhcPs)
mk_unfold_rhs DataCon
dc)
mk_unfold_rhs :: DataCon -> Located (HsExpr GhcPs)
mk_unfold_rhs DataCon
dc = (Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> [Located (HsExpr GhcPs)]
-> Located (HsExpr GhcPs)
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs) -> Located (HsExpr GhcPs)
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(LHsExpr GhcPs
z_Expr LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` (DataCon -> Located (HsExpr GhcPs)
forall (p :: Pass).
(IsPass p, IdGhcP p ~ RdrName,
XMG (GhcPass p) (Located (HsExpr (GhcPass p))) ~ NoExtField) =>
DataCon -> Located (HsExpr (GhcPass p))
eta_expand_data_con DataCon
dc))
(Arity -> Located (HsExpr GhcPs) -> [Located (HsExpr GhcPs)]
forall a. Arity -> a -> [a]
replicate (DataCon -> Arity
dataConSourceArity DataCon
dc) (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
k_RDR))
eta_expand_data_con :: DataCon -> LHsExpr (GhcPass p)
eta_expand_data_con DataCon
dc =
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
forall (p :: Pass).
(IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam [Located (Pat (GhcPass p))]
[LPat (GhcPass p)]
eta_expand_pats
((Located (HsExpr (GhcPass p))
-> Located (HsExpr (GhcPass p)) -> Located (HsExpr (GhcPass p)))
-> Located (HsExpr (GhcPass p))
-> [Located (HsExpr (GhcPass p))]
-> Located (HsExpr (GhcPass p))
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Located (HsExpr (GhcPass p))
-> Located (HsExpr (GhcPass p)) -> Located (HsExpr (GhcPass p))
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP (GhcPass p) -> LHsExpr (GhcPass p)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
dc)) [Located (HsExpr (GhcPass p))]
eta_expand_hsvars)
where
eta_expand_pats :: [Located (Pat (GhcPass p))]
eta_expand_pats = (RdrName -> Located (Pat (GhcPass p)))
-> [RdrName] -> [Located (Pat (GhcPass p))]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> Located (Pat (GhcPass p))
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat [RdrName]
eta_expand_vars
eta_expand_hsvars :: [Located (HsExpr (GhcPass p))]
eta_expand_hsvars = (RdrName -> Located (HsExpr (GhcPass p)))
-> [RdrName] -> [Located (HsExpr (GhcPass p))]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> Located (HsExpr (GhcPass p))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [RdrName]
eta_expand_vars
eta_expand_vars :: [RdrName]
eta_expand_vars = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take (DataCon -> Arity
dataConSourceArity DataCon
dc) [RdrName]
as_RDRs
mk_unfold_pat :: DataCon -> Located (Pat GhcPs)
mk_unfold_pat DataCon
dc
| Arity
tagArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
fIRST_TAG Arity -> Arity -> Bool
forall a. Eq a => a -> a -> Bool
== Arity
n_consArity -> Arity -> Arity
forall a. Num a => a -> a -> a
-Arity
1 = Located (Pat GhcPs)
LPat GhcPs
nlWildPat
| Bool
otherwise = RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat RdrName
intDataCon_RDR
[HsLit GhcPs -> LPat GhcPs
nlLitPat (XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim GhcPs
NoSourceText (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger Arity
tag))]
where
tag :: Arity
tag = DataCon -> Arity
dataConTag DataCon
dc
toCon_bind :: [RdrName] -> LHsBind GhcPs
toCon_bind [RdrName]
dataC_RDRs
= Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
1 SrcSpan
loc RdrName
toConstr_RDR LHsExpr GhcPs -> LHsExpr GhcPs
forall a. a -> a
id
((DataCon
-> RdrName -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs)))
-> [DataCon]
-> [RdrName]
-> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith DataCon
-> RdrName -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
forall (id :: Pass).
DataCon
-> IdGhcP id
-> ([Located (Pat GhcPs)], Located (HsExpr (GhcPass id)))
to_con_eqn [DataCon]
data_cons [RdrName]
dataC_RDRs)
to_con_eqn :: DataCon
-> IdGhcP id
-> ([Located (Pat GhcPs)], Located (HsExpr (GhcPass id)))
to_con_eqn DataCon
dc IdGhcP id
con_name = ([DataCon -> LPat GhcPs
nlWildConPat DataCon
dc], IdP (GhcPass id) -> LHsExpr (GhcPass id)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar IdP (GhcPass id)
IdGhcP id
con_name)
dataTypeOf_bind :: RdrName -> LHsBind GhcPs
dataTypeOf_bind RdrName
dataT_RDR
= SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind
SrcSpan
loc
RdrName
dataTypeOf_RDR
[LPat GhcPs
nlWildPat]
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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 (Located (HsBindLR GhcPs GhcPs))
gcast_binds | Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqKind` Type
kind1 = RdrName -> RdrName -> Bag (Located (HsBindLR GhcPs GhcPs))
mk_gcast RdrName
dataCast1_RDR RdrName
gcast1_RDR
| Type
tycon_kind HasDebugCallStack => Type -> Type -> Bool
Type -> Type -> Bool
`tcEqKind` Type
kind2 = RdrName -> RdrName -> Bag (Located (HsBindLR GhcPs GhcPs))
mk_gcast RdrName
dataCast2_RDR RdrName
gcast2_RDR
| Bool
otherwise = Bag (Located (HsBindLR GhcPs GhcPs))
forall a. Bag a
emptyBag
mk_gcast :: RdrName -> RdrName -> Bag (Located (HsBindLR GhcPs GhcPs))
mk_gcast RdrName
dataCast_RDR RdrName
gcast_RDR
= Located (HsBindLR GhcPs GhcPs)
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. a -> Bag a
unitBag (SrcSpan
-> RdrName -> [LPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs
mkSimpleGeneratedFunBind SrcSpan
loc RdrName
dataCast_RDR [IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
f_RDR]
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
gcast_RDR LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
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 ,
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 ,
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,
eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
extendWord8_RDR, extendInt8_RDR,
extendWord16_RDR, extendInt16_RDR,
extendWord32_RDR, extendInt32_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
"==#")
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#")
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#")
eqAddr_RDR :: RdrName
eqAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqAddr#")
ltAddr_RDR :: RdrName
ltAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltAddr#")
leAddr_RDR :: RdrName
leAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leAddr#")
gtAddr_RDR :: RdrName
gtAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtAddr#")
geAddr_RDR :: RdrName
geAddr_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geAddr#")
eqFloat_RDR :: RdrName
eqFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"eqFloat#")
ltFloat_RDR :: RdrName
ltFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"ltFloat#")
leFloat_RDR :: RdrName
leFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"leFloat#")
gtFloat_RDR :: RdrName
gtFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"gtFloat#")
geFloat_RDR :: RdrName
geFloat_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"geFloat#")
eqDouble_RDR :: RdrName
eqDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"==##")
ltDouble_RDR :: RdrName
ltDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"<##" )
leDouble_RDR :: RdrName
leDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"<=##")
gtDouble_RDR :: RdrName
gtDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
">##" )
geDouble_RDR :: RdrName
geDouble_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
">=##")
extendWord8_RDR :: RdrName
extendWord8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"extendWord8#")
extendInt8_RDR :: RdrName
extendInt8_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"extendInt8#")
extendWord16_RDR :: RdrName
extendWord16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"extendWord16#")
extendInt16_RDR :: RdrName
extendInt16_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"extendInt16#")
extendWord32_RDR :: RdrName
extendWord32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"extendWord32#")
extendInt32_RDR :: RdrName
extendInt32_RDR = Module -> FastString -> RdrName
varQual_RDR Module
gHC_PRIM (String -> FastString
fsLit String
"extendInt32#")
gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
gen_Lift_binds SrcSpan
loc TyCon
tycon [Type]
tycon_args = ([Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
lift_bind, Located (HsBindLR GhcPs GhcPs)
LHsBind GhcPs
liftTyped_bind], BagDerivStuff
forall a. Bag a
emptyBag)
where
lift_bind :: LHsBind GhcPs
lift_bind = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
1 SrcSpan
loc RdrName
lift_RDR (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
pure_Expr)
((DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs)))
-> [DataCon] -> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map ((Located (HsExpr GhcPs) -> HsBracket GhcPs)
-> DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
forall (id :: Pass) p.
(IsPass id, XBracket p ~ NoExtField, IdGhcP id ~ RdrName) =>
(GenLocated SrcSpan (HsExpr (GhcPass id)) -> HsBracket p)
-> DataCon -> ([Located (Pat GhcPs)], Located (HsExpr p))
pats_etc Located (HsExpr GhcPs) -> HsBracket GhcPs
LHsExpr GhcPs -> HsBracket GhcPs
mk_exp) [DataCon]
data_cons)
liftTyped_bind :: LHsBind GhcPs
liftTyped_bind = Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
1 SrcSpan
loc RdrName
liftTyped_RDR (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
unsafeCodeCoerce_Expr (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp LHsExpr GhcPs
pure_Expr)
((DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs)))
-> [DataCon] -> [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
map ((Located (HsExpr GhcPs) -> HsBracket GhcPs)
-> DataCon -> ([Located (Pat GhcPs)], Located (HsExpr GhcPs))
forall (id :: Pass) p.
(IsPass id, XBracket p ~ NoExtField, IdGhcP id ~ RdrName) =>
(GenLocated SrcSpan (HsExpr (GhcPass id)) -> HsBracket p)
-> DataCon -> ([Located (Pat GhcPs)], Located (HsExpr p))
pats_etc Located (HsExpr GhcPs) -> HsBracket GhcPs
LHsExpr GhcPs -> HsBracket GhcPs
mk_texp) [DataCon]
data_cons)
mk_exp :: LHsExpr GhcPs -> HsBracket GhcPs
mk_exp = XExpBr GhcPs -> LHsExpr GhcPs -> HsBracket GhcPs
forall p. XExpBr p -> LHsExpr p -> HsBracket p
ExpBr NoExtField
XExpBr GhcPs
noExtField
mk_texp :: LHsExpr GhcPs -> HsBracket GhcPs
mk_texp = XTExpBr GhcPs -> LHsExpr GhcPs -> HsBracket GhcPs
forall p. XTExpBr p -> LHsExpr p -> HsBracket p
TExpBr NoExtField
XTExpBr GhcPs
noExtField
data_cons :: [DataCon]
data_cons = TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args
pats_etc :: (GenLocated SrcSpan (HsExpr (GhcPass id)) -> HsBracket p)
-> DataCon -> ([Located (Pat GhcPs)], Located (HsExpr p))
pats_etc GenLocated SrcSpan (HsExpr (GhcPass id)) -> HsBracket p
mk_bracket DataCon
data_con
= ([Located (Pat GhcPs)
LPat GhcPs
con_pat], Located (HsExpr p)
lift_Expr)
where
con_pat :: LPat GhcPs
con_pat = RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
data_con_RDR [RdrName]
as_needed
data_con_RDR :: RdrName
data_con_RDR = DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
data_con
con_arity :: Arity
con_arity = DataCon -> Arity
dataConSourceArity DataCon
data_con
as_needed :: [RdrName]
as_needed = Arity -> [RdrName] -> [RdrName]
forall a. Arity -> [a] -> [a]
take Arity
con_arity [RdrName]
as_RDRs
lift_Expr :: Located (HsExpr p)
lift_Expr = HsExpr p -> Located (HsExpr p)
forall e. e -> Located e
noLoc (XBracket p -> HsBracket p -> HsExpr p
forall p. XBracket p -> HsBracket p -> HsExpr p
HsBracket NoExtField
XBracket p
noExtField (GenLocated SrcSpan (HsExpr (GhcPass id)) -> HsBracket p
mk_bracket GenLocated SrcSpan (HsExpr (GhcPass id))
LHsExpr (GhcPass id)
br_body))
br_body :: LHsExpr (GhcPass id)
br_body = IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps (Name -> RdrName
Exact (DataCon -> Name
dataConName DataCon
data_con))
((RdrName -> GenLocated SrcSpan (HsExpr (GhcPass id)))
-> [RdrName] -> [GenLocated SrcSpan (HsExpr (GhcPass id))]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> GenLocated SrcSpan (HsExpr (GhcPass id))
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [RdrName]
as_needed)
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
gen_Newtype_binds SrcSpan
loc Class
cls [TyVar]
inst_tvs [Type]
inst_tys Type
rhs_ty
= do let ats :: [TyCon]
ats = Class -> [TyCon]
classATs Class
cls
([Located (HsBindLR GhcPs GhcPs)]
binds, [Located (Sig GhcPs)]
sigs) = (TyVar -> (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
-> [TyVar]
-> ([Located (HsBindLR GhcPs GhcPs)], [Located (Sig GhcPs)])
forall a b c. (a -> (b, c)) -> [a] -> ([b], [c])
mapAndUnzip TyVar -> (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
TyVar -> (LHsBind GhcPs, LSig GhcPs)
mk_bind_and_sig (Class -> [TyVar]
classMethods Class
cls)
[FamInst]
atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
(TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst)
-> [TyCon] -> IOEnv (Env TcGblEnv TcLclEnv) [FamInst]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst
mk_atf_inst [TyCon]
ats
(Bag (Located (HsBindLR GhcPs GhcPs)), [Located (Sig GhcPs)],
BagDerivStuff)
-> IOEnv
(Env TcGblEnv TcLclEnv)
(Bag (Located (HsBindLR GhcPs GhcPs)), [Located (Sig GhcPs)],
BagDerivStuff)
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Located (HsBindLR GhcPs GhcPs)]
-> Bag (Located (HsBindLR GhcPs GhcPs))
forall a. [a] -> Bag a
listToBag [Located (HsBindLR GhcPs GhcPs)]
binds
, [Located (Sig GhcPs)]
sigs
, [DerivStuff] -> BagDerivStuff
forall a. [a] -> Bag a
listToBag ([DerivStuff] -> BagDerivStuff) -> [DerivStuff] -> BagDerivStuff
forall a b. (a -> b) -> a -> b
$ (FamInst -> DerivStuff) -> [FamInst] -> [DerivStuff]
forall a b. (a -> b) -> [a] -> [b]
map FamInst -> DerivStuff
DerivFamInst [FamInst]
atf_insts )
where
mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)
mk_bind_and_sig :: TyVar -> (LHsBind GhcPs, LSig GhcPs)
mk_bind_and_sig TyVar
meth_id
= (
Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind Located RdrName
loc_meth_RDR [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> Located (HsExpr GhcPs)
-> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch
(LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
LIdP GhcPs
loc_meth_RDR)
[] Located (HsExpr GhcPs)
LHsExpr GhcPs
rhs_expr]
,
SrcSpan -> Sig GhcPs -> Located (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Sig GhcPs -> Located (Sig GhcPs))
-> Sig GhcPs -> Located (Sig GhcPs)
forall a b. (a -> b) -> a -> b
$ XClassOpSig GhcPs
-> Bool -> [LIdP GhcPs] -> Located (HsSigType GhcPs) -> Sig GhcPs
forall pass.
XClassOpSig pass
-> Bool -> [LIdP pass] -> LHsSigType pass -> Sig pass
ClassOpSig NoExtField
XClassOpSig GhcPs
noExtField Bool
False [Located RdrName
LIdP GhcPs
loc_meth_RDR]
(Located (HsSigType GhcPs) -> Sig GhcPs)
-> Located (HsSigType GhcPs) -> Sig GhcPs
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsSigType GhcPs -> Located (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsSigType GhcPs -> Located (HsSigType GhcPs))
-> HsSigType GhcPs -> Located (HsSigType GhcPs)
forall a b. (a -> b) -> a -> b
$ [LHsTyVarBndr Specificity GhcPs]
-> LHsType GhcPs -> HsSigType GhcPs
mkHsExplicitSigType
((VarBndr TyVar Specificity
-> Located (HsTyVarBndr Specificity GhcPs))
-> [VarBndr TyVar Specificity]
-> [Located (HsTyVarBndr Specificity GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map VarBndr TyVar Specificity
-> Located (HsTyVarBndr Specificity GhcPs)
forall flag. VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb [VarBndr TyVar Specificity]
to_tvbs)
(Type -> LHsType GhcPs
nlHsCoreTy Type
to_rho)
)
where
Pair Type
from_ty Type
to_ty = Class -> [TyVar] -> [Type] -> Type -> TyVar -> Pair Type
mkCoerceClassMethEqn Class
cls [TyVar]
inst_tvs [Type]
inst_tys Type
rhs_ty TyVar
meth_id
([TyVar]
_, [Type]
_, Type
from_tau) = Type -> ([TyVar], [Type], Type)
tcSplitSigmaTy Type
from_ty
([VarBndr TyVar Specificity]
to_tvbs, Type
to_rho) = Type -> ([VarBndr TyVar Specificity], Type)
tcSplitForAllInvisTVBinders Type
to_ty
([Type]
_, Type
to_tau) = Type -> ([Type], Type)
tcSplitPhiTy Type
to_rho
mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb (Bndr TyVar
tv flag
flag) = HsTyVarBndr flag GhcPs -> Located (HsTyVarBndr flag GhcPs)
forall e. e -> Located e
noLoc (HsTyVarBndr flag GhcPs -> Located (HsTyVarBndr flag GhcPs))
-> HsTyVarBndr flag GhcPs -> Located (HsTyVarBndr flag GhcPs)
forall a b. (a -> b) -> a -> b
$ XKindedTyVar GhcPs
-> flag -> LIdP GhcPs -> LHsType GhcPs -> HsTyVarBndr flag GhcPs
forall flag pass.
XKindedTyVar pass
-> flag -> LIdP pass -> LHsKind pass -> HsTyVarBndr flag pass
KindedTyVar NoExtField
XKindedTyVar GhcPs
noExtField
flag
flag
(RdrName -> Located RdrName
forall e. e -> Located e
noLoc (TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyVar
tv))
(Type -> LHsType GhcPs
nlHsCoreTy (TyVar -> Type
tyVarKind TyVar
tv))
meth_RDR :: RdrName
meth_RDR = TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyVar
meth_id
loc_meth_RDR :: Located RdrName
loc_meth_RDR = SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
meth_RDR
rhs_expr :: LHsExpr GhcPs
rhs_expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName TyVar
coerceId)
LHsExpr GhcPs -> Type -> LHsExpr GhcPs
`nlHsAppType` Type
from_tau
LHsExpr GhcPs -> Type -> LHsExpr GhcPs
`nlHsAppType` Type
to_tau
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` Located (HsExpr GhcPs)
LHsExpr GhcPs
meth_app
meth_app :: Located (HsExpr GhcPs)
meth_app = (Located (HsExpr GhcPs) -> Type -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs) -> [Type] -> Located (HsExpr GhcPs)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Located (HsExpr GhcPs) -> Type -> Located (HsExpr GhcPs)
LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
meth_RDR) ([Type] -> Located (HsExpr GhcPs))
-> [Type] -> Located (HsExpr GhcPs)
forall a b. (a -> b) -> a -> b
$
TyCon -> [Type] -> [Type]
filterOutInferredTypes (Class -> TyCon
classTyCon Class
cls) [Type]
underlying_inst_tys
mk_atf_inst :: TyCon -> TcM FamInst
mk_atf_inst :: TyCon -> IOEnv (Env TcGblEnv TcLclEnv) FamInst
mk_atf_inst TyCon
fam_tc = do
Name
rep_tc_name <- Located Name -> [Type] -> TcM Name
newFamInstTyConName (SrcSpan -> Name -> Located Name
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (TyCon -> Name
tyConName TyCon
fam_tc))
[Type]
rep_lhs_tys
let axiom :: CoAxiom Unbranched
axiom = Role
-> Name
-> [TyVar]
-> [TyVar]
-> [TyVar]
-> TyCon
-> [Type]
-> Type
-> CoAxiom Unbranched
mkSingleCoAxiom Role
Nominal Name
rep_tc_name [TyVar]
rep_tvs' [] [TyVar]
rep_cvs'
TyCon
fam_tc [Type]
rep_lhs_tys Type
rep_rhs_ty
TyCon -> CoAxBranch -> TcM ()
checkValidCoAxBranch TyCon
fam_tc (CoAxiom Unbranched -> CoAxBranch
coAxiomSingleBranch CoAxiom Unbranched
axiom)
FamFlavor
-> CoAxiom Unbranched -> IOEnv (Env TcGblEnv TcLclEnv) FamInst
newFamInst FamFlavor
SynFamilyInst CoAxiom Unbranched
axiom
where
cls_tvs :: [TyVar]
cls_tvs = Class -> [TyVar]
classTyVars Class
cls
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TyVar] -> VarSet
mkVarSet [TyVar]
inst_tvs
lhs_env :: TvSubstEnv
lhs_env = [TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
cls_tvs [Type]
inst_tys
lhs_subst :: TCvSubst
lhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
lhs_env
rhs_env :: TvSubstEnv
rhs_env = [TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
cls_tvs [Type]
underlying_inst_tys
rhs_subst :: TCvSubst
rhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope TvSubstEnv
rhs_env
fam_tvs :: [TyVar]
fam_tvs = TyCon -> [TyVar]
tyConTyVars TyCon
fam_tc
rep_lhs_tys :: [Type]
rep_lhs_tys = TCvSubst -> [TyVar] -> [Type]
substTyVars TCvSubst
lhs_subst [TyVar]
fam_tvs
rep_rhs_tys :: [Type]
rep_rhs_tys = TCvSubst -> [TyVar] -> [Type]
substTyVars TCvSubst
rhs_subst [TyVar]
fam_tvs
rep_rhs_ty :: Type
rep_rhs_ty = TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
rep_rhs_tys
rep_tcvs :: [TyVar]
rep_tcvs = [Type] -> [TyVar]
tyCoVarsOfTypesList [Type]
rep_lhs_tys
([TyVar]
rep_tvs, [TyVar]
rep_cvs) = (TyVar -> Bool) -> [TyVar] -> ([TyVar], [TyVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition TyVar -> Bool
isTyVar [TyVar]
rep_tcvs
rep_tvs' :: [TyVar]
rep_tvs' = [TyVar] -> [TyVar]
scopedSort [TyVar]
rep_tvs
rep_cvs' :: [TyVar]
rep_cvs' = [TyVar] -> [TyVar]
scopedSort [TyVar]
rep_cvs
underlying_inst_tys :: [Type]
underlying_inst_tys :: [Type]
underlying_inst_tys = [Type] -> Type -> [Type]
forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty
nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType LHsExpr GhcPs
e Type
s = HsExpr GhcPs -> Located (HsExpr GhcPs)
forall e. e -> Located e
noLoc (XAppTypeE GhcPs
-> LHsExpr GhcPs -> LHsWcType (NoGhcTc GhcPs) -> HsExpr GhcPs
forall p.
XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
HsAppType NoExtField
XAppTypeE GhcPs
noExtField LHsExpr GhcPs
e HsWildCardBndrs GhcPs (Located (HsType GhcPs))
LHsWcType (NoGhcTc GhcPs)
hs_ty)
where
hs_ty :: HsWildCardBndrs GhcPs (Located (HsType GhcPs))
hs_ty = Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsType GhcPs)))
-> Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsType GhcPs))
forall a b. (a -> b) -> a -> b
$ PprPrec -> LHsType GhcPs -> LHsType GhcPs
forall (p :: Pass).
PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
parenthesizeHsType PprPrec
appPrec (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall a b. (a -> b) -> a -> b
$ Type -> LHsType GhcPs
nlHsCoreTy Type
s
nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
nlHsCoreTy :: Type -> LHsType GhcPs
nlHsCoreTy = HsType GhcPs -> Located (HsType GhcPs)
forall e. e -> Located e
noLoc (HsType GhcPs -> Located (HsType GhcPs))
-> (Type -> HsType GhcPs) -> Type -> Located (HsType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType
mkCoerceClassMethEqn :: Class
-> [TyVar]
-> [Type]
-> Type
-> Id
-> Pair Type
mkCoerceClassMethEqn :: Class -> [TyVar] -> [Type] -> Type -> TyVar -> Pair Type
mkCoerceClassMethEqn Class
cls [TyVar]
inst_tvs [Type]
inst_tys Type
rhs_ty TyVar
id
= Type -> Type -> Pair Type
forall a. a -> a -> Pair a
Pair (HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
rhs_subst Type
user_meth_ty)
(HasCallStack => TCvSubst -> Type -> Type
TCvSubst -> Type -> Type
substTy TCvSubst
lhs_subst Type
user_meth_ty)
where
cls_tvs :: [TyVar]
cls_tvs = Class -> [TyVar]
classTyVars Class
cls
in_scope :: InScopeSet
in_scope = VarSet -> InScopeSet
mkInScopeSet (VarSet -> InScopeSet) -> VarSet -> InScopeSet
forall a b. (a -> b) -> a -> b
$ [TyVar] -> VarSet
mkVarSet [TyVar]
inst_tvs
lhs_subst :: TCvSubst
lhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope ([TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
cls_tvs [Type]
inst_tys)
rhs_subst :: TCvSubst
rhs_subst = InScopeSet -> TvSubstEnv -> TCvSubst
mkTvSubst InScopeSet
in_scope ([TyVar] -> [Type] -> TvSubstEnv
HasDebugCallStack => [TyVar] -> [Type] -> TvSubstEnv
zipTyEnv [TyVar]
cls_tvs ([Type] -> Type -> [Type]
forall a. [a] -> a -> [a]
changeLast [Type]
inst_tys Type
rhs_ty))
([TyVar]
_class_tvs, Type
_class_constraint, Type
user_meth_ty)
= Type -> ([TyVar], Type, Type)
tcSplitMethodTy (TyVar -> Type
varType TyVar
id)
genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal DynFlags
dflags SrcSpan
loc AuxBindSpec
spec
= (AuxBindSpec -> LHsBind GhcPs
gen_bind AuxBindSpec
spec,
SrcSpan -> Sig GhcPs -> Located (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTypeSig GhcPs
-> [LIdP GhcPs]
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
-> Sig GhcPs
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig GhcPs
noExtField [SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
spec)]
(SrcSpan
-> AuxBindSpec -> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
spec)))
where
gen_bind :: AuxBindSpec -> LHsBind GhcPs
gen_bind :: AuxBindSpec -> LHsBind GhcPs
gen_bind (DerivTag2Con TyCon
_ RdrName
tag2con_RDR)
= Arity
-> SrcSpan
-> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE Arity
0 SrcSpan
loc RdrName
tag2con_RDR
[([RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat RdrName
intDataCon_RDR [RdrName
a_RDR]],
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
tagToEnum_RDR) LHsExpr GhcPs
a_Expr)]
gen_bind (DerivMaxTag TyCon
tycon RdrName
maxtag_RDR)
= SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
maxtag_RDR LHsExpr GhcPs
rhs
where
rhs :: LHsExpr GhcPs
rhs = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
intDataCon_RDR)
(HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (XHsIntPrim GhcPs -> Integer -> HsLit GhcPs
forall x. XHsIntPrim x -> Integer -> HsLit x
HsIntPrim SourceText
XHsIntPrim GhcPs
NoSourceText Integer
max_tag))
max_tag :: Integer
max_tag = case (TyCon -> [DataCon]
tyConDataCons TyCon
tycon) of
[DataCon]
data_cons -> Arity -> Integer
forall a. Integral a => a -> Integer
toInteger (([DataCon] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [DataCon]
data_cons) Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
fIRST_TAG)
gen_bind (DerivDataDataType TyCon
tycon RdrName
dataT_RDR [RdrName]
dataC_RDRs)
= SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
dataT_RDR LHsExpr GhcPs
rhs
where
ctx :: SDocContext
ctx = DynFlags -> SDocContext
initDefaultSDocContext DynFlags
dflags
rhs :: LHsExpr GhcPs
rhs = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
mkDataType_RDR
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (SDocContext -> SDoc -> String
showSDocOneLine SDocContext
ctx (TyCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr TyCon
tycon)))
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`nlHsApp` [LHsExpr GhcPs] -> LHsExpr GhcPs
nlList ((RdrName -> Located (HsExpr GhcPs))
-> [RdrName] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map RdrName -> Located (HsExpr GhcPs)
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar [RdrName]
dataC_RDRs)
gen_bind (DerivDataConstr DataCon
dc RdrName
dataC_RDR RdrName
dataT_RDR)
= SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
dataC_RDR LHsExpr GhcPs
rhs
where
rhs :: LHsExpr GhcPs
rhs = IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps RdrName
IdP GhcPs
mkConstrTag_RDR [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
constr_args
constr_args :: [Located (HsExpr GhcPs)]
constr_args
= [ IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
dataT_RDR
, HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (OccName -> String
occNameString OccName
dc_occ))
, Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit (Arity -> Integer
forall a. Integral a => a -> Integer
toInteger (DataCon -> Arity
dataConTag DataCon
dc))
, [LHsExpr GhcPs] -> LHsExpr GhcPs
nlList [Located (HsExpr GhcPs)]
[LHsExpr GhcPs]
labels
, IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
fixity ]
labels :: [Located (HsExpr GhcPs)]
labels = (FieldLabel -> Located (HsExpr GhcPs))
-> [FieldLabel] -> [Located (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (HsLit GhcPs -> Located (HsExpr GhcPs)
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (HsLit GhcPs -> Located (HsExpr GhcPs))
-> (FieldLabel -> HsLit GhcPs)
-> FieldLabel
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String -> HsLit GhcPs)
-> (FieldLabel -> String) -> FieldLabel -> HsLit GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> String
unpackFS (FastString -> String)
-> (FieldLabel -> FastString) -> FieldLabel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldLabel -> FastString
flLabel)
(DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc)
dc_occ :: OccName
dc_occ = DataCon -> OccName
forall a. NamedThing a => a -> OccName
getOccName DataCon
dc
is_infix :: Bool
is_infix = OccName -> Bool
isDataSymOcc OccName
dc_occ
fixity :: RdrName
fixity | Bool
is_infix = RdrName
infix_RDR
| Bool
otherwise = RdrName
prefix_RDR
genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup SrcSpan
loc RdrName
original_rdr_name AuxBindSpec
dup_spec
= (SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind SrcSpan
loc RdrName
dup_rdr_name (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
original_rdr_name),
SrcSpan -> Sig GhcPs -> Located (Sig GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XTypeSig GhcPs
-> [LIdP GhcPs]
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
-> Sig GhcPs
forall pass.
XTypeSig pass -> [LIdP pass] -> LHsSigWcType pass -> Sig pass
TypeSig NoExtField
XTypeSig GhcPs
noExtField [SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
dup_rdr_name]
(SrcSpan
-> AuxBindSpec -> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
dup_spec)))
where
dup_rdr_name :: RdrName
dup_rdr_name = AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
dup_spec
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig :: SrcSpan
-> AuxBindSpec -> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
genAuxBindSpecSig SrcSpan
loc AuxBindSpec
spec = case AuxBindSpec
spec of
DerivTag2Con TyCon
tycon RdrName
_
-> Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
mk_sig (Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs)))
-> Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
forall a b. (a -> b) -> a -> b
$ SrcSpan -> HsType GhcPs -> Located (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsType GhcPs -> Located (HsType GhcPs))
-> HsType GhcPs -> Located (HsType GhcPs)
forall a b. (a -> b) -> a -> b
$
XXType GhcPs -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType (XXType GhcPs -> HsType GhcPs) -> XXType GhcPs -> HsType GhcPs
forall a b. (a -> b) -> a -> b
$ [TyVar] -> Type -> Type
mkSpecForAllTys (TyCon -> [TyVar]
tyConTyVars TyCon
tycon) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$
Type
intTy Type -> Type -> Type
`mkVisFunTyMany` TyCon -> Type
mkParentType TyCon
tycon
DerivMaxTag TyCon
_ RdrName
_
-> Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
mk_sig (SrcSpan -> HsType GhcPs -> Located (HsType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (XXType GhcPs -> HsType GhcPs
forall pass. XXType pass -> HsType pass
XHsType Type
XXType GhcPs
intTy))
DerivDataDataType TyCon
_ RdrName
_ [RdrName]
_
-> Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
mk_sig (IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar RdrName
IdP GhcPs
dataType_RDR)
DerivDataConstr DataCon
_ RdrName
_ RdrName
_
-> Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
mk_sig (IdP GhcPs -> LHsType GhcPs
forall (p :: Pass). IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar RdrName
IdP GhcPs
constr_RDR)
where
mk_sig :: Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
mk_sig = Located (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
forall thing. thing -> HsWildCardBndrs GhcPs thing
mkHsWildCardBndrs (Located (HsSigType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs)))
-> (Located (HsType GhcPs) -> Located (HsSigType GhcPs))
-> Located (HsType GhcPs)
-> HsWildCardBndrs GhcPs (Located (HsSigType GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> HsSigType GhcPs -> Located (HsSigType GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsSigType GhcPs -> Located (HsSigType GhcPs))
-> (Located (HsType GhcPs) -> HsSigType GhcPs)
-> Located (HsType GhcPs)
-> Located (HsSigType GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsType GhcPs) -> HsSigType GhcPs
LHsType GhcPs -> HsSigType GhcPs
mkHsImplicitSigType
type SeparateBagsDerivStuff =
( Bag (LHsBind GhcPs, LSig GhcPs)
, Bag FamInst )
genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds DynFlags
dflags SrcSpan
loc BagDerivStuff
b = (Bag AuxBindSpec
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
gen_aux_bind_specs Bag AuxBindSpec
b1, Bag FamInst
b2) where
(Bag AuxBindSpec
b1,Bag FamInst
b2) = (DerivStuff -> Either AuxBindSpec FamInst)
-> BagDerivStuff -> (Bag AuxBindSpec, Bag FamInst)
forall a b c. (a -> Either b c) -> Bag a -> (Bag b, Bag c)
partitionBagWith DerivStuff -> Either AuxBindSpec FamInst
splitDerivAuxBind BagDerivStuff
b
splitDerivAuxBind :: DerivStuff -> Either AuxBindSpec FamInst
splitDerivAuxBind (DerivAuxBind AuxBindSpec
x) = AuxBindSpec -> Either AuxBindSpec FamInst
forall a b. a -> Either a b
Left AuxBindSpec
x
splitDerivAuxBind (DerivFamInst FamInst
t) = FamInst -> Either AuxBindSpec FamInst
forall a b. b -> Either a b
Right FamInst
t
gen_aux_bind_specs :: Bag AuxBindSpec
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
gen_aux_bind_specs = (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
forall a b. (a, b) -> b
snd ((OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
-> (Bag AuxBindSpec
-> (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))))
-> Bag AuxBindSpec
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuxBindSpec
-> (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
-> (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))))
-> (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
-> Bag AuxBindSpec
-> (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AuxBindSpec
-> (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
-> (OccEnv RdrName,
Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs)))
AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
gen_aux_bind_spec (OccEnv RdrName
forall a. OccEnv a
emptyOccEnv, Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
forall a. Bag a
emptyBag)
gen_aux_bind_spec :: AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
gen_aux_bind_spec :: AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
gen_aux_bind_spec AuxBindSpec
spec (OccEnv RdrName
original_rdr_name_env, Bag (LHsBind GhcPs, LSig GhcPs)
spec_bag) =
case OccEnv RdrName -> OccName -> Maybe RdrName
forall a. OccEnv a -> OccName -> Maybe a
lookupOccEnv OccEnv RdrName
original_rdr_name_env OccName
spec_occ of
Maybe RdrName
Nothing
-> ( OccEnv RdrName -> OccName -> RdrName -> OccEnv RdrName
forall a. OccEnv a -> OccName -> a -> OccEnv a
extendOccEnv OccEnv RdrName
original_rdr_name_env OccName
spec_occ RdrName
spec_rdr_name
, DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal DynFlags
dflags SrcSpan
loc AuxBindSpec
spec (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
forall a. a -> Bag a -> Bag a
`consBag` Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
Bag (LHsBind GhcPs, LSig GhcPs)
spec_bag )
Just RdrName
original_rdr_name
-> ( OccEnv RdrName
original_rdr_name_env
, SrcSpan -> RdrName -> AuxBindSpec -> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup SrcSpan
loc RdrName
original_rdr_name AuxBindSpec
spec (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
-> Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
forall a. a -> Bag a -> Bag a
`consBag` Bag (Located (HsBindLR GhcPs GhcPs), Located (Sig GhcPs))
Bag (LHsBind GhcPs, LSig GhcPs)
spec_bag )
where
spec_rdr_name :: RdrName
spec_rdr_name = AuxBindSpec -> RdrName
auxBindSpecRdrName AuxBindSpec
spec
spec_occ :: OccName
spec_occ = RdrName -> OccName
rdrNameOcc RdrName
spec_rdr_name
mkParentType :: TyCon -> Type
mkParentType :: TyCon -> Type
mkParentType TyCon
tc
= case TyCon -> Maybe (TyCon, [Type])
tyConFamInst_maybe TyCon
tc of
Maybe (TyCon, [Type])
Nothing -> TyCon -> [Type] -> Type
mkTyConApp TyCon
tc ([TyVar] -> [Type]
mkTyVarTys (TyCon -> [TyVar]
tyConTyVars TyCon
tc))
Just (TyCon
fam_tc,[Type]
tys) -> TyCon -> [Type] -> Type
mkTyConApp TyCon
fam_tc [Type]
tys
mkFunBindSE :: Arity -> SrcSpan -> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE :: Arity
-> SrcSpan
-> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE Arity
arity SrcSpan
loc RdrName
fun [([LPat GhcPs], LHsExpr GhcPs)]
pats_and_exprs
= Arity
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindSE Arity
arity (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun) [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches
where
matches :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
matches = [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun))
((Located (Pat GhcPs) -> Located (Pat GhcPs))
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [Located (Pat GhcPs)]
p) Located (HsExpr GhcPs)
LHsExpr GhcPs
e
(HsLocalBinds GhcPs -> Located (HsLocalBinds GhcPs)
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
| ([Located (Pat GhcPs)]
p,Located (HsExpr GhcPs)
e) <-[([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
[([LPat GhcPs], LHsExpr GhcPs)]
pats_and_exprs]
mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBind fun :: Located RdrName
fun@(L SrcSpan
loc RdrName
_fun_rdr) [LMatch GhcPs (LHsExpr GhcPs)]
matches
= SrcSpan -> HsBindLR GhcPs GhcPs -> Located (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Origin
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBindLR GhcPs GhcPs
mkFunBind Origin
Generated Located RdrName
fun [LMatch GhcPs (LHsExpr GhcPs)]
matches)
mkFunBindEC :: Arity -> SrcSpan -> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC :: Arity
-> SrcSpan
-> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC Arity
arity SrcSpan
loc RdrName
fun LHsExpr GhcPs -> LHsExpr GhcPs
catch_all [([LPat GhcPs], LHsExpr GhcPs)]
pats_and_exprs
= Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
arity LHsExpr GhcPs -> LHsExpr GhcPs
catch_all (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun) [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches
where
matches :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
matches = [ HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs (SrcSpan -> RdrName -> Located RdrName
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc RdrName
fun))
((Located (Pat GhcPs) -> Located (Pat GhcPs))
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map (PprPrec -> LPat GhcPs -> LPat GhcPs
forall (p :: Pass).
IsPass p =>
PprPrec -> LPat (GhcPass p) -> LPat (GhcPass p)
parenthesizePat PprPrec
appPrec) [Located (Pat GhcPs)]
p) Located (HsExpr GhcPs)
LHsExpr GhcPs
e
(HsLocalBinds GhcPs -> Located (HsLocalBinds GhcPs)
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)
| ([Located (Pat GhcPs)]
p,Located (HsExpr GhcPs)
e) <- [([Located (Pat GhcPs)], Located (HsExpr GhcPs))]
[([LPat GhcPs], LHsExpr GhcPs)]
pats_and_exprs ]
mkRdrFunBindEC :: Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC :: Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC Arity
arity LHsExpr GhcPs -> LHsExpr GhcPs
catch_all
fun :: Located RdrName
fun@(L SrcSpan
loc RdrName
_fun_rdr) [LMatch GhcPs (LHsExpr GhcPs)]
matches = SrcSpan -> HsBindLR GhcPs GhcPs -> Located (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Origin
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBindLR GhcPs GhcPs
mkFunBind Origin
Generated Located RdrName
fun [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches')
where
matches' :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
matches' = if [Located (Match GhcPs (Located (HsExpr GhcPs)))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches
then [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
LIdP GhcPs
fun)
(Arity -> Located (Pat GhcPs) -> [Located (Pat GhcPs)]
forall a. Arity -> a -> [a]
replicate (Arity
arity Arity -> Arity -> Arity
forall a. Num a => a -> a -> a
- Arity
1) Located (Pat GhcPs)
LPat GhcPs
nlWildPat [Located (Pat GhcPs)]
-> [Located (Pat GhcPs)] -> [Located (Pat GhcPs)]
forall a. [a] -> [a] -> [a]
++ [Located (Pat GhcPs)
LPat GhcPs
z_Pat])
(LHsExpr GhcPs -> LHsExpr GhcPs
catch_all (LHsExpr GhcPs -> LHsExpr GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase LHsExpr GhcPs
z_Expr [])
(HsLocalBinds GhcPs -> Located (HsLocalBinds GhcPs)
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)]
else [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches
mkRdrFunBindSE :: Arity -> Located RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE :: Arity
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindSE Arity
arity
fun :: Located RdrName
fun@(L SrcSpan
loc RdrName
fun_rdr) [LMatch GhcPs (LHsExpr GhcPs)]
matches = SrcSpan -> HsBindLR GhcPs GhcPs -> Located (HsBindLR GhcPs GhcPs)
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (Origin
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBindLR GhcPs GhcPs
mkFunBind Origin
Generated Located RdrName
fun [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches')
where
matches' :: [Located (Match GhcPs (Located (HsExpr GhcPs)))]
matches' = if [Located (Match GhcPs (Located (HsExpr GhcPs)))] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches
then [HsMatchContext (NoGhcTc GhcPs)
-> [LPat GhcPs]
-> LHsExpr GhcPs
-> Located (HsLocalBinds GhcPs)
-> LMatch GhcPs (LHsExpr GhcPs)
forall (p :: Pass).
IsPass p =>
HsMatchContext (NoGhcTc (GhcPass p))
-> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch (LIdP GhcPs -> HsMatchContext GhcPs
forall p. LIdP p -> HsMatchContext p
mkPrefixFunRhs Located RdrName
LIdP GhcPs
fun)
(Arity -> Located (Pat GhcPs) -> [Located (Pat GhcPs)]
forall a. Arity -> a -> [a]
replicate Arity
arity Located (Pat GhcPs)
LPat GhcPs
nlWildPat)
(String -> LHsExpr GhcPs
error_Expr String
str) (HsLocalBinds GhcPs -> Located (HsLocalBinds GhcPs)
forall e. e -> Located e
noLoc HsLocalBinds GhcPs
forall (a :: Pass) (b :: Pass).
HsLocalBindsLR (GhcPass a) (GhcPass b)
emptyLocalBinds)]
else [Located (Match GhcPs (Located (HsExpr GhcPs)))]
[LMatch GhcPs (LHsExpr GhcPs)]
matches
str :: String
str = String
"Void " String -> String -> String
forall a. [a] -> [a] -> [a]
++ OccName -> String
occNameString (RdrName -> OccName
rdrNameOcc RdrName
fun_rdr)
box :: String
-> LHsExpr GhcPs
-> Type
-> LHsExpr GhcPs
box :: String -> LHsExpr GhcPs -> Type -> LHsExpr GhcPs
box String
cls_str LHsExpr GhcPs
arg Type
arg_ty = String
-> [(Type, Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))]
-> Type
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
cls_str [(Type, Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))]
[(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
boxConTbl Type
arg_ty Located (HsExpr GhcPs)
LHsExpr GhcPs
arg
primOrdOps :: String
-> Type
-> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps :: String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
str Type
ty = String
-> [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
-> Type
-> (RdrName, RdrName, RdrName, RdrName, RdrName)
forall a. HasCallStack => String -> [(Type, a)] -> Type -> a
assoc_ty_id String
str [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl Type
ty
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
= [(Type
charPrimTy , (RdrName
ltChar_RDR , RdrName
leChar_RDR
, RdrName
eqChar_RDR , RdrName
geChar_RDR , RdrName
gtChar_RDR ))
,(Type
intPrimTy , (RdrName
ltInt_RDR , RdrName
leInt_RDR
, RdrName
eqInt_RDR , RdrName
geInt_RDR , RdrName
gtInt_RDR ))
,(Type
int8PrimTy , (RdrName
ltInt8_RDR , RdrName
leInt8_RDR
, RdrName
eqInt8_RDR , RdrName
geInt8_RDR , RdrName
gtInt8_RDR ))
,(Type
int16PrimTy , (RdrName
ltInt16_RDR , RdrName
leInt16_RDR
, RdrName
eqInt16_RDR , RdrName
geInt16_RDR , RdrName
gtInt16_RDR ))
,(Type
int32PrimTy , (RdrName
ltInt32_RDR , RdrName
leInt32_RDR
, RdrName
eqInt32_RDR , RdrName
geInt32_RDR , RdrName
gtInt32_RDR ))
,(Type
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
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 GhcPs -> LHsExpr GhcPs)]
boxConTbl =
[ (Type
charPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
charDataCon))
, (Type
intPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon))
, (Type
wordPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon ))
, (Type
floatPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
floatDataCon ))
, (Type
doublePrimTy, LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
doubleDataCon))
, (Type
int8PrimTy,
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
extendInt8_RDR))
, (Type
word8PrimTy,
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
extendWord8_RDR))
, (Type
int16PrimTy,
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
extendInt16_RDR))
, (Type
word16PrimTy,
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
extendWord16_RDR))
, (Type
int32PrimTy,
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
intDataCon)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
extendInt32_RDR))
, (Type
word32PrimTy,
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ DataCon -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName DataCon
wordDataCon)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
extendWord32_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
"narrowInt8#")
, (Type
word8PrimTy, String
"narrowWord8#")
, (Type
int16PrimTy, String
"narrowInt16#")
, (Type
word16PrimTy, String
"narrowWord16#")
, (Type
int32PrimTy, String
"narrowInt32#")
, (Type
word32PrimTy, String
"narrowWord32#")
]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl
= [(Type
charPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
charPrimL_RDR))
,(Type
intPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
intPrimL_RDR)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
toInteger_RDR))
,(Type
wordPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
wordPrimL_RDR)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
toInteger_RDR))
,(Type
addrPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
stringPrimL_RDR)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
map_RDR)
(RdrName
IdP GhcPs
compose_RDR IdP GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
`nlHsApps`
[ IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
fromIntegral_RDR
, IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
fromEnum_RDR
])))
,(Type
floatPrimTy , LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
floatPrimL_RDR)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
toRational_RDR))
,(Type
doublePrimTy, LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
doublePrimL_RDR)
(Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> (Located (HsExpr GhcPs) -> Located (HsExpr GhcPs))
-> Located (HsExpr GhcPs)
-> Located (HsExpr GhcPs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
toRational_RDR))
]
assoc_ty_id :: HasCallStack => String
-> [(Type,a)]
-> Type
-> a
assoc_ty_id :: String -> [(Type, a)] -> Type -> a
assoc_ty_id String
cls_str [(Type, a)]
tbl Type
ty
| Just a
a <- [(Type, a)] -> Type -> Maybe a
forall a. [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, a)]
tbl Type
ty = a
a
| Bool
otherwise =
String -> SDoc -> a
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Error in deriving:"
(String -> SDoc
text String
"Can't derive" SDoc -> SDoc -> SDoc
<+> String -> SDoc
text String
cls_str SDoc -> SDoc -> SDoc
<+>
String -> SDoc
text String
"for primitive type" SDoc -> SDoc -> SDoc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr Type
ty)
assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe [(Type, a)]
tbl Type
ty = (Type, a) -> a
forall a b. (a, b) -> b
snd ((Type, a) -> a) -> Maybe (Type, a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Type, a) -> Bool) -> [(Type, a)] -> Maybe (Type, a)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\(Type
t, a
_) -> Type
t Type -> Type -> Bool
`eqType` Type
ty) [(Type, a)]
tbl
and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr LHsExpr GhcPs
a LHsExpr GhcPs
b = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
a RdrName
and_RDR LHsExpr GhcPs
b
eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr Type
ty LHsExpr GhcPs
a LHsExpr GhcPs
b
| Bool -> Bool
not (HasDebugCallStack => Type -> Bool
Type -> Bool
isUnliftedType Type
ty) = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
a RdrName
eq_RDR LHsExpr GhcPs
b
| Bool
otherwise = LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
a RdrName
prim_eq LHsExpr GhcPs
b
where
(RdrName
_, RdrName
_, RdrName
prim_eq, RdrName
_, RdrName
_) = String -> Type -> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps String
"Eq" Type
ty
untag_Expr :: [(RdrName, RdrName)]
-> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr :: [(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [] LHsExpr GhcPs
expr = LHsExpr GhcPs
expr
untag_Expr ((RdrName
untag_this, RdrName
put_tag_here) : [(RdrName, RdrName)]
more) LHsExpr GhcPs
expr
= LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs
nlHsCase (LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (IdP GhcPs -> [IdP GhcPs] -> LHsExpr GhcPs
forall (id :: Pass).
IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps RdrName
IdP GhcPs
dataToTag_RDR [RdrName
IdP GhcPs
untag_this]))
[LPat GhcPs
-> Located (HsExpr GhcPs) -> LMatch GhcPs (Located (HsExpr GhcPs))
forall (p :: Pass) (body :: * -> *).
LPat (GhcPass p)
-> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt (IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
put_tag_here) ([(RdrName, RdrName)] -> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [(RdrName, RdrName)]
more LHsExpr GhcPs
expr)]
enum_from_to_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
enum_from_then_to_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
enum_from_to_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_to_Expr LHsExpr GhcPs
f LHsExpr GhcPs
t2 = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
enumFromTo_RDR) LHsExpr GhcPs
f) LHsExpr GhcPs
t2
enum_from_then_to_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
enum_from_then_to_Expr LHsExpr GhcPs
f LHsExpr GhcPs
t LHsExpr GhcPs
t2 = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
enumFromThenTo_RDR) LHsExpr GhcPs
f) LHsExpr GhcPs
t) LHsExpr GhcPs
t2
showParen_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
showParen_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
showParen_Expr LHsExpr GhcPs
e1 LHsExpr GhcPs
e2 = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
showParen_RDR) LHsExpr GhcPs
e1) LHsExpr GhcPs
e2
nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr [] = String -> Located (HsExpr GhcPs)
forall a. String -> a
panic String
"nested_compose_expr"
nested_compose_Expr [LHsExpr GhcPs
e] = LHsExpr GhcPs -> LHsExpr GhcPs
parenify LHsExpr GhcPs
e
nested_compose_Expr (LHsExpr GhcPs
e:[LHsExpr GhcPs]
es)
= LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
compose_RDR) (LHsExpr GhcPs -> LHsExpr GhcPs
parenify LHsExpr GhcPs
e)) ([LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr [LHsExpr GhcPs]
es)
error_Expr :: String -> LHsExpr GhcPs
error_Expr :: String -> LHsExpr GhcPs
error_Expr String
string = LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
error_RDR) (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
string))
illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
illegal_Expr String
meth String
tp String
msg =
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
error_RDR) (HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String
meth String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'{'Char -> String -> String
forall a. a -> [a] -> [a]
:String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg)))
illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
illegal_toEnum_tag String
tp RdrName
maxtag =
LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
error_RDR)
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
append_RDR)
(HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString (String
"toEnum{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}: tag ("))))
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
showsPrec_RDR)
(Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a_RDR))
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
append_RDR)
(HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
") is outside of enumeration's range (0,")))
(LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
showsPrec_RDR)
(Integer -> LHsExpr GhcPs
forall (p :: Pass). Integer -> LHsExpr (GhcPass p)
nlHsIntLit Integer
0))
(IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
maxtag))
(HsLit GhcPs -> LHsExpr GhcPs
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (String -> HsLit GhcPs
forall (p :: Pass). String -> HsLit (GhcPass p)
mkHsString String
")"))))))
parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
parenify e :: LHsExpr GhcPs
e@(L _ (HsVar _ _)) = LHsExpr GhcPs
e
parenify LHsExpr GhcPs
e = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar LHsExpr GhcPs
e
genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp LHsExpr GhcPs
e1 RdrName
op LHsExpr GhcPs
e2 = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp LHsExpr GhcPs
e1 RdrName
IdP GhcPs
op LHsExpr GhcPs
e2)
genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp LHsExpr GhcPs
e1 RdrName
op LHsExpr GhcPs
e2 = LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass). LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsPar (LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
IsPass id =>
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp (IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
tagToEnum_RDR) (LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp LHsExpr GhcPs
e1 RdrName
IdP GhcPs
op LHsExpr GhcPs
e2))
a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
:: RdrName
a_RDR :: RdrName
a_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"a")
b_RDR :: RdrName
b_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"b")
c_RDR :: RdrName
c_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"c")
d_RDR :: RdrName
d_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"d")
f_RDR :: RdrName
f_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"f")
k_RDR :: RdrName
k_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"k")
z_RDR :: RdrName
z_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"z")
ah_RDR :: RdrName
ah_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"a#")
bh_RDR :: RdrName
bh_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"b#")
ch_RDR :: RdrName
ch_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"c#")
dh_RDR :: RdrName
dh_RDR = FastString -> RdrName
mkVarUnqual (String -> FastString
fsLit String
"d#")
as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
as_RDRs :: [RdrName]
as_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"a"String -> String -> String
forall a. [a] -> [a] -> [a]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]
bs_RDRs :: [RdrName]
bs_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"b"String -> String -> String
forall a. [a] -> [a] -> [a]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]
cs_RDRs :: [RdrName]
cs_RDRs = [ FastString -> RdrName
mkVarUnqual (String -> FastString
mkFastString (String
"c"String -> String -> String
forall a. [a] -> [a] -> [a]
++Arity -> String
forall a. Show a => a -> String
show Arity
i)) | Arity
i <- [(Arity
1::Int) .. ] ]
a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs
a_Expr :: LHsExpr GhcPs
a_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
a_RDR
b_Expr :: LHsExpr GhcPs
b_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
b_RDR
c_Expr :: LHsExpr GhcPs
c_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
c_RDR
z_Expr :: LHsExpr GhcPs
z_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
z_RDR
ltTag_Expr :: LHsExpr GhcPs
ltTag_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
ltTag_RDR
eqTag_Expr :: LHsExpr GhcPs
eqTag_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
eqTag_RDR
gtTag_Expr :: LHsExpr GhcPs
gtTag_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
gtTag_RDR
false_Expr :: LHsExpr GhcPs
false_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
false_RDR
true_Expr :: LHsExpr GhcPs
true_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
true_RDR
pure_Expr :: LHsExpr GhcPs
pure_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
pure_RDR
unsafeCodeCoerce_Expr :: LHsExpr GhcPs
unsafeCodeCoerce_Expr = IdP GhcPs -> LHsExpr GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar RdrName
IdP GhcPs
unsafeCodeCoerce_RDR
a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
a_Pat :: LPat GhcPs
a_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
a_RDR
b_Pat :: LPat GhcPs
b_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
b_RDR
c_Pat :: LPat GhcPs
c_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
c_RDR
d_Pat :: LPat GhcPs
d_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
d_RDR
k_Pat :: LPat GhcPs
k_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
k_RDR
z_Pat :: LPat GhcPs
z_Pat = IdP GhcPs -> LPat GhcPs
forall (id :: Pass). IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat RdrName
IdP GhcPs
z_RDR
minusInt_RDR, tagToEnum_RDR :: RdrName
minusInt_RDR :: RdrName
minusInt_RDR = TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (PrimOp -> TyVar
primOpId PrimOp
IntSubOp )
tagToEnum_RDR :: RdrName
tagToEnum_RDR = TyVar -> RdrName
forall thing. NamedThing thing => thing -> RdrName
getRdrName (PrimOp -> TyVar
primOpId PrimOp
TagToEnumOp)
new_tag2con_rdr_name, new_maxtag_rdr_name
:: SrcSpan -> TyCon -> TcM RdrName
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 <- TcRnIf TcGblEnv TcLclEnv Unique
forall gbl lcl. TcRnIf gbl lcl Unique
newUnique
RdrName -> TcM RdrName
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RdrName -> TcM RdrName) -> RdrName -> TcM RdrName
forall a b. (a -> b) -> a -> b
$ Name -> RdrName
Exact (Name -> RdrName) -> Name -> RdrName
forall a b. (a -> b) -> a -> b
$ Unique -> OccName -> SrcSpan -> Name
mkSystemNameAt Unique
uniq (OccName -> OccName
occ_fun (Name -> OccName
nameOccName Name
parent)) SrcSpan
loc
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons TyCon
tycon [Type]
tycon_args = (DataCon -> Bool) -> [DataCon] -> [DataCon]
forall a. (a -> Bool) -> [a] -> [a]
filter DataCon -> Bool
isPossible ([DataCon] -> [DataCon]) -> [DataCon] -> [DataCon]
forall a b. (a -> b) -> a -> b
$ TyCon -> [DataCon]
tyConDataCons TyCon
tycon
where
isPossible :: DataCon -> Bool
isPossible = Bool -> Bool
not (Bool -> Bool) -> (DataCon -> Bool) -> DataCon -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> DataCon -> Bool
dataConCannotMatch (TyCon -> [Type] -> [Type]
tyConInstArgTys TyCon
tycon [Type]
tycon_args)
tyConInstArgTys :: TyCon -> [Type] -> [Type]
tyConInstArgTys :: TyCon -> [Type] -> [Type]
tyConInstArgTys TyCon
tycon [Type]
tycon_args = [Type] -> [Type] -> [Type]
forall a. [a] -> [a] -> [a]
chkAppend [Type]
tycon_args ([Type] -> [Type]) -> [Type] -> [Type]
forall a b. (a -> b) -> a -> b
$ (TyVar -> Type) -> [TyVar] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map TyVar -> Type
mkTyVarTy [TyVar]
tycon_args_suffix
where
tycon_args_suffix :: [TyVar]
tycon_args_suffix = Arity -> [TyVar] -> [TyVar]
forall a. Arity -> [a] -> [a]
drop ([Type] -> Arity
forall (t :: * -> *) a. Foldable t => t a -> Arity
length [Type]
tycon_args) ([TyVar] -> [TyVar]) -> [TyVar] -> [TyVar]
forall a b. (a -> b) -> a -> b
$ TyCon -> [TyVar]
tyConTyVars TyCon
tycon