module TcGenDeriv (
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, error_Expr
) where
#include "HsVersions.h"
import TcRnMonad
import HsSyn
import RdrName
import BasicTypes
import DataCon
import Name
import Fingerprint
import Encoding
import DynFlags
import PrelInfo
import FamInst
import FamInstEnv
import PrelNames
import THNames
import Module ( moduleName, moduleNameString
, moduleUnitId, unitIdString )
import MkId ( coerceId )
import PrimOp
import SrcLoc
import TyCon
import TcEnv
import TcType
import TcValidity ( checkValidTyFamEqn )
import TysPrim
import TysWiredIn
import Type
import Class
import VarSet
import VarEnv
import Util
import Var
import Outputable
import Lexeme
import FastString
import Pair
import Bag
import Data.List ( partition, intersperse )
type BagDerivStuff = Bag DerivStuff
data AuxBindSpec
= DerivCon2Tag TyCon
| DerivTag2Con TyCon
| DerivMaxTag TyCon
deriving( Eq )
data DerivStuff
= DerivAuxBind AuxBindSpec
| DerivFamInst FamInst
| DerivHsBind (LHsBind RdrName, LSig RdrName)
gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
gen_Eq_binds loc tycon = do
dflags <- getDynFlags
return (method_binds dflags, aux_binds)
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 dflags
| no_tag_match_cons
= case pat_match_cons of
[] -> []
[_] -> []
_ ->
[([nlWildPat, nlWildPat], false_Expr)]
| otherwise
= [([a_Pat, b_Pat],
untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
aux_binds | no_tag_match_cons = emptyBag
| otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
method_binds dflags = listToBag
[ eq_bind dflags
, ne_bind
]
eq_bind dflags = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons
++ fall_through_eqn dflags)
ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_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 tys_needed as_needed bs_needed)
where
nested_eq_expr [] [] [] = true_Expr
nested_eq_expr tys as bs
= foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
where
nested_eq ty a b = nlHsPar (eq_Expr tycon 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 RdrName
ltResult OrdCompare = ltTag_Expr
ltResult OrdLT = true_Expr
ltResult OrdLE = true_Expr
ltResult OrdGE = false_Expr
ltResult OrdGT = false_Expr
eqResult :: OrdOp -> LHsExpr RdrName
eqResult OrdCompare = eqTag_Expr
eqResult OrdLT = false_Expr
eqResult OrdLE = true_Expr
eqResult OrdGE = true_Expr
eqResult OrdGT = false_Expr
gtResult :: OrdOp -> LHsExpr RdrName
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 RdrName, BagDerivStuff)
gen_Ord_binds loc tycon = do
dflags <- getDynFlags
return $ if null tycon_data_cons
then ( unitBag $ mk_FunBind loc compare_RDR []
, emptyBag)
else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags
, aux_binds)
where
aux_binds | single_con_type = emptyBag
| otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
other_ops dflags
| (last_tag first_tag) <= 2
|| null non_nullary_cons
= listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]
| otherwise
= emptyBag
negate_expr = nlHsApp (nlHsVar not_RDR)
lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $
negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $
nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
gE = mk_easy_FunBind 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 :: DynFlags -> OrdOp -> LHsBind RdrName
mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]
(mkOrdOpRhs dflags op)
mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr RdrName
mkOrdOpRhs dflags op
| length nullary_cons <= 2
= nlHsCase (nlHsVar a_RDR) $
map (mkOrdOpAlt dflags op) tycon_data_cons
| null non_nullary_cons
= mkTagCmp dflags op
| otherwise
= nlHsCase (nlHsVar a_RDR) $
(map (mkOrdOpAlt dflags op) non_nullary_cons
++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])
mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon
-> LMatch RdrName (LHsExpr RdrName)
mkOrdOpAlt dflags op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
(mkInnerRhs dflags op data_con)
where
as_needed = take (dataConSourceArity data_con) as_RDRs
data_con_RDR = getRdrName data_con
mkInnerRhs dflags 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 dflags tycon [(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 dflags tycon [(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 (HsIntPrim NoSourceText (toInteger tag)))
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
mkInnerEqAlt op data_con
= mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
mkCompareFields tycon op (dataConOrigArgTys data_con)
where
data_con_RDR = getRdrName data_con
bs_needed = take (dataConSourceArity data_con) bs_RDRs
mkTagCmp :: DynFlags -> OrdOp -> LHsExpr RdrName
mkTagCmp dflags op =
untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
mkCompareFields tycon op tys
= go tys as_RDRs bs_RDRs
where
go [] _ _ = eqResult op
go [ty] (a:_) (b:_)
| isUnliftedType ty = unliftedOrdOp tycon 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" tycon ty
unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
unliftedOrdOp tycon 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" tycon ty
wrap prim_op = genPrimOpApp a_expr prim_op b_expr
a_expr = nlHsVar a
b_expr = nlHsVar b
unliftedCompare :: RdrName -> RdrName
-> LHsExpr RdrName -> LHsExpr RdrName
-> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
-> LHsExpr RdrName
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 boolTy
nlConWildPat :: DataCon -> LPat RdrName
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(RecCon (HsRecFields { rec_flds = []
, rec_dotdot = Nothing })))
gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
gen_Enum_binds loc tycon = do
dflags <- getDynFlags
return (method_binds dflags, aux_binds)
where
method_binds dflags = listToBag
[ succ_enum dflags
, pred_enum dflags
, to_enum dflags
, enum_from dflags
, enum_from_then dflags
, from_enum dflags
]
aux_binds = listToBag $ map DerivAuxBind
[DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
occ_nm = getOccString tycon
succ_enum dflags
= mk_easy_FunBind loc succ_RDR [a_Pat] $
untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),
nlHsVarApps intDataCon_RDR [ah_RDR]])
(illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
(nlHsApp (nlHsVar (tag2con_RDR dflags tycon))
(nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsIntLit 1]))
pred_enum dflags
= mk_easy_FunBind loc pred_RDR [a_Pat] $
untag_Expr dflags tycon [(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 dflags tycon))
(nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsLit (HsInt NoSourceText (1))]))
to_enum dflags
= mk_easy_FunBind 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 dflags tycon)]])
(nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])
(illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))
enum_from dflags
= mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
nlHsApps map_RDR
[nlHsVar (tag2con_RDR dflags tycon),
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVar (maxtag_RDR dflags tycon)))]
enum_from_then dflags
= mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
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 dflags tycon))
))
from_enum dflags
= mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
(nlHsVarApps intDataCon_RDR [ah_RDR])
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, 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 (nOfThem arity minBound_RDR)
max_bound_1con = mkHsVarBind loc maxBound_RDR $
nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds RdrName, BagDerivStuff)
gen_Ix_binds loc tycon = do
dflags <- getDynFlags
return $ if isEnumerationTyCon tycon
then (enum_ixes dflags, listToBag $ map DerivAuxBind
[DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
where
enum_ixes dflags = listToBag
[ enum_range dflags
, enum_index dflags
, enum_inRange dflags
]
enum_range dflags
= mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
untag_Expr dflags tycon [(a_RDR, ah_RDR)] $
untag_Expr dflags tycon [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR]))
enum_index dflags
= mk_easy_FunBind loc unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
untag_Expr dflags tycon [(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 dflags
= mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
untag_Expr dflags tycon [(a_RDR, ah_RDR)] (
untag_Expr dflags tycon [(b_RDR, bh_RDR)] (
untag_Expr dflags tycon [(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
= mk_easy_FunBind 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 $ mkBindStmt (nlVarPat c)
(nlHsApp (nlHsVar range_RDR)
(mkLHsVarTuple [a,b]))
single_con_index
= mk_easy_FunBind 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
= mk_easy_FunBind 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 RdrName, 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
(nlHsApp (nlHsVar parens_RDR) read_cons)
read_cons | null data_cons = nlHsVar pfail_RDR
| otherwise = 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 (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 = length labels > 0
as_needed = take con_arity as_RDRs
read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (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 (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 (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
read_field lbl a = read_lbl lbl ++
[read_punc "=",
noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
read_lbl lbl | isSym lbl_str
= [read_punc "(", symbol_pat lbl_str, read_punc ")"]
| otherwise
= ident_h_pat lbl_str
where
lbl_str = unpackFS lbl
gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Show_binds get_fixity loc tycon
= (listToBag [shows_prec, show_list], emptyBag)
where
show_list = mkHsVarBind loc showList_RDR
(nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
data_cons = tyConDataCons tycon
shows_prec = mk_FunBind loc showsPrec_RDR (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 NoSourceText 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 = zipWith 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 RdrName
show_arg b arg_ty
| isUnliftedType arg_ty
= 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" tycon arg arg_ty
postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
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 RdrName
mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
mk_showsPrec_app p x
= nlHsApps showsPrec_RDR [nlHsLit (HsInt NoSourceText p), x]
mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
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 RdrName,
BagDerivStuff)
gen_Data_binds loc rep_tc
= do { dflags <- getDynFlags
; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
(tyConDataCons rep_tc)
; let dt_rdr = mkRdrUnqual dt_occ
dc_rdrs = map mkRdrUnqual dc_occs
; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
gen_data :: DynFlags -> RdrName -> [RdrName]
-> SrcSpan -> TyCon
-> (LHsBinds RdrName,
BagDerivStuff)
gen_data dflags data_type_name constr_names loc rep_tc
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
`unionBags` gcast_binds,
listToBag ( genDataTyCon
: zipWith genDataDataCon data_cons constr_names ) )
where
data_cons = tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
genDataTyCon :: DerivStuff
genDataTyCon
= DerivHsBind (mkHsVarBind loc data_type_name rhs,
L loc (TypeSig [L loc data_type_name] sig_ty))
sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
rhs = nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
`nlHsApp` nlList (map nlHsVar constr_names)
genDataDataCon :: DataCon -> RdrName -> DerivStuff
genDataDataCon dc constr_name
= DerivHsBind (mkHsVarBind loc constr_name rhs,
L loc (TypeSig [L loc constr_name] sig_ty))
where
sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
rhs = nlHsApps mkConstr_RDR constr_args
constr_args
= [
nlHsVar (data_type_name)
, 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
gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
gfoldl_eqn con
= ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) 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 = mk_HRFunBind 2 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
(nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
(replicate (dataConSourceArity dc) (nlHsVar k_RDR))
mk_unfold_pat dc
| tagfIRST_TAG == n_cons1 = nlWildPat
| otherwise = nlConPat intDataCon_RDR
[nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
where
tag = dataConTag dc
toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names)
to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
dataTypeOf_bind = mk_easy_FunBind
loc
dataTypeOf_RDR
[nlWildPat]
(nlHsVar data_type_name)
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 (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
(nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
kind1, kind2 :: Kind
kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
kind2 = liftedTypeKind `mkFunTy` 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 ,
eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_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 :: 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 ">=#")
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#")
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 ">=##")
gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Lift_binds loc tycon
| null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
[mkMatch (mkPrefixFunRhs (L loc lift_RDR))
[nlWildPat] errorMsg_Expr
(noLoc emptyLocalBinds)])
, emptyBag)
| otherwise = (unitBag lift_bind, emptyBag)
where
errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
(mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
data_cons = tyConDataCons tycon
tycon_str = occNameString . nameOccName . tyConName $ tycon
pats_etc 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
lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
tys_needed as_needed
tycon_name = tyConName tycon
is_infix = dataConIsInfix data_con
tys_needed = dataConOrigArgTys data_con
mk_lift_app ty a
| not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
(nlHsVar a)
| otherwise = nlHsApp (nlHsVar litE_RDR)
(primLitOp (mkBoxExp (nlHsVar a)))
where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
pkg_name = unitIdString . moduleUnitId
. nameModule $ tycon_name
mod_name = moduleNameString . moduleName . nameModule $ tycon_name
con_name = occNameString . nameOccName . dataConName $ data_con
conE_Expr = nlHsApp (nlHsVar conE_RDR)
(nlHsApps mkNameG_dRDR
(map (nlHsLit . mkHsString)
[pkg_name, mod_name, con_name]))
lift_Expr
| is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
| otherwise = foldl mk_appE_app conE_Expr lifted_as
(a1:a2:_) = lifted_as
mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
mk_appE_app a b = nlHsApps appE_RDR [a, b]
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> TcM (LHsBinds RdrName, BagDerivStuff)
gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty
= do let ats = classATs cls
atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )
mapM mk_atf_inst ats
return ( listToBag $ map mk_bind (classMethods cls)
, listToBag $ map DerivFamInst atf_insts )
where
coerce_RDR = getRdrName coerceId
mk_bind :: Id -> LHsBind RdrName
mk_bind meth_id
= mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
(mkPrefixFunRhs (L loc meth_RDR))
[] rhs_expr]
where
Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
meth_RDR = getRdrName meth_id
rhs_expr = nlHsVar coerce_RDR `nlHsAppType` from_ty
`nlHsAppType` to_ty
`nlHsApp` nlHsVar meth_RDR
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
checkValidTyFamEqn (Just (cls, cls_tvs, lhs_env)) fam_tc rep_tvs'
rep_cvs' rep_lhs_tys rep_rhs_ty loc
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 $ changeLast inst_tys rhs_ty
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' = toposortTyVars rep_tvs
rep_cvs' = toposortTyVars rep_cvs
nlHsAppType :: LHsExpr RdrName -> Type -> LHsExpr RdrName
nlHsAppType e s = noLoc (e `HsAppType` hs_ty)
where
hs_ty = mkHsWildCardBndrs $ nlHsParTy (typeToLHsType s)
nlExprWithTySig :: LHsExpr RdrName -> Type -> LHsExpr RdrName
nlExprWithTySig e s = noLoc (e `ExprWithTySig` hs_ty)
where
hs_ty = mkLHsSigWcType (typeToLHsType s)
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)
genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec
-> (LHsBind RdrName, LSig RdrName)
genAuxBindSpec dflags loc (DerivCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns,
L loc (TypeSig [L loc rdr_name] sig_ty))
where
rdr_name = con2tag_RDR dflags tycon
sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
mkParentType tycon `mkFunTy` intPrimTy
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 RdrName], LHsExpr RdrName)
mk_eqn con = ([nlWildConPat con],
nlHsLit (HsIntPrim NoSourceText
(toInteger ((dataConTag con) fIRST_TAG))))
genAuxBindSpec dflags loc (DerivTag2Con tycon)
= (mk_FunBind loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
L loc (TypeSig [L loc rdr_name] sig_ty))
where
sig_ty = mkLHsSigWcType $ L loc $
HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
intTy `mkFunTy` mkParentType tycon
rdr_name = tag2con_RDR dflags tycon
genAuxBindSpec dflags loc (DerivMaxTag tycon)
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] sig_ty))
where
rdr_name = maxtag_RDR dflags tycon
sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
rhs = nlHsApp (nlHsVar intDataCon_RDR)
(nlHsLit (HsIntPrim NoSourceText max_tag))
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) fIRST_TAG)
type SeparateBagsDerivStuff =
( Bag (LHsBind RdrName, LSig RdrName)
, Bag (FamInst) )
genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds dflags loc b = genAuxBinds' b2 where
(b1,b2) = partitionBagWith splitDerivAuxBind b
splitDerivAuxBind (DerivAuxBind x) = Left x
splitDerivAuxBind x = Right x
rm_dups = foldrBag dup_check emptyBag
dup_check a b = if anyBag (== a) b then b else consBag a b
genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)
, emptyBag )
f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
f (DerivAuxBind _) = panic "genAuxBinds'"
f (DerivHsBind b) = add1 b
f (DerivFamInst t) = add2 t
add1 x (a,b) = (x `consBag` a,b)
add2 x (a,b) = (a,x `consBag` b)
mkParentType :: TyCon -> Type
mkParentType tc
= case tyConFamInst_maybe tc of
Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
Just (fam_tc,tys) -> mkTyConApp fam_tc tys
mk_FunBind :: SrcSpan -> RdrName
-> [([LPat RdrName], LHsExpr RdrName)]
-> LHsBind RdrName
mk_FunBind = mk_HRFunBind 0
mk_HRFunBind :: Arity -> SrcSpan -> RdrName
-> [([LPat RdrName], LHsExpr RdrName)]
-> LHsBind RdrName
mk_HRFunBind arity loc fun pats_and_exprs
= mkHRRdrFunBind arity (L loc fun) matches
where
matches = [mkMatch (mkPrefixFunRhs (L loc fun)) p e
(noLoc emptyLocalBinds)
| (p,e) <-pats_and_exprs]
mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
mkRdrFunBind = mkHRRdrFunBind 0
mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind 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
-> TyCon
-> LHsExpr RdrName
-> Type
-> LHsExpr RdrName
box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
where
box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
primOrdOps :: String
-> TyCon
-> Type
-> (RdrName, RdrName, RdrName, RdrName, RdrName)
primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
primLitOps :: String
-> TyCon
-> Type
-> ( LHsExpr RdrName -> LHsExpr RdrName
, LHsExpr RdrName -> LHsExpr RdrName
)
primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
, \v -> nlHsVar boxRDR `nlHsApp` v
)
where
boxRDR
| ty `eqType` addrPrimTy = unpackCString_RDR
| otherwise = assoc_ty_id str tycon boxConTbl 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 ))
,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_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, RdrName)]
boxConTbl
= [(charPrimTy , getRdrName charDataCon )
,(intPrimTy , getRdrName intDataCon )
,(wordPrimTy , getRdrName wordDataCon )
,(floatPrimTy , getRdrName floatDataCon )
,(doublePrimTy, getRdrName doubleDataCon)
]
postfixModTbl :: [(Type, String)]
postfixModTbl
= [(charPrimTy , "#" )
,(intPrimTy , "#" )
,(wordPrimTy , "##")
,(floatPrimTy , "#" )
,(doublePrimTy, "##")
]
litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
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 :: String
-> TyCon
-> [(Type,a)]
-> Type
-> a
assoc_ty_id cls_str _ tbl ty
| null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
text "for primitive type" <+> ppr ty)
| otherwise = head res
where
res = [id | (ty',id) <- tbl, ty `eqType` ty']
and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
and_Expr a b = genOpApp a and_RDR b
eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
eq_Expr tycon ty a b
| not (isUnliftedType ty) = genOpApp a eq_RDR b
| otherwise = genPrimOpApp a prim_eq b
where
(_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
untag_Expr :: DynFlags -> TyCon -> [( RdrName, RdrName)]
-> LHsExpr RdrName -> LHsExpr RdrName
untag_Expr _ _ [] expr = expr
untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr
= nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)
[untag_this]))
[mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]
enum_from_to_Expr
:: LHsExpr RdrName -> LHsExpr RdrName
-> LHsExpr RdrName
enum_from_then_to_Expr
:: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
-> LHsExpr RdrName
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 RdrName -> LHsExpr RdrName
-> LHsExpr RdrName
showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
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 RdrName
error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
illegal_Expr :: String -> String -> String -> LHsExpr RdrName
illegal_Expr meth tp msg =
nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
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 RdrName -> LHsExpr RdrName
parenify e@(L _ (HsVar _)) = e
parenify e = mkHsPar e
genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
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, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
true_Expr :: LHsExpr RdrName
a_Expr = nlHsVar a_RDR
b_Expr = nlHsVar b_RDR
c_Expr = nlHsVar c_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
a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat RdrName
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)
con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName
con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc
tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc
maxtag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc
mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName
mk_tc_deriv_name dflags tycon occ_fun =
mkAuxBinderName dflags (tyConName tycon) occ_fun
mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName
mkAuxBinderName dflags parent occ_fun
= mkRdrUnqual (occ_fun stable_parent_occ)
where
stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
stable_string
| hasPprDebug dflags = parent_stable
| otherwise = parent_stable_hash
parent_stable = nameStableString parent
parent_stable_hash =
let Fingerprint high low = fingerprintString parent_stable
in toBase62 high ++ toBase62Padded low
parent_occ = nameOccName parent