module GHC.Tc.Deriv.Generate (
BagDerivStuff, DerivStuff(..),
gen_Eq_binds,
gen_Ord_binds,
gen_Enum_binds,
gen_Bounded_binds,
gen_Ix_binds,
gen_Show_binds,
gen_Read_binds,
gen_Data_binds,
gen_Lift_binds,
gen_Newtype_binds,
mkCoerceClassMethEqn,
genAuxBinds,
ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.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.Lexeme
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Bag
import Data.List ( find, partition, intersperse )
type BagDerivStuff = Bag DerivStuff
data AuxBindSpec
= DerivCon2Tag
TyCon
RdrName
| DerivTag2Con
TyCon
RdrName
| DerivMaxTag
TyCon
RdrName
| DerivDataDataType
TyCon
RdrName
[RdrName]
| DerivDataConstr
DataCon
RdrName
RdrName
auxBindSpecRdrName :: AuxBindSpec -> RdrName
auxBindSpecRdrName (DerivCon2Tag _ con2tag_RDR) = con2tag_RDR
auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR
auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR
auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR
auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR
data DerivStuff
= DerivAuxBind AuxBindSpec
| DerivFamInst FamInst
gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Eq_binds loc tycon = do
con2tag_RDR <- new_con2tag_rdr_name loc tycon
return (method_binds con2tag_RDR, aux_binds con2tag_RDR)
where
all_cons = tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
(tag_match_cons, pat_match_cons)
| nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
| otherwise = ([], all_cons)
no_tag_match_cons = null tag_match_cons
fall_through_eqn con2tag_RDR
| no_tag_match_cons
= case pat_match_cons of
[] -> []
[_] -> []
_ ->
[([nlWildPat, nlWildPat], false_Expr)]
| otherwise
= [([a_Pat, b_Pat],
untag_Expr con2tag_RDR [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
aux_binds con2tag_RDR
| no_tag_match_cons = emptyBag
| otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR
method_binds con2tag_RDR = unitBag (eq_bind con2tag_RDR)
eq_bind con2tag_RDR
= mkFunBindEC 2 loc eq_RDR (const true_Expr)
(map pats_etc pat_match_cons
++ fall_through_eqn con2tag_RDR)
pats_etc data_con
= let
con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed
con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed
data_con_RDR = getRdrName data_con
con_arity = length tys_needed
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
tys_needed = dataConOrigArgTys data_con
in
([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed)
where
nested_eq_expr [] [] [] = true_Expr
nested_eq_expr tys as bs
= foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
where
nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
ordMethRdr :: OrdOp -> RdrName
ordMethRdr op
= case op of
OrdCompare -> compare_RDR
OrdLT -> lt_RDR
OrdLE -> le_RDR
OrdGE -> ge_RDR
OrdGT -> gt_RDR
ltResult :: OrdOp -> LHsExpr GhcPs
ltResult OrdCompare = ltTag_Expr
ltResult OrdLT = true_Expr
ltResult OrdLE = true_Expr
ltResult OrdGE = false_Expr
ltResult OrdGT = false_Expr
eqResult :: OrdOp -> LHsExpr GhcPs
eqResult OrdCompare = eqTag_Expr
eqResult OrdLT = false_Expr
eqResult OrdLE = true_Expr
eqResult OrdGE = true_Expr
eqResult OrdGT = false_Expr
gtResult :: OrdOp -> LHsExpr GhcPs
gtResult OrdCompare = gtTag_Expr
gtResult OrdLT = false_Expr
gtResult OrdLE = false_Expr
gtResult OrdGE = true_Expr
gtResult OrdGT = true_Expr
gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ord_binds loc tycon = do
con2tag_RDR <- new_con2tag_rdr_name loc tycon
return $ if null tycon_data_cons
then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
, emptyBag)
else ( unitBag (mkOrdOp con2tag_RDR OrdCompare)
`unionBags` other_ops con2tag_RDR
, aux_binds con2tag_RDR)
where
aux_binds con2tag_RDR
| single_con_type = emptyBag
| otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon con2tag_RDR
other_ops con2tag_RDR
| (last_tag first_tag) <= 2
|| null non_nullary_cons
= listToBag [mkOrdOp con2tag_RDR OrdLT, lE, gT, gE]
| otherwise
= emptyBag
negate_expr = nlHsApp (nlHsVar not_RDR)
lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $
negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $
nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $
negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
get_tag con = dataConTag con fIRST_TAG
tycon_data_cons = tyConDataCons tycon
single_con_type = isSingleton tycon_data_cons
(first_con : _) = tycon_data_cons
(last_con : _) = reverse tycon_data_cons
first_tag = get_tag first_con
last_tag = get_tag last_con
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
mkOrdOp :: RdrName -> OrdOp -> LHsBind GhcPs
mkOrdOp con2tag_RDR op
= mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]
(mkOrdOpRhs con2tag_RDR op)
mkOrdOpRhs :: RdrName -> OrdOp -> LHsExpr GhcPs
mkOrdOpRhs con2tag_RDR op
| nullary_cons `lengthAtMost` 2
= nlHsCase (nlHsVar a_RDR) $
map (mkOrdOpAlt con2tag_RDR op) tycon_data_cons
| null non_nullary_cons
= mkTagCmp con2tag_RDR op
| otherwise
= nlHsCase (nlHsVar a_RDR) $
(map (mkOrdOpAlt con2tag_RDR op) non_nullary_cons
++ [mkHsCaseAlt nlWildPat (mkTagCmp con2tag_RDR op)])
mkOrdOpAlt :: RdrName -> OrdOp -> DataCon
-> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt con2tag_RDR op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
(mkInnerRhs con2tag_RDR op data_con)
where
as_needed = take (dataConSourceArity data_con) as_RDRs
data_con_RDR = getRdrName data_con
mkInnerRhs con2tag_RDR op data_con
| single_con_type
= nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
| tag == first_tag
= nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkHsCaseAlt nlWildPat (ltResult op) ]
| tag == last_tag
= nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkHsCaseAlt nlWildPat (gtResult op) ]
| tag == first_tag + 1
= nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
(gtResult op)
, mkInnerEqAlt op data_con
, mkHsCaseAlt nlWildPat (ltResult op) ]
| tag == last_tag 1
= nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
(ltResult op)
, mkInnerEqAlt op data_con
, mkHsCaseAlt nlWildPat (gtResult op) ]
| tag > last_tag `div` 2
= untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $
nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
(gtResult op) $
nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkHsCaseAlt nlWildPat (ltResult op) ]
| otherwise
= untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $
nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
(ltResult op) $
nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkHsCaseAlt nlWildPat (gtResult op) ]
where
tag = get_tag data_con
tag_lit = noLoc (HsLit noExtField (HsIntPrim NoSourceText (toInteger tag)))
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con)
where
data_con_RDR = getRdrName data_con
bs_needed = take (dataConSourceArity data_con) bs_RDRs
mkTagCmp :: RdrName -> OrdOp -> LHsExpr GhcPs
mkTagCmp con2tag_RDR op =
untag_Expr con2tag_RDR [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
unliftedOrdOp intPrimTy op ah_RDR bh_RDR
mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
mkCompareFields op tys
= go tys as_RDRs bs_RDRs
where
go [] _ _ = eqResult op
go [ty] (a:_) (b:_)
| isUnliftedType ty = unliftedOrdOp ty op a b
| otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
(ltResult op)
(go tys as bs)
(gtResult op)
go _ _ _ = panic "mkCompareFields"
mk_compare ty a b lt eq gt
| isUnliftedType ty
= unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
| otherwise
= nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
[mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
where
a_expr = nlHsVar a
b_expr = nlHsVar b
(lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
unliftedOrdOp ty op a b
= case op of
OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
ltTag_Expr eqTag_Expr gtTag_Expr
OrdLT -> wrap lt_op
OrdLE -> wrap le_op
OrdGE -> wrap ge_op
OrdGT -> wrap gt_op
where
(lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
wrap prim_op = genPrimOpApp a_expr prim_op b_expr
a_expr = nlHsVar a
b_expr = nlHsVar b
unliftedCompare :: RdrName -> RdrName
-> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
= nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
where
ascribeBool e = nlExprWithTySig e $ nlHsTyVar boolTyCon_RDR
nlConWildPat :: DataCon -> LPat GhcPs
nlConWildPat con = noLoc $ ConPat
{ pat_con_ext = noExtField
, pat_con = noLoc $ getRdrName con
, pat_args = RecCon $ HsRecFields
{ rec_flds = []
, rec_dotdot = Nothing }
}
gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Enum_binds loc tycon = do
con2tag_RDR <- new_con2tag_rdr_name loc tycon
tag2con_RDR <- new_tag2con_rdr_name loc tycon
maxtag_RDR <- new_maxtag_rdr_name loc tycon
return ( method_binds con2tag_RDR tag2con_RDR maxtag_RDR
, aux_binds con2tag_RDR tag2con_RDR maxtag_RDR )
where
method_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag
[ succ_enum con2tag_RDR tag2con_RDR maxtag_RDR
, pred_enum con2tag_RDR tag2con_RDR
, to_enum tag2con_RDR maxtag_RDR
, enum_from con2tag_RDR tag2con_RDR maxtag_RDR
, enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR
, from_enum con2tag_RDR
]
aux_binds con2tag_RDR tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind
[ DerivCon2Tag tycon con2tag_RDR
, DerivTag2Con tycon tag2con_RDR
, DerivMaxTag tycon maxtag_RDR
]
occ_nm = getOccString tycon
succ_enum con2tag_RDR tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $
untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR,
nlHsVarApps intDataCon_RDR [ah_RDR]])
(illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
(nlHsApp (nlHsVar tag2con_RDR)
(nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsIntLit 1]))
pred_enum con2tag_RDR tag2con_RDR
= mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $
untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
nlHsVarApps intDataCon_RDR [ah_RDR]])
(illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
(nlHsApp (nlHsVar tag2con_RDR)
(nlHsApps plus_RDR
[ nlHsVarApps intDataCon_RDR [ah_RDR]
, nlHsLit (HsInt noExtField
(mkIntegralLit (1 :: Int)))]))
to_enum tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $
nlHsIf (nlHsApps and_RDR
[nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
nlHsApps le_RDR [ nlHsVar a_RDR
, nlHsVar maxtag_RDR]])
(nlHsVarApps tag2con_RDR [a_RDR])
(illegal_toEnum_tag occ_nm maxtag_RDR)
enum_from con2tag_RDR tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $
untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
nlHsApps map_RDR
[nlHsVar tag2con_RDR,
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVar maxtag_RDR))]
enum_from_then con2tag_RDR tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
untag_Expr con2tag_RDR [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
nlHsPar (enum_from_then_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR])
(nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsVarApps intDataCon_RDR [bh_RDR]])
(nlHsIntLit 0)
(nlHsVar maxtag_RDR)
))
from_enum con2tag_RDR
= mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $
untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
gen_Bounded_binds loc tycon
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
| otherwise
= ASSERT(isSingleton data_cons)
(listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
where
data_cons = tyConDataCons tycon
min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
data_con_1 = head data_cons
data_con_N = last data_cons
data_con_1_RDR = getRdrName data_con_1
data_con_N_RDR = getRdrName data_con_N
arity = dataConSourceArity data_con_1
min_bound_1con = mkHsVarBind loc minBound_RDR $
nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)
max_bound_1con = mkHsVarBind loc maxBound_RDR $
nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)
gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)
gen_Ix_binds loc tycon = do
con2tag_RDR <- new_con2tag_rdr_name loc tycon
tag2con_RDR <- new_tag2con_rdr_name loc tycon
return $ if isEnumerationTyCon tycon
then (enum_ixes con2tag_RDR tag2con_RDR, listToBag $ map DerivAuxBind
[ DerivCon2Tag tycon con2tag_RDR
, DerivTag2Con tycon tag2con_RDR
])
else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon con2tag_RDR)))
where
enum_ixes con2tag_RDR tag2con_RDR = listToBag
[ enum_range con2tag_RDR tag2con_RDR
, enum_index con2tag_RDR
, enum_inRange con2tag_RDR
]
enum_range con2tag_RDR tag2con_RDR
= mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] $
untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR]))
enum_index con2tag_RDR
= mkSimpleGeneratedFunBind loc unsafeIndex_RDR
[noLoc (AsPat noExtField (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (
untag_Expr con2tag_RDR [(d_RDR, dh_RDR)] (
let
rhs = nlHsVarApps intDataCon_RDR [c_RDR]
in
nlHsCase
(genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
[mkHsCaseAlt (nlVarPat c_RDR) rhs]
))
)
enum_inRange con2tag_RDR
= mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
untag_Expr con2tag_RDR [(a_RDR, ah_RDR)] (
untag_Expr con2tag_RDR [(b_RDR, bh_RDR)] (
untag_Expr con2tag_RDR [(c_RDR, ch_RDR)] (
nlHsApps and_RDR
[ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
, genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
]
)))
single_con_ixes
= listToBag [single_con_range, single_con_index, single_con_inRange]
data_con
= case tyConSingleDataCon_maybe tycon of
Nothing -> panic "get_Ix_binds"
Just dc -> dc
con_arity = dataConSourceArity data_con
data_con_RDR = getRdrName data_con
as_needed = take con_arity as_RDRs
bs_needed = take con_arity bs_RDRs
cs_needed = take con_arity cs_RDRs
con_pat xs = nlConVarPat data_con_RDR xs
con_expr = nlHsVarApps data_con_RDR cs_needed
single_con_range
= mkSimpleGeneratedFunBind loc range_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
noLoc (mkHsComp ListComp stmts con_expr)
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
mk_qual a b c = noLoc $ mkPsBindStmt (nlVarPat c)
(nlHsApp (nlHsVar range_RDR)
(mkLHsVarTuple [a,b]))
single_con_index
= mkSimpleGeneratedFunBind loc unsafeIndex_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed]
(mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
where
mk_index [] = nlHsIntLit 0
mk_index [(l,u,i)] = mk_one l u i
mk_index ((l,u,i) : rest)
= genOpApp (
mk_one l u i
) plus_RDR (
genOpApp (
(nlHsApp (nlHsVar unsafeRangeSize_RDR)
(mkLHsVarTuple [l,u]))
) times_RDR (mk_index rest)
)
mk_one l u i
= nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
single_con_inRange
= mkSimpleGeneratedFunBind loc inRange_RDR
[nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
con_pat cs_needed] $
if con_arity == 0
then true_Expr
else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
as_needed bs_needed cs_needed)
where
in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
-> (LHsBinds GhcPs, BagDerivStuff)
gen_Read_binds get_fixity loc tycon
= (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
where
default_readlist
= mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
default_readlistprec
= mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
data_cons = tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
read_prec = mkHsVarBind loc readPrec_RDR rhs
where
rhs | null data_cons
= nlHsVar pfail_RDR
| otherwise
= nlHsApp (nlHsVar parens_RDR)
(foldr1 mk_alt (read_nullary_cons ++
read_non_nullary_cons))
read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
read_nullary_cons
= case nullary_cons of
[] -> []
[con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
match_con con | isSym con_str = [symbol_pat con_str]
| otherwise = ident_h_pat con_str
where
con_str = data_con_str con
mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
result_expr con []]
read_non_nullary_con data_con
| is_infix = mk_parser infix_prec infix_stmts body
| is_record = mk_parser record_prec record_stmts body
| otherwise = prefix_parser
where
body = result_expr data_con as_needed
con_str = data_con_str data_con
prefix_parser = mk_parser prefix_prec prefix_stmts body
read_prefix_con
| isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
| otherwise = ident_h_pat con_str
read_infix_con
| isSym con_str = [symbol_pat con_str]
| otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
prefix_stmts
= read_prefix_con ++ read_args
infix_stmts
= [read_a1]
++ read_infix_con
++ [read_a2]
record_stmts
= read_prefix_con
++ [read_punc "{"]
++ concat (intersperse [read_punc ","] field_stmts)
++ [read_punc "}"]
field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
con_arity = dataConSourceArity data_con
labels = map flLabel $ dataConFieldLabels data_con
dc_nm = getName data_con
is_infix = dataConIsInfix data_con
is_record = labels `lengthExceeds` 0
as_needed = take con_arity as_RDRs
read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con)
(read_a1:read_a2:_) = read_args
prefix_prec = appPrecedence
infix_prec = getPrecedence get_fixity dc_nm
record_prec = appPrecedence + 1
mk_alt e1 e2 = genOpApp e1 alt_RDR e2
mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p
, nlHsDo (DoExpr Nothing) (ss ++ [noLoc $ mkLastStmt b])]
con_app con as = nlHsVarApps (getRdrName con) as
result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)
ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
| otherwise = [ ident_pat s ]
bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat))
ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)]
symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]
read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)]
data_con_str con = occNameString (getOccName con)
read_arg a ty = ASSERT( not (isUnliftedType ty) )
noLoc (mkPsBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
read_field lbl a =
[noLoc
(mkPsBindStmt
(nlVarPat a)
(nlHsApp
read_field
(nlHsVarApps reset_RDR [readPrec_RDR])
)
)
]
where
lbl_str = unpackFS lbl
mk_read_field read_field_rdr lbl
= nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
read_field
| isSym lbl_str
= mk_read_field readSymField_RDR lbl_str
| Just (ss, '#') <- snocView lbl_str
= mk_read_field readFieldHash_RDR ss
| otherwise
= mk_read_field readField_RDR lbl_str
gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon
-> (LHsBinds GhcPs, BagDerivStuff)
gen_Show_binds get_fixity loc tycon
= (unitBag shows_prec, emptyBag)
where
data_cons = tyConDataCons tycon
shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
comma_space = nlHsVar showCommaSpace_RDR
pats_etc data_con
| nullary_con =
ASSERT(null bs_needed)
([nlWildPat, con_pat], mk_showString_app op_con_str)
| otherwise =
([a_Pat, con_pat],
showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
(HsInt noExtField (mkIntegralLit con_prec_plus_one))))
(nlHsPar (nested_compose_Expr show_thingies)))
where
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
bs_needed = take con_arity bs_RDRs
arg_tys = dataConOrigArgTys data_con
con_pat = nlConVarPat data_con_RDR bs_needed
nullary_con = con_arity == 0
labels = map flLabel $ dataConFieldLabels data_con
lab_fields = length labels
record_syntax = lab_fields > 0
dc_nm = getName data_con
dc_occ_nm = getOccName data_con
con_str = occNameString dc_occ_nm
op_con_str = wrapOpParens con_str
backquote_str = wrapOpBackquotes con_str
show_thingies
| is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
| record_syntax = mk_showString_app (op_con_str ++ " {") :
show_record_args ++ [mk_showString_app "}"]
| otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
show_label l = mk_showString_app (nm ++ " = ")
where
nm = wrapOpParens (unpackFS l)
show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys)
(show_arg1:show_arg2:_) = show_args
show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
show_record_args = concat $
intersperse [comma_space] $
[ [show_label lbl, arg]
| (lbl,arg) <- zipEqual "gen_Show_binds"
labels show_args ]
show_arg :: RdrName -> Type -> LHsExpr GhcPs
show_arg b arg_ty
| isUnliftedType arg_ty
= with_conv $
nlHsApps compose_RDR
[mk_shows_app boxed_arg, mk_showString_app postfixMod]
| otherwise
= mk_showsPrec_app arg_prec arg
where
arg = nlHsVar b
boxed_arg = box "Show" arg arg_ty
postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
with_conv expr
| (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
nested_compose_Expr
[ mk_showString_app ("(" ++ conv ++ " ")
, expr
, mk_showString_app ")"
]
| otherwise = expr
is_infix = dataConIsInfix data_con
con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
arg_prec | record_syntax = 0
| otherwise = con_prec_plus_one
wrapOpParens :: String -> String
wrapOpParens s | isSym s = '(' : s ++ ")"
| otherwise = s
wrapOpBackquotes :: String -> String
wrapOpBackquotes s | isSym s = s
| otherwise = '`' : s ++ "`"
isSym :: String -> Bool
isSym "" = False
isSym (c : _) = startsVarSym c || startsConSym c
mk_showString_app :: String -> LHsExpr GhcPs
mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
mk_showsPrec_app p x
= nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x]
mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
getPrec is_infix get_fixity nm
| not is_infix = appPrecedence
| otherwise = getPrecedence get_fixity nm
appPrecedence :: Integer
appPrecedence = fromIntegral maxPrecedence + 1
getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence get_fixity nm
= case get_fixity nm of
Fixity _ x _assoc -> fromIntegral x
gen_Data_binds :: SrcSpan
-> TyCon
-> TcM (LHsBinds GhcPs,
BagDerivStuff)
gen_Data_binds loc rep_tc
= do {
dataT_RDR <- new_dataT_rdr_name loc rep_tc
; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
; pure ( listToBag [ gfoldl_bind, gunfold_bind
, toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]
`unionBags` gcast_binds
, listToBag $ map DerivAuxBind
( DerivDataDataType rep_tc dataT_RDR dataC_RDRs
: zipWith (\data_con dataC_RDR ->
DerivDataConstr data_con dataC_RDR dataT_RDR)
data_cons dataC_RDRs )
) }
where
data_cons = tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
gfoldl_eqn con
= ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed)
where
con_name :: RdrName
con_name = getRdrName con
as_needed = take (dataConSourceArity con) as_RDRs
mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
gunfold_bind = mkSimpleGeneratedFunBind loc
gunfold_RDR
[k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
gunfold_rhs
gunfold_rhs
| one_constr = mk_unfold_rhs (head data_cons)
| otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
(map gunfold_alt data_cons)
gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
mk_unfold_rhs dc = foldr nlHsApp
(z_Expr `nlHsApp` (eta_expand_data_con dc))
(replicate (dataConSourceArity dc) (nlHsVar k_RDR))
eta_expand_data_con dc =
mkHsLam eta_expand_pats
(foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)
where
eta_expand_pats = map nlVarPat eta_expand_vars
eta_expand_hsvars = map nlHsVar eta_expand_vars
eta_expand_vars = take (dataConSourceArity dc) as_RDRs
mk_unfold_pat dc
| tagfIRST_TAG == n_cons1 = nlWildPat
| otherwise = nlConPat intDataCon_RDR
[nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
where
tag = dataConTag dc
toCon_bind dataC_RDRs
= mkFunBindEC 1 loc toConstr_RDR id
(zipWith to_con_eqn data_cons dataC_RDRs)
to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
dataTypeOf_bind dataT_RDR
= mkSimpleGeneratedFunBind
loc
dataTypeOf_RDR
[nlWildPat]
(nlHsVar dataT_RDR)
tycon_kind = case tyConFamInst_maybe rep_tc of
Just (fam_tc, _) -> tyConKind fam_tc
Nothing -> tyConKind rep_tc
gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
| tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
| otherwise = emptyBag
mk_gcast dataCast_RDR gcast_RDR
= unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR]
(nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
kind1, kind2 :: Kind
kind1 = typeToTypeKind
kind2 = liftedTypeKind `mkVisFunTyMany` kind1
gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
constr_RDR, dataType_RDR,
eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR ,
eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
extendWord8_RDR, extendInt8_RDR,
extendWord16_RDR, extendInt16_RDR :: RdrName
gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#")
ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" )
leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#")
gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" )
geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#")
eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#")
ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" )
leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#")
gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" )
geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#")
eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#")
ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" )
leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#")
gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" )
geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#")
eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#")
ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" )
leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#")
gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" )
geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#")
eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
extendWord8_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord8#")
extendInt8_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt8#")
extendWord16_RDR = varQual_RDR gHC_PRIM (fsLit "extendWord16#")
extendInt16_RDR = varQual_RDR gHC_PRIM (fsLit "extendInt16#")
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)
gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
(map (pats_etc mk_exp) data_cons)
liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
(map (pats_etc mk_texp) data_cons)
mk_exp = ExpBr noExtField
mk_texp = TExpBr noExtField
data_cons = tyConDataCons tycon
pats_etc mk_bracket data_con
= ([con_pat], lift_Expr)
where
con_pat = nlConVarPat data_con_RDR as_needed
data_con_RDR = getRdrName data_con
con_arity = dataConSourceArity data_con
as_needed = take con_arity as_RDRs
lift_Expr = noLoc (HsBracket noExtField (mk_bracket br_body))
br_body = nlHsApps (Exact (dataConName data_con))
(map nlHsVar as_needed)
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
= do let ats = classATs cls
(binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
mapM mk_atf_inst ats
return ( listToBag binds
, sigs
, listToBag $ map DerivFamInst atf_insts )
where
mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)
mk_bind_and_sig meth_id
= (
mkRdrFunBind loc_meth_RDR [mkSimpleMatch
(mkPrefixFunRhs loc_meth_RDR)
[] rhs_expr]
,
L loc $ ClassOpSig noExtField False [loc_meth_RDR]
$ mkLHsSigType $ nlHsCoreTy to_ty
)
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
(_, _, from_tau) = tcSplitSigmaTy from_ty
(_, _, to_tau) = tcSplitSigmaTy to_ty
meth_RDR = getRdrName meth_id
loc_meth_RDR = L loc meth_RDR
rhs_expr = nlHsVar (getRdrName coerceId)
`nlHsAppType` from_tau
`nlHsAppType` to_tau
`nlHsApp` meth_app
meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $
filterOutInferredTypes (classTyCon cls) underlying_inst_tys
mk_atf_inst :: TyCon -> TcM FamInst
mk_atf_inst fam_tc = do
rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))
rep_lhs_tys
let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'
fam_tc rep_lhs_tys rep_rhs_ty
checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
newFamInst SynFamilyInst axiom
where
cls_tvs = classTyVars cls
in_scope = mkInScopeSet $ mkVarSet inst_tvs
lhs_env = zipTyEnv cls_tvs inst_tys
lhs_subst = mkTvSubst in_scope lhs_env
rhs_env = zipTyEnv cls_tvs underlying_inst_tys
rhs_subst = mkTvSubst in_scope rhs_env
fam_tvs = tyConTyVars fam_tc
rep_lhs_tys = substTyVars lhs_subst fam_tvs
rep_rhs_tys = substTyVars rhs_subst fam_tvs
rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys
rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys
(rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
rep_tvs' = scopedSort rep_tvs
rep_cvs' = scopedSort rep_cvs
underlying_inst_tys :: [Type]
underlying_inst_tys = changeLast inst_tys rhs_ty
nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType e s = noLoc (HsAppType noExtField e hs_ty)
where
hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
nlExprWithTySig :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs
nlExprWithTySig e s = noLoc $ ExprWithTySig noExtField (parenthesizeHsExpr sigPrec e) hs_ty
where
hs_ty = mkLHsSigWcType s
nlHsCoreTy :: Type -> LHsType GhcPs
nlHsCoreTy = noLoc . XHsType . NHsCoreTy
mkCoerceClassMethEqn :: Class
-> [TyVar]
-> [Type]
-> Type
-> Id
-> Pair Type
mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
= Pair (substTy rhs_subst user_meth_ty)
(substTy lhs_subst user_meth_ty)
where
cls_tvs = classTyVars cls
in_scope = mkInScopeSet $ mkVarSet inst_tvs
lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
(_class_tvs, _class_constraint, user_meth_ty)
= tcSplitMethodTy (varType id)
genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecOriginal dflags loc spec
= (gen_bind spec,
L loc (TypeSig noExtField [L loc (auxBindSpecRdrName spec)]
(genAuxBindSpecSig loc spec)))
where
gen_bind :: AuxBindSpec -> LHsBind GhcPs
gen_bind (DerivCon2Tag tycon con2tag_RDR)
= mkFunBindSE 0 loc con2tag_RDR eqns
where
lots_of_constructors = tyConFamilySize tycon > 8
eqns | lots_of_constructors = [get_tag_eqn]
| otherwise = map mk_eqn (tyConDataCons tycon)
get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)
mk_eqn con = ([nlWildConPat con],
nlHsLit (HsIntPrim NoSourceText
(toInteger ((dataConTag con) fIRST_TAG))))
gen_bind (DerivTag2Con _ tag2con_RDR)
= mkFunBindSE 0 loc tag2con_RDR
[([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)]
gen_bind (DerivMaxTag tycon maxtag_RDR)
= mkHsVarBind loc maxtag_RDR rhs
where
rhs = nlHsApp (nlHsVar intDataCon_RDR)
(nlHsLit (HsIntPrim NoSourceText max_tag))
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) fIRST_TAG)
gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)
= mkHsVarBind loc dataT_RDR rhs
where
ctx = initDefaultSDocContext dflags
rhs = nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (ppr tycon)))
`nlHsApp` nlList (map nlHsVar dataC_RDRs)
gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
= mkHsVarBind loc dataC_RDR rhs
where
rhs = nlHsApps mkConstr_RDR constr_args
constr_args
= [
nlHsVar dataT_RDR
, nlHsLit (mkHsString (occNameString dc_occ))
, nlList labels
, nlHsVar fixity ]
labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
(dataConFieldLabels dc)
dc_occ = getOccName dc
is_infix = isDataSymOcc dc_occ
fixity | is_infix = infix_RDR
| otherwise = prefix_RDR
genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
-> (LHsBind GhcPs, LSig GhcPs)
genAuxBindSpecDup loc original_rdr_name dup_spec
= (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name),
L loc (TypeSig noExtField [L loc dup_rdr_name]
(genAuxBindSpecSig loc dup_spec)))
where
dup_rdr_name = auxBindSpecRdrName dup_spec
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig loc spec = case spec of
DerivCon2Tag tycon _
-> mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $
mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
mkParentType tycon `mkVisFunTyMany` intPrimTy
DerivTag2Con tycon _
-> mkLHsSigWcType $ L loc $
XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
intTy `mkVisFunTyMany` mkParentType tycon
DerivMaxTag _ _
-> mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))
DerivDataDataType _ _ _
-> mkLHsSigWcType (nlHsTyVar dataType_RDR)
DerivDataConstr _ _ _
-> mkLHsSigWcType (nlHsTyVar constr_RDR)
type SeparateBagsDerivStuff =
( Bag (LHsBind GhcPs, LSig GhcPs)
, Bag FamInst )
genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds dflags loc b = (gen_aux_bind_specs b1, b2) where
(b1,b2) = partitionBagWith splitDerivAuxBind b
splitDerivAuxBind (DerivAuxBind x) = Left x
splitDerivAuxBind (DerivFamInst t) = Right t
gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
gen_aux_bind_spec :: AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) =
case lookupOccEnv original_rdr_name_env spec_occ of
Nothing
-> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name
, genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag )
Just original_rdr_name
-> ( original_rdr_name_env
, genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )
where
spec_rdr_name = auxBindSpecRdrName spec
spec_occ = rdrNameOcc spec_rdr_name
mkParentType :: TyCon -> Type
mkParentType tc
= case tyConFamInst_maybe tc of
Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
Just (fam_tc,tys) -> mkTyConApp fam_tc tys
mkFunBindSE :: Arity -> SrcSpan -> RdrName
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindSE arity loc fun pats_and_exprs
= mkRdrFunBindSE arity (L loc fun) matches
where
matches = [mkMatch (mkPrefixFunRhs (L loc fun))
(map (parenthesizePat appPrec) p) e
(noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs]
mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
= L loc (mkFunBind Generated fun matches)
mkFunBindEC :: Arity -> SrcSpan -> RdrName
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> [([LPat GhcPs], LHsExpr GhcPs)]
-> LHsBind GhcPs
mkFunBindEC arity loc fun catch_all pats_and_exprs
= mkRdrFunBindEC arity catch_all (L loc fun) matches
where
matches = [ mkMatch (mkPrefixFunRhs (L loc fun))
(map (parenthesizePat appPrec) p) e
(noLoc emptyLocalBinds)
| (p,e) <- pats_and_exprs ]
mkRdrFunBindEC :: Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> Located RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all
fun@(L loc _fun_rdr) matches = L loc (mkFunBind Generated fun matches')
where
matches' = if null matches
then [mkMatch (mkPrefixFunRhs fun)
(replicate (arity 1) nlWildPat ++ [z_Pat])
(catch_all $ nlHsCase z_Expr [])
(noLoc emptyLocalBinds)]
else matches
mkRdrFunBindSE :: Arity -> Located RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity
fun@(L loc fun_rdr) matches = L loc (mkFunBind Generated fun matches')
where
matches' = if null matches
then [mkMatch (mkPrefixFunRhs fun)
(replicate arity nlWildPat)
(error_Expr str) (noLoc emptyLocalBinds)]
else matches
str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
box :: String
-> LHsExpr GhcPs
-> Type
-> LHsExpr GhcPs
box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
primOrdOps :: String
-> Type
-> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps str ty = assoc_ty_id str ordOpTbl ty
ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
ordOpTbl
= [(charPrimTy , (ltChar_RDR , leChar_RDR
, eqChar_RDR , geChar_RDR , gtChar_RDR ))
,(intPrimTy , (ltInt_RDR , leInt_RDR
, eqInt_RDR , geInt_RDR , gtInt_RDR ))
,(int8PrimTy , (ltInt8_RDR , leInt8_RDR
, eqInt8_RDR , geInt8_RDR , gtInt8_RDR ))
,(int16PrimTy , (ltInt16_RDR , leInt16_RDR
, eqInt16_RDR , geInt16_RDR , gtInt16_RDR ))
,(wordPrimTy , (ltWord_RDR , leWord_RDR
, eqWord_RDR , geWord_RDR , gtWord_RDR ))
,(word8PrimTy , (ltWord8_RDR , leWord8_RDR
, eqWord8_RDR , geWord8_RDR , gtWord8_RDR ))
,(word16PrimTy, (ltWord16_RDR, leWord16_RDR
, eqWord16_RDR, geWord16_RDR, gtWord16_RDR ))
,(addrPrimTy , (ltAddr_RDR , leAddr_RDR
, eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
,(floatPrimTy , (ltFloat_RDR , leFloat_RDR
, eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
,(doublePrimTy, (ltDouble_RDR, leDouble_RDR
, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
boxConTbl =
[ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon))
, (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon))
, (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
, (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
, (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
, (int8PrimTy,
nlHsApp (nlHsVar $ getRdrName intDataCon)
. nlHsApp (nlHsVar extendInt8_RDR))
, (word8PrimTy,
nlHsApp (nlHsVar $ getRdrName wordDataCon)
. nlHsApp (nlHsVar extendWord8_RDR))
, (int16PrimTy,
nlHsApp (nlHsVar $ getRdrName intDataCon)
. nlHsApp (nlHsVar extendInt16_RDR))
, (word16PrimTy,
nlHsApp (nlHsVar $ getRdrName wordDataCon)
. nlHsApp (nlHsVar extendWord16_RDR))
]
postfixModTbl :: [(Type, String)]
postfixModTbl
= [(charPrimTy , "#" )
,(intPrimTy , "#" )
,(wordPrimTy , "##")
,(floatPrimTy , "#" )
,(doublePrimTy, "##")
,(int8PrimTy, "#")
,(word8PrimTy, "##")
,(int16PrimTy, "#")
,(word16PrimTy, "##")
]
primConvTbl :: [(Type, String)]
primConvTbl =
[ (int8PrimTy, "narrowInt8#")
, (word8PrimTy, "narrowWord8#")
, (int16PrimTy, "narrowInt16#")
, (word16PrimTy, "narrowWord16#")
]
litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
litConTbl
= [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
. nlHsApp (nlHsVar toInteger_RDR))
,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
. nlHsApp (nlHsVar toInteger_RDR))
,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
. nlHsApp (nlHsApp
(nlHsVar map_RDR)
(compose_RDR `nlHsApps`
[ nlHsVar fromIntegral_RDR
, nlHsVar fromEnum_RDR
])))
,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
. nlHsApp (nlHsVar toRational_RDR))
,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
. nlHsApp (nlHsVar toRational_RDR))
]
assoc_ty_id :: HasCallStack => String
-> [(Type,a)]
-> Type
-> a
assoc_ty_id cls_str tbl ty
| Just a <- assoc_ty_id_maybe tbl ty = a
| otherwise =
pprPanic "Error in deriving:"
(text "Can't derive" <+> text cls_str <+>
text "for primitive type" <+> ppr ty)
assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
and_Expr a b = genOpApp a and_RDR b
eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
eq_Expr ty a b
| not (isUnliftedType ty) = genOpApp a eq_RDR b
| otherwise = genPrimOpApp a prim_eq b
where
(_, _, prim_eq, _, _) = primOrdOps "Eq" ty
untag_Expr :: RdrName -> [(RdrName, RdrName)]
-> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr _ [] expr = expr
untag_Expr con2tag_RDR ((untag_this, put_tag_here) : more) expr
= nlHsCase (nlHsPar (nlHsVarApps con2tag_RDR [untag_this]))
[mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr con2tag_RDR more 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 f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
showParen_Expr
:: LHsExpr GhcPs -> LHsExpr GhcPs
-> LHsExpr GhcPs
showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
nested_compose_Expr [] = panic "nested_compose_expr"
nested_compose_Expr [e] = parenify e
nested_compose_Expr (e:es)
= nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
error_Expr :: String -> LHsExpr GhcPs
error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
illegal_Expr meth tp msg =
nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
illegal_toEnum_tag tp maxtag =
nlHsApp (nlHsVar error_RDR)
(nlHsApp (nlHsApp (nlHsVar append_RDR)
(nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
(nlHsApp (nlHsApp (nlHsApp
(nlHsVar showsPrec_RDR)
(nlHsIntLit 0))
(nlHsVar a_RDR))
(nlHsApp (nlHsApp
(nlHsVar append_RDR)
(nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
(nlHsApp (nlHsApp (nlHsApp
(nlHsVar showsPrec_RDR)
(nlHsIntLit 0))
(nlHsVar maxtag))
(nlHsLit (mkHsString ")"))))))
parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
parenify e@(L _ (HsVar _ _)) = e
parenify e = mkHsPar e
genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op 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 = mkVarUnqual (fsLit "a")
b_RDR = mkVarUnqual (fsLit "b")
c_RDR = mkVarUnqual (fsLit "c")
d_RDR = mkVarUnqual (fsLit "d")
f_RDR = mkVarUnqual (fsLit "f")
k_RDR = mkVarUnqual (fsLit "k")
z_RDR = mkVarUnqual (fsLit "z")
ah_RDR = mkVarUnqual (fsLit "a#")
bh_RDR = mkVarUnqual (fsLit "b#")
ch_RDR = mkVarUnqual (fsLit "c#")
dh_RDR = mkVarUnqual (fsLit "d#")
as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(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 = nlHsVar a_RDR
b_Expr = nlHsVar b_RDR
c_Expr = nlHsVar c_RDR
z_Expr = nlHsVar z_RDR
ltTag_Expr = nlHsVar ltTag_RDR
eqTag_Expr = nlHsVar eqTag_RDR
gtTag_Expr = nlHsVar gtTag_RDR
false_Expr = nlHsVar false_RDR
true_Expr = nlHsVar true_RDR
pure_Expr = nlHsVar pure_RDR
unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR
a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
a_Pat = nlVarPat a_RDR
b_Pat = nlVarPat b_RDR
c_Pat = nlVarPat c_RDR
d_Pat = nlVarPat d_RDR
k_Pat = nlVarPat k_RDR
z_Pat = nlVarPat z_RDR
minusInt_RDR, tagToEnum_RDR :: RdrName
minusInt_RDR = getRdrName (primOpId IntSubOp )
tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
new_con2tag_rdr_name, new_tag2con_rdr_name, new_maxtag_rdr_name
:: SrcSpan -> TyCon -> TcM RdrName
new_con2tag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkCon2TagOcc
new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc
new_maxtag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc
new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
new_dataT_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkDataTOcc
new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
new_dataC_rdr_name dflags dc = new_dc_deriv_rdr_name dflags dc mkDataCOcc
new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
new_tc_deriv_rdr_name loc tycon occ_fun
= newAuxBinderRdrName loc (tyConName tycon) occ_fun
new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
new_dc_deriv_rdr_name loc dc occ_fun
= newAuxBinderRdrName loc (dataConName dc) occ_fun
newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
newAuxBinderRdrName loc parent occ_fun = do
uniq <- newUnique
pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc