module GHC.Tc.Deriv.Generate (
AuxBindSpec(..),
gen_Eq_binds,
gen_Ord_binds,
gen_Enum_binds,
gen_Bounded_binds,
gen_Ix_binds,
gen_Show_binds,
gen_Read_binds,
gen_Data_binds,
gen_Lift_binds,
gen_Newtype_binds,
gen_Newtype_fam_insts,
mkCoerceClassMethEqn,
genAuxBinds,
ordOpTbl, boxConTbl, litConTbl,
mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
getPossibleDataCons,
DerivInstTys(..), buildDataConInstArgEnv,
derivDataConInstArgTys, substDerivInstTys, zonkDerivInstTys
) where
import GHC.Prelude
import GHC.Tc.Utils.Monad
import GHC.Tc.TyCl.Class ( substATBndrs )
import GHC.Hs
import GHC.Types.Name.Reader
import GHC.Types.Basic
import GHC.Types.Fixity
import GHC.Core.DataCon
import GHC.Types.Name
import GHC.Types.SourceText
import GHC.Driver.Session
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
import GHC.Builtin.Names
import GHC.Builtin.Names.TH
import GHC.Types.Id.Make ( coerceId )
import GHC.Builtin.PrimOps
import GHC.Builtin.PrimOps.Ids (primOpId)
import GHC.Types.SrcLoc
import GHC.Core.TyCon
import GHC.Tc.Utils.Env
import GHC.Tc.Utils.TcType
import GHC.Tc.Utils.Zonk
import GHC.Tc.Validity ( checkValidCoAxBranch )
import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
import GHC.Builtin.Types.Prim
import GHC.Builtin.Types
import GHC.Core.Type
import GHC.Core.Class
import GHC.Types.Unique.FM ( lookupUFM, listToUFM )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
import GHC.Utils.Misc
import GHC.Types.Var
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Lexeme
import GHC.Data.FastString
import GHC.Data.Pair
import GHC.Data.Bag
import Data.List ( find, partition, intersperse )
import GHC.Data.Maybe ( expectJust )
import GHC.Unit.Module
data AuxBindSpec
= DerivTag2Con
TyCon
RdrName
| DerivMaxTag
TyCon
RdrName
| DerivDataDataType
TyCon
RdrName
[RdrName]
| DerivDataConstr
DataCon
RdrName
RdrName
auxBindSpecRdrName :: AuxBindSpec -> RdrName
auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR
auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR
auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR
auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR
gen_Eq_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Eq_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
, dit_rep_tc_args = tycon_args }) = do
return (method_binds, emptyBag)
where
all_cons = getPossibleDataCons tycon tycon_args
non_nullary_cons = filter (not . isNullarySrcDataCon) all_cons
eq_expr_with_tag_check = nlHsCase
(nlHsPar (untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(nlHsOpApp (nlHsVar ah_RDR) neInt_RDR (nlHsVar bh_RDR))))
[ mkHsCaseAlt (nlLitPat (HsIntPrim NoSourceText 1)) false_Expr
, mkHsCaseAlt nlWildPat (
nlHsCase
(nlHsVar a_RDR)
(let non_nullary_pats = map pats_etc non_nullary_cons
in if null non_nullary_cons
then non_nullary_pats
else non_nullary_pats ++ [mkHsCaseAlt nlWildPat true_Expr]))
]
method_binds = unitBag eq_bind
eq_bind = mkFunBindEC 2 loc eq_RDR (const true_Expr) binds
where
binds
| null all_cons = []
| [data_con] <- all_cons
, (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con
, data_con_RDR <- getRdrName data_con
, con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed
, con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed
, eq_expr <- nested_eq_expr tys_needed as_needed bs_needed
= [([con1_pat, con2_pat], eq_expr)]
| all isNullarySrcDataCon all_cons
= [([a_Pat, b_Pat], untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
| otherwise
= [([a_Pat, b_Pat], eq_expr_with_tag_check)]
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))
gen_con_fields_and_tys data_con
| tys_needed <- derivDataConInstArgTys data_con dit
, con_arity <- length tys_needed
, as_needed <- take con_arity as_RDRs
, bs_needed <- take con_arity bs_RDRs
= (as_needed, bs_needed, tys_needed)
pats_etc data_con
| (as_needed, bs_needed, tys_needed) <- gen_con_fields_and_tys data_con
, data_con_RDR <- getRdrName data_con
, con1_pat <- nlParPat $ nlConVarPat data_con_RDR as_needed
, con2_pat <- nlParPat $ nlConVarPat data_con_RDR bs_needed
, fields_eq_expr <- nested_eq_expr tys_needed as_needed bs_needed
= mkHsCaseAlt con1_pat (nlHsCase (nlHsVar b_RDR) [mkHsCaseAlt con2_pat fields_eq_expr])
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 -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Ord_binds loc dit@(DerivInstTys{ dit_rep_tc = tycon
, dit_rep_tc_args = tycon_args }) = do
return $ if null tycon_data_cons
then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
, emptyBag)
else ( unitBag (mkOrdOp OrdCompare)
`unionBags` other_ops
, aux_binds)
where
aux_binds = emptyBag
other_ops
| (last_tag first_tag) <= 2
|| null non_nullary_cons
= listToBag [mkOrdOp 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 = getPossibleDataCons tycon tycon_args
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 :: OrdOp -> LHsBind GhcPs
mkOrdOp op
= mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]
(mkOrdOpRhs op)
mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
mkOrdOpRhs op
| nullary_cons `lengthAtMost` 2
= nlHsCase (nlHsVar a_RDR) $
map (mkOrdOpAlt op) tycon_data_cons
| null non_nullary_cons
= mkTagCmp op
| otherwise
= nlHsCase (nlHsVar a_RDR) $
(map (mkOrdOpAlt op) non_nullary_cons
++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
mkOrdOpAlt :: OrdOp -> DataCon
-> LMatch GhcPs (LHsExpr GhcPs)
mkOrdOpAlt op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
(mkInnerRhs op data_con)
where
as_needed = take (dataConSourceArity data_con) as_RDRs
data_con_RDR = getRdrName data_con
mkInnerRhs 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 [(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 [(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
= noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag)))
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
mkInnerEqAlt op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
mkCompareFields op (derivDataConInstArgTys data_con dit)
where
data_con_RDR = getRdrName data_con
bs_needed = take (dataConSourceArity data_con) bs_RDRs
mkTagCmp :: OrdOp -> LHsExpr GhcPs
mkTagCmp op =
untag_Expr [(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 = noLocA $ ExprWithTySig noAnn e
$ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType
$ nlHsTyVar NotPromoted boolTyCon_RDR
nlConWildPat :: DataCon -> LPat GhcPs
nlConWildPat con = noLocA $ ConPat
{ pat_con_ext = noAnn
, pat_con = noLocA $ getRdrName con
, pat_args = RecCon $ HsRecFields
{ rec_flds = []
, rec_dotdot = Nothing }
}
gen_Enum_binds :: SrcSpan -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Enum_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
tag2con_RDR <- new_tag2con_rdr_name loc tycon
maxtag_RDR <- new_maxtag_rdr_name loc tycon
return ( method_binds tag2con_RDR maxtag_RDR
, aux_binds tag2con_RDR maxtag_RDR )
where
method_binds tag2con_RDR maxtag_RDR = listToBag
[ succ_enum tag2con_RDR maxtag_RDR
, pred_enum tag2con_RDR
, to_enum tag2con_RDR maxtag_RDR
, enum_from tag2con_RDR maxtag_RDR
, enum_from_then tag2con_RDR maxtag_RDR
, from_enum
]
aux_binds tag2con_RDR maxtag_RDR = listToBag
[ DerivTag2Con tycon tag2con_RDR
, DerivMaxTag tycon maxtag_RDR
]
occ_nm = getOccString tycon
succ_enum tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $
untag_Expr [(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 tag2con_RDR
= mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $
untag_Expr [(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 tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $
untag_Expr [(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 tag2con_RDR maxtag_RDR
= mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
untag_Expr [(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
= mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $
untag_Expr [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
gen_Bounded_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Bounded_binds loc (DerivInstTys{dit_rep_tc = 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 -> DerivInstTys -> TcM (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Ix_binds loc (DerivInstTys{dit_rep_tc = tycon}) = do
tag2con_RDR <- new_tag2con_rdr_name loc tycon
return $ if isEnumerationTyCon tycon
then (enum_ixes tag2con_RDR, listToBag
[ DerivTag2Con tycon tag2con_RDR
])
else (single_con_ixes, emptyBag)
where
enum_ixes tag2con_RDR = listToBag
[ enum_range tag2con_RDR
, enum_index
, enum_inRange
]
enum_range tag2con_RDR
= mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
untag_Expr [(a_RDR, ah_RDR)] $
untag_Expr [(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
= mkSimpleGeneratedFunBind loc unsafeIndex_RDR
[noLocA (AsPat noAnn (noLocA c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
untag_Expr [(a_RDR, ah_RDR)] (
untag_Expr [(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
= mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
untag_Expr [(a_RDR, ah_RDR)] (
untag_Expr [(b_RDR, bh_RDR)] (
untag_Expr [(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] $
noLocA (mkHsComp ListComp stmts con_expr)
where
stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c)
(nlHsApp (nlHsVar range_RDR)
(mkLHsVarTuple [a,b] noAnn))
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] noAnn))
) times_RDR (mk_index rest)
)
mk_one l u i
= nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u] noAnn, 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] noAnn, nlHsVar c]
gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> DerivInstTys
-> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Read_binds get_fixity loc dit@(DerivInstTys{dit_rep_tc = 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 ++ [noLocA $ 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 []] noAnn
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 (derivDataConInstArgTys data_con dit)
(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 ++ [noLocA $ 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 = noLocA (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)) $
noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
read_field lbl a =
[noLocA
(mkPsBindStmt noAnn
(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 -> DerivInstTys
-> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Show_binds get_fixity loc dit@(DerivInstTys{ dit_rep_tc = tycon
, dit_rep_tc_args = tycon_args })
= (unitBag shows_prec, emptyBag)
where
data_cons = getPossibleDataCons tycon tycon_args
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 = derivDataConInstArgTys data_con dit
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 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
-> DerivInstTys
-> TcM (LHsBinds GhcPs,
Bag AuxBindSpec)
gen_Data_binds loc (DerivInstTys{dit_rep_tc = 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
( 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, mkConstrTag_RDR,
mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
constr_RDR, dataType_RDR,
eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR , neInt_RDR ,
eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR ,
eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,
eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR ,
eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR,
eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR,
eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
word8ToWord_RDR , int8ToInt_RDR ,
word16ToWord_RDR, int16ToInt_RDR,
word32ToWord_RDR, int32ToInt_RDR
:: RdrName
gfoldl_RDR = 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")
mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag")
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 "==#")
neInt_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#")
eqInt32_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt32#")
ltInt32_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt32#" )
leInt32_RDR = varQual_RDR gHC_PRIM (fsLit "leInt32#")
gtInt32_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt32#" )
geInt32_RDR = varQual_RDR gHC_PRIM (fsLit "geInt32#")
eqInt64_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt64#")
ltInt64_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt64#" )
leInt64_RDR = varQual_RDR gHC_PRIM (fsLit "leInt64#")
gtInt64_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt64#" )
geInt64_RDR = varQual_RDR gHC_PRIM (fsLit "geInt64#")
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#")
eqWord32_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord32#")
ltWord32_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord32#" )
leWord32_RDR = varQual_RDR gHC_PRIM (fsLit "leWord32#")
gtWord32_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord32#" )
geWord32_RDR = varQual_RDR gHC_PRIM (fsLit "geWord32#")
eqWord64_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord64#")
ltWord64_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord64#" )
leWord64_RDR = varQual_RDR gHC_PRIM (fsLit "leWord64#")
gtWord64_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord64#" )
geWord64_RDR = varQual_RDR gHC_PRIM (fsLit "geWord64#")
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 ">=##")
word8ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word8ToWord#")
int8ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int8ToInt#")
word16ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word16ToWord#")
int16ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int16ToInt#")
word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#")
int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#")
gen_Lift_binds :: SrcSpan -> DerivInstTys -> (LHsBinds GhcPs, Bag AuxBindSpec)
gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
, dit_rep_tc_args = tycon_args }) =
(listToBag [lift_bind, liftTyped_bind], emptyBag)
where
lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
(map (pats_etc mk_untyped_bracket mk_usplice liftName) data_cons)
liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
(map (pats_etc mk_typed_bracket mk_tsplice liftTypedName) data_cons)
mk_untyped_bracket = HsUntypedBracket noAnn . ExpBr noExtField
mk_typed_bracket = HsTypedBracket noAnn
mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice
mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice
data_cons = getPossibleDataCons tycon tycon_args
pats_etc mk_bracket mk_splice lift_name 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 = noLocA (mk_bracket br_body)
br_body = nlHsApps (Exact (dataConName data_con))
(map lift_var as_needed)
lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
lift_var x = noLocA (HsSpliceE EpAnnNotUsed (mk_splice x (nlHsPar (mk_lift_expr x))))
mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)
mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x]
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> (LHsBinds GhcPs, [LSig GhcPs])
gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
= (listToBag binds, sigs)
where
(binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
underlying_inst_tys :: [Type]
underlying_inst_tys = changeLast inst_tys rhs_ty
locn = noAnnSrcSpan loc'
loca = noAnnSrcSpan loc'
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 loca $ ClassOpSig noAnn False [loc_meth_RDR]
$ L loca $ mkHsExplicitSigType noAnn
(map mk_hs_tvb to_tvbs)
(nlHsCoreTy to_rho)
)
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
(_, _, from_tau) = tcSplitSigmaTy from_ty
(to_tvbs, to_rho) = tcSplitForAllInvisTVBinders to_ty
(_, to_tau) = tcSplitPhiTy to_rho
mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn
flag
(noLocA (getRdrName tv))
(nlHsCoreTy (tyVarKind tv))
meth_RDR = getRdrName meth_id
loc_meth_RDR = L locn 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
gen_Newtype_fam_insts :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> TcM [FamInst]
gen_Newtype_fam_insts loc' cls inst_tvs inst_tys rhs_ty
= assert (all (not . isDataFamilyTyCon) ats) $
mapM mk_atf_inst ats
where
underlying_inst_tys :: [Type]
underlying_inst_tys = changeLast inst_tys rhs_ty
ats = classATs cls
locn = noAnnSrcSpan loc'
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
mk_atf_inst :: TyCon -> TcM FamInst
mk_atf_inst fam_tc = do
rep_tc_name <- newFamInstTyConName (L locn (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
fam_tvs = tyConTyVars fam_tc
(_, rep_lhs_tys) = substATBndrs lhs_subst fam_tvs
(_, rep_rhs_tys) = substATBndrs 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
nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty)
where
hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
nlHsCoreTy = noLocA . XHsType
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 loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)]
(genAuxBindSpecSig loc spec)))
where
loca = noAnnSrcSpan loc
locn = noAnnSrcSpan loc
gen_bind :: AuxBindSpec -> LHsBind GhcPs
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
tc_name = tyConName tycon
tc_name_string = occNameString (getOccName tc_name)
definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))
ctx = initDefaultSDocContext dflags
rhs = nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string)))
`nlHsApp` nlList (map nlHsVar dataC_RDRs)
gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
= mkHsVarBind loc dataC_RDR rhs
where
rhs = nlHsApps mkConstrTag_RDR constr_args
constr_args
= [ nlHsVar dataT_RDR
, nlHsLit (mkHsString (occNameString dc_occ))
, nlHsIntLit (toInteger (dataConTag dc))
, 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 loca (TypeSig noAnn [L locn dup_rdr_name]
(genAuxBindSpecSig loc dup_spec)))
where
loca = noAnnSrcSpan loc
locn = noAnnSrcSpan loc
dup_rdr_name = auxBindSpecRdrName dup_spec
genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
genAuxBindSpecSig loc spec = case spec of
DerivTag2Con tycon _
-> mk_sig $ L (noAnnSrcSpan loc) $
XHsType $ mkSpecForAllTys (tyConTyVars tycon) $
intTy `mkVisFunTyMany` mkParentType tycon
DerivMaxTag _ _
-> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))
DerivDataDataType _ _ _
-> mk_sig (nlHsTyVar NotPromoted dataType_RDR)
DerivDataConstr _ _ _
-> mk_sig (nlHsTyVar NotPromoted constr_RDR)
where
mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType
genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec
-> Bag (LHsBind GhcPs, LSig GhcPs)
genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
where
gen_aux_bind_spec :: AuxBindSpec
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
-> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
gen_aux_bind_spec 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 (noAnnSrcSpan loc) fun) matches
where
matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <-pats_and_exprs]
mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches
= L (na2la 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 (noAnnSrcSpan loc) fun) matches
where
matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
(map (parenthesizePat appPrec) p) e
emptyLocalBinds
| (p,e) <- pats_and_exprs ]
mkRdrFunBindEC :: Arity
-> (LHsExpr GhcPs -> LHsExpr GhcPs)
-> LocatedN RdrName
-> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs
mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
= L (na2la 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 [])
emptyLocalBinds]
else matches
mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
= L (na2la loc) (mkFunBind Generated fun matches')
where
matches' = if null matches
then [mkMatch (mkPrefixFunRhs fun)
(replicate arity nlWildPat)
(error_Expr str) 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 ))
,(int32PrimTy , (ltInt32_RDR , leInt32_RDR
, eqInt32_RDR , geInt32_RDR , gtInt32_RDR ))
,(int64PrimTy , (ltInt64_RDR , leInt64_RDR
, eqInt64_RDR , geInt64_RDR , gtInt64_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 ))
,(word32PrimTy, (ltWord32_RDR, leWord32_RDR
, eqWord32_RDR, geWord32_RDR, gtWord32_RDR ))
,(word64PrimTy, (ltWord64_RDR, leWord64_RDR
, eqWord64_RDR, geWord64_RDR, gtWord64_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 int8ToInt_RDR))
, (word8PrimTy,
nlHsApp (nlHsVar $ getRdrName wordDataCon)
. nlHsApp (nlHsVar word8ToWord_RDR))
, (int16PrimTy,
nlHsApp (nlHsVar $ getRdrName intDataCon)
. nlHsApp (nlHsVar int16ToInt_RDR))
, (word16PrimTy,
nlHsApp (nlHsVar $ getRdrName wordDataCon)
. nlHsApp (nlHsVar word16ToWord_RDR))
, (int32PrimTy,
nlHsApp (nlHsVar $ getRdrName intDataCon)
. nlHsApp (nlHsVar int32ToInt_RDR))
, (word32PrimTy,
nlHsApp (nlHsVar $ getRdrName wordDataCon)
. nlHsApp (nlHsVar word32ToWord_RDR))
]
postfixModTbl :: [(Type, String)]
postfixModTbl
= [(charPrimTy , "#" )
,(intPrimTy , "#" )
,(wordPrimTy , "##")
,(floatPrimTy , "#" )
,(doublePrimTy, "##")
,(int8PrimTy, "#")
,(word8PrimTy, "##")
,(int16PrimTy, "#")
,(word16PrimTy, "##")
,(int32PrimTy, "#")
,(word32PrimTy, "##")
]
primConvTbl :: [(Type, String)]
primConvTbl =
[ (int8PrimTy, "intToInt8#")
, (word8PrimTy, "wordToWord8#")
, (int16PrimTy, "intToInt16#")
, (word16PrimTy, "wordToWord16#")
, (int32PrimTy, "intToInt32#")
, (word32PrimTy, "wordToWord32#")
]
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)]
-> LHsExpr GhcPs -> LHsExpr GhcPs
untag_Expr [] expr = expr
untag_Expr ((untag_this, put_tag_here) : more) expr
= nlHsCase (nlHsPar (nlHsVarApps dataToTag_RDR [untag_this]))
[mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr 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_tag2con_rdr_name, new_maxtag_rdr_name
:: SrcSpan -> TyCon -> TcM RdrName
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
getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon
where
isPossible dc = not $ dataConCannotMatch (dataConInstUnivs dc tycon_args) dc
data DerivInstTys = DerivInstTys
{ dit_cls_tys :: [Type]
, dit_tc :: TyCon
, dit_tc_args :: [Type]
, dit_rep_tc :: TyCon
, dit_rep_tc_args :: [Type]
, dit_dc_inst_arg_env :: DataConEnv [Type]
}
instance Outputable DerivInstTys where
ppr (DerivInstTys { dit_cls_tys = cls_tys, dit_tc = tc, dit_tc_args = tc_args
, dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args
, dit_dc_inst_arg_env = dc_inst_arg_env })
= hang (text "DerivInstTys")
2 (vcat [ text "dit_cls_tys" <+> ppr cls_tys
, text "dit_tc" <+> ppr tc
, text "dit_tc_args" <+> ppr tc_args
, text "dit_rep_tc" <+> ppr rep_tc
, text "dit_rep_tc_args" <+> ppr rep_tc_args
, text "dit_dc_inst_arg_env" <+> ppr dc_inst_arg_env ])
derivDataConInstArgTys :: DataCon -> DerivInstTys -> [Type]
derivDataConInstArgTys dc dit =
case lookupUFM (dit_dc_inst_arg_env dit) dc of
Just inst_arg_tys -> inst_arg_tys
Nothing -> pprPanic "derivDataConInstArgTys" (ppr dc)
buildDataConInstArgEnv :: TyCon -> [Type] -> DataConEnv [Type]
buildDataConInstArgEnv rep_tc rep_tc_args =
listToUFM [ (dc, inst_arg_tys)
| dc <- tyConDataCons rep_tc
, let (_, _, inst_arg_tys) =
dataConInstSig dc $ dataConInstUnivs dc rep_tc_args
]
substDerivInstTys :: TCvSubst -> DerivInstTys -> DerivInstTys
substDerivInstTys subst
dit@(DerivInstTys { dit_cls_tys = cls_tys, dit_tc_args = tc_args
, dit_rep_tc = rep_tc, dit_rep_tc_args = rep_tc_args })
| isEmptyTCvSubst subst
= dit
| otherwise
= dit{ dit_cls_tys = cls_tys'
, dit_tc_args = tc_args'
, dit_rep_tc_args = rep_tc_args'
, dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'
}
where
cls_tys' = substTys subst cls_tys
tc_args' = substTys subst tc_args
rep_tc_args' = substTys subst rep_tc_args
zonkDerivInstTys :: ZonkEnv -> DerivInstTys -> TcM DerivInstTys
zonkDerivInstTys ze dit@(DerivInstTys { dit_cls_tys = cls_tys
, dit_tc_args = tc_args
, dit_rep_tc = rep_tc
, dit_rep_tc_args = rep_tc_args }) = do
cls_tys' <- zonkTcTypesToTypesX ze cls_tys
tc_args' <- zonkTcTypesToTypesX ze tc_args
rep_tc_args' <- zonkTcTypesToTypesX ze rep_tc_args
pure dit{ dit_cls_tys = cls_tys'
, dit_tc_args = tc_args'
, dit_rep_tc_args = rep_tc_args'
, dit_dc_inst_arg_env = buildDataConInstArgEnv rep_tc rep_tc_args'
}