module TcGenDeriv (
BagDerivStuff, DerivStuff(..),
canDeriveAnyClass,
genDerivedBinds,
FFoldType(..), functorLikeTraverse,
deepSubtypesContaining, foldDataConArgs,
mkCoerceClassMethEqn,
gen_Newtype_binds,
genAuxBinds,
ordOpTbl, boxConTbl,
mkRdrFunBind
) where
#include "HsVersions.h"
import HsSyn
import RdrName
import BasicTypes
import DataCon
import Name
import DynFlags
import PrelInfo
import FamInstEnv( FamInst )
import MkCore ( eRROR_ID )
import PrelNames hiding (error_RDR)
import MkId ( coerceId )
import PrimOp
import SrcLoc
import TyCon
import TcType
import TysPrim
import TysWiredIn
import Type
import Class
import TypeRep
import VarSet
import VarEnv
import State
import Util
import Var
#if __GLASGOW_HASKELL__ < 709
import MonadUtils
#endif
import Outputable
import Lexeme
import FastString
import Pair
import Bag
import TcEnv (InstInfo)
import StaticFlags( opt_PprStyle_Debug )
import ListSetOps ( assocMaybe )
import Data.List ( partition, intersperse )
import Data.Maybe ( isNothing )
type BagDerivStuff = Bag DerivStuff
data AuxBindSpec
= DerivCon2Tag TyCon
| DerivTag2Con TyCon
| DerivMaxTag TyCon
deriving( Eq )
data DerivStuff
= DerivAuxBind AuxBindSpec
| DerivTyCon TyCon
| DerivFamInst FamInst
| DerivHsBind (LHsBind RdrName, LSig RdrName)
| DerivInst (InstInfo RdrName)
genDerivedBinds :: DynFlags -> (Name -> Fixity) -> Class -> SrcSpan -> TyCon
-> (LHsBinds RdrName, BagDerivStuff)
genDerivedBinds dflags fix_env clas loc tycon
| Just gen_fn <- assocMaybe gen_list (getUnique clas)
= gen_fn loc tycon
| otherwise
= ASSERT2( isNothing (canDeriveAnyClass dflags tycon clas)
, ppr "genDerivStuff: bad derived class" <+> ppr clas )
(emptyBag, emptyBag)
where
gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
gen_list = [ (eqClassKey, gen_Eq_binds)
, (ordClassKey, gen_Ord_binds)
, (enumClassKey, gen_Enum_binds)
, (boundedClassKey, gen_Bounded_binds)
, (ixClassKey, gen_Ix_binds)
, (showClassKey, gen_Show_binds fix_env)
, (readClassKey, gen_Read_binds fix_env)
, (dataClassKey, gen_Data_binds dflags)
, (functorClassKey, gen_Functor_binds)
, (foldableClassKey, gen_Foldable_binds)
, (traversableClassKey, gen_Traversable_binds) ]
canDeriveAnyClass :: DynFlags -> TyCon -> Class -> Maybe SDoc
canDeriveAnyClass dflags _tycon clas =
let b `orElse` s = if b then Nothing else Just (ptext (sLit s))
Just m <> _ = Just m
Nothing <> n = n
in
(not (getUnique clas `elem` standardClassKeys) `orElse` "")
<> (xopt Opt_DeriveAnyClass dflags `orElse` "Try enabling DeriveAnyClass")
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Eq_binds loc tycon
= (method_binds, 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
| no_tag_match_cons
= case pat_match_cons of
[] -> []
[_] -> []
_ ->
[([nlWildPat, nlWildPat], false_Expr)]
| otherwise
= [([a_Pat, b_Pat],
untag_Expr 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 = listToBag [eq_bind, ne_bind]
eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
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 = nlConVarPat data_con_RDR as_needed
con2_pat = 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 -> (LHsBinds RdrName, BagDerivStuff)
gen_Ord_binds loc tycon
| null tycon_data_cons
= (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
| otherwise
= (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
where
aux_binds | single_con_type = emptyBag
| otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
other_ops | (last_tag first_tag) <= 2
|| null non_nullary_cons
= listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
| otherwise
= emptyBag
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 :: OrdOp -> LHsBind RdrName
mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
mkOrdOpRhs op
| length nullary_cons <= 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
++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
mkOrdOpAlt op data_con
= mkSimpleHsAlt (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
, mkSimpleHsAlt nlWildPat (ltResult op) ]
| tag == last_tag
= nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkSimpleHsAlt nlWildPat (gtResult op) ]
| tag == first_tag + 1
= nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
, mkInnerEqAlt op data_con
, mkSimpleHsAlt nlWildPat (ltResult op) ]
| tag == last_tag 1
= nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
, mkInnerEqAlt op data_con
, mkSimpleHsAlt nlWildPat (gtResult op) ]
| tag > last_tag `div` 2
= untag_Expr tycon [(b_RDR, bh_RDR)] $
nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
(gtResult op) $
nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkSimpleHsAlt nlWildPat (ltResult op) ]
| otherwise
= untag_Expr tycon [(b_RDR, bh_RDR)] $
nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
(ltResult op) $
nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
, mkSimpleHsAlt nlWildPat (gtResult op) ]
where
tag = get_tag data_con
tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
mkInnerEqAlt op data_con
= mkSimpleHsAlt (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 :: OrdOp -> LHsExpr RdrName
mkTagCmp op = untag_Expr 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))
[mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
mkSimpleHsAlt (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 (genPrimOpApp a_expr lt_op b_expr) lt $
nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
nlConWildPat :: DataCon -> LPat RdrName
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(RecCon (HsRecFields { rec_flds = []
, rec_dotdot = Nothing })))
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Enum_binds loc tycon
= (method_binds, aux_binds)
where
method_binds = listToBag [
succ_enum,
pred_enum,
to_enum,
enum_from,
enum_from_then,
from_enum
]
aux_binds = listToBag $ map DerivAuxBind
[DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
occ_nm = getOccString tycon
succ_enum
= mk_easy_FunBind loc succ_RDR [a_Pat] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
nlHsVarApps intDataCon_RDR [ah_RDR]])
(illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
(nlHsApp (nlHsVar (tag2con_RDR tycon))
(nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsIntLit 1]))
pred_enum
= mk_easy_FunBind loc pred_RDR [a_Pat] $
untag_Expr 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 tycon))
(nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
nlHsLit (HsInt "-1" (1))]))
to_enum
= 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 tycon)]])
(nlHsVarApps (tag2con_RDR tycon) [a_RDR])
(illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
enum_from
= mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
nlHsApps map_RDR
[nlHsVar (tag2con_RDR tycon),
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVar (maxtag_RDR tycon)))]
enum_from_then
= mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR 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 tycon))
))
from_enum
= mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
untag_Expr 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 -> (LHsBinds RdrName, BagDerivStuff)
gen_Ix_binds loc tycon
| isEnumerationTyCon tycon
= ( enum_ixes
, listToBag $ map DerivAuxBind
[DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
| otherwise
= (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
where
enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
enum_range
= mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
untag_Expr tycon [(a_RDR, ah_RDR)] $
untag_Expr tycon [(b_RDR, bh_RDR)] $
nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
nlHsPar (enum_from_to_Expr
(nlHsVarApps intDataCon_RDR [ah_RDR])
(nlHsVarApps intDataCon_RDR [bh_RDR]))
enum_index
= mk_easy_FunBind loc unsafeIndex_RDR
[noLoc (AsPat (noLoc c_RDR)
(nlTuplePat [a_Pat, nlWildPat] Boxed)),
d_Pat] (
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(d_RDR, dh_RDR)] (
let
rhs = nlHsVarApps intDataCon_RDR [c_RDR]
in
nlHsCase
(genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
[mkSimpleHsAlt (nlVarPat c_RDR) rhs]
))
)
enum_inRange
= mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
untag_Expr tycon [(a_RDR, ah_RDR)] (
untag_Expr tycon [(b_RDR, bh_RDR)] (
untag_Expr tycon [(c_RDR, ch_RDR)] (
nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
(genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
) (
false_Expr
))))
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] $
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 = 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 = occNameString (getOccName 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)
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 (nlHsPar (genOpApp a_Expr ge_RDR
(nlHsLit (HsInt "" 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 = 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
occ_nm = getOccName l
nm = wrapOpParens (occNameString occ_nm)
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 [mk_showString_app ", "] $
[ [show_label lbl, arg]
| (lbl,arg) <- zipEqual "gen_Show_binds"
labels show_args ]
show_arg b arg_ty = nlHsApps showsPrec_RDR
[nlHsLit (HsInt "" arg_prec),
box_if_necy "Show" tycon (nlHsVar b) 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))
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 :: DynFlags
-> SrcSpan
-> TyCon
-> (LHsBinds RdrName,
BagDerivStuff)
gen_Data_binds dflags loc rep_tc
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
`unionBags` gcast_binds,
listToBag ( DerivHsBind (genDataTyCon)
: map (DerivHsBind . genDataDataCon) data_cons))
where
data_cons = tyConDataCons rep_tc
n_cons = length data_cons
one_constr = n_cons == 1
genDataTyCon :: (LHsBind RdrName, LSig RdrName)
genDataTyCon
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
where
rdr_name = mk_data_type_name rep_tc
sig_ty = nlHsTyVar dataType_RDR
constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
rhs = nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
`nlHsApp` nlList constrs
genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
genDataDataCon dc
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
where
rdr_name = mk_constr_name dc
sig_ty = nlHsTyVar constr_RDR
rhs = nlHsApps mkConstr_RDR constr_args
constr_args
= [
nlHsVar (mk_data_type_name (dataConTyCon dc)),
nlHsLit (mkHsString (occNameString dc_occ)),
nlList labels,
nlHsVar fixity]
labels = map (nlHsLit . mkHsString . getOccString)
(dataConFieldLabels dc)
dc_occ = getOccName dc
is_infix = isDataSymOcc dc_occ
fixity | is_infix = infix_RDR
| otherwise = prefix_RDR
gfoldl_bind = mk_FunBind 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_FunBind 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 = mkSimpleHsAlt (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 "" (toInteger tag))]
where
tag = dataConTag dc
toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
dataTypeOf_bind = mk_easy_FunBind
loc
dataTypeOf_RDR
[nlWildPat]
(nlHsVar (mk_data_type_name rep_tc))
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 `mkArrowKind` liftedTypeKind
kind2 = liftedTypeKind `mkArrowKind` 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_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Functor_binds loc tycon
= (unitBag fmap_bind, emptyBag)
where
data_cons = tyConDataCons tycon
fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns
fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
where
parts = sequence $ foldDataConArgs ft_fmap con
eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
(error_Expr "Void fmap")]
| otherwise = map fmap_eqn data_cons
ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
, ft_var = return f_Expr
, ft_fun = \g h -> do
gg <- g
hh <- h
mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
, ft_tup = \t gs -> do
gg <- sequence gs
mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
, ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
, ft_forall = \_ g -> g
, ft_bad_app = panic "in other argument"
, ft_co_var = panic "contravariant" }
match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
-> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
match_for_con = mkSimpleConMatch $
\con_name xs -> return $ nlHsApps con_name xs
data FFoldType a
= FT { ft_triv :: a
, ft_var :: a
, ft_co_var :: a
, ft_fun :: a -> a -> a
, ft_tup :: TupleSort -> [a] -> a
, ft_ty_app :: Type -> a -> a
, ft_bad_app :: a
, ft_forall :: TcTyVar -> a -> a
}
functorLikeTraverse :: forall a.
TyVar
-> FFoldType a
-> Type
-> a
functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
, ft_co_var = caseCoVar, ft_fun = caseFun
, ft_tup = caseTuple, ft_ty_app = caseTyApp
, ft_bad_app = caseWrongArg, ft_forall = caseForAll })
ty
= fst (go False ty)
where
go :: Bool
-> Type
-> (a, Bool)
go co ty | Just ty' <- coreView ty = go co ty'
go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
go co (FunTy x y) | isPredTy x = go co y
| xc || yc = (caseFun xr yr,True)
where (xr,xc) = go (not co) x
(yr,yc) = go co y
go co (AppTy x y) | xc = (caseWrongArg, True)
| yc = (caseTyApp x yr, True)
where (_, xc) = go co x
(yr,yc) = go co y
go co ty@(TyConApp con args)
| not (or xcs) = (caseTrivial, False)
| isTupleTyCon con = (caseTuple (tupleTyConSort con) xrs, True)
| or (init xcs) = (caseWrongArg, True)
| otherwise = case splitAppTy_maybe ty of
Nothing -> (caseWrongArg, True)
Just (fun_ty, _) -> (caseTyApp fun_ty (last xrs), True)
where
(xrs,xcs) = unzip (map (go co) args)
go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
where (xr,xc) = go co x
go _ _ = (caseTrivial,False)
deepSubtypesContaining :: TyVar -> Type -> [TcType]
deepSubtypesContaining tv
= functorLikeTraverse tv
(FT { ft_triv = []
, ft_var = []
, ft_fun = (++)
, ft_tup = \_ xs -> concat xs
, ft_ty_app = (:)
, ft_bad_app = panic "in other argument"
, ft_co_var = panic "contravariant"
, ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
foldDataConArgs :: FFoldType a -> DataCon -> [a]
foldDataConArgs ft con
= map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
where
Just tv = getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))
mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
-> State [RdrName] (LHsExpr RdrName)
mkSimpleLam lam = do
(n:names) <- get
put names
body <- lam (nlHsVar n)
return (mkHsLam [nlVarPat n] body)
mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
-> State [RdrName] (LHsExpr RdrName))
-> State [RdrName] (LHsExpr RdrName)
mkSimpleLam2 lam = do
(n1:n2:names) <- get
put names
body <- lam (nlHsVar n1) (nlHsVar n2)
return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
-> [LPat RdrName]
-> DataCon
-> [LHsExpr RdrName]
-> m (LMatch RdrName (LHsExpr RdrName))
mkSimpleConMatch fold extra_pats con insides = do
let con_name = getRdrName con
let vars_needed = takeList insides as_RDRs
let pat = nlConVarPat con_name vars_needed
rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
-> m (LMatch RdrName (LHsExpr RdrName)))
-> TupleSort -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
mkSimpleTupleCase match_for_con sort insides x = do
let con = tupleCon sort (length insides)
match <- match_for_con [] con insides
return $ nlHsCase x [match]
gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Foldable_binds loc tycon
= (listToBag [foldr_bind, foldMap_bind], emptyBag)
where
data_cons = tyConDataCons tycon
foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
where
parts = sequence $ foldDataConArgs ft_foldr con
foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
where
parts = sequence $ foldDataConArgs ft_foldMap con
ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z -> return z
, ft_var = return f_Expr
, ft_tup = \t g -> do gg <- sequence g
mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
, ft_ty_app = \_ g -> do gg <- g
mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
, ft_forall = \_ g -> g
, ft_co_var = panic "contravariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs
ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr
, ft_var = return f_Expr
, ft_tup = \t g -> do gg <- sequence g
mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
, ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g
, ft_forall = \_ g -> g
, ft_co_var = panic "contravariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
case xs of
[] -> mempty_Expr
xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
gen_Traversable_binds loc tycon
= (unitBag traverse_bind, emptyBag)
where
data_cons = tyConDataCons tycon
traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
eqns = map traverse_eqn data_cons
traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
where
parts = sequence $ foldDataConArgs ft_trav con
ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
ft_trav = FT { ft_triv = return pure_Expr
, ft_var = return f_Expr
, ft_tup = \t gs -> do
gg <- sequence gs
mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
, ft_ty_app = \_ g -> nlHsApp traverse_Expr <$> g
, ft_forall = \_ g -> g
, ft_co_var = panic "contravariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
match_for_con = mkSimpleConMatch $
\con_name xs -> return $ mkApCon (nlHsVar con_name) xs
mkApCon con [] = nlHsApps pure_RDR [con]
mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
where appAp x y = nlHsApps ap_RDR [x,y]
mkCoerceClassMethEqn :: Class
-> [TyVar]
-> [Type]
-> Type
-> Id
-> Pair Type
mkCoerceClassMethEqn cls inst_tvs cls_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 cls_tys)
rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
(_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
changeLast :: [a] -> a -> [a]
changeLast [] _ = panic "changeLast"
changeLast [_] x = [x]
changeLast (x:xs) x' = x : changeLast xs x'
gen_Newtype_binds :: SrcSpan
-> Class
-> [TyVar]
-> [Type]
-> Type
-> LHsBinds RdrName
gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
= listToBag $ zipWith mk_bind
(classMethods cls)
(map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
where
coerce_RDR = getRdrName coerceId
mk_bind :: Id -> Pair Type -> LHsBind RdrName
mk_bind id (Pair tau_ty user_ty)
= mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
where
meth_RDR = getRdrName id
rhs_expr
= ( nlHsVar coerce_RDR
`nlHsApp`
(nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty'))
`nlExprWithTySig` toHsType user_ty
(_, _, tau_ty') = tcSplitSigmaTy tau_ty
nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName
nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder)
genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
genAuxBindSpec loc (DerivCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns,
L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
where
rdr_name = con2tag_RDR tycon
sig_ty = HsCoreTy $
mkSigmaTy (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 ""
(toInteger ((dataConTag con) fIRST_TAG))))
genAuxBindSpec 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] (L loc sig_ty) PlaceHolder))
where
sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
intTy `mkFunTy` mkParentType tycon
rdr_name = tag2con_RDR tycon
genAuxBindSpec loc (DerivMaxTag tycon)
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
where
rdr_name = maxtag_RDR tycon
sig_ty = HsCoreTy intTy
rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) fIRST_TAG)
type SeparateBagsDerivStuff =
( Bag (LHsBind RdrName, LSig RdrName)
, Bag TyCon
, Bag (FamInst)
, Bag (InstInfo RdrName))
genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
genAuxBinds 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 loc) (rm_dups b1)
, emptyBag, emptyBag, emptyBag)
f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
f (DerivAuxBind _) = panic "genAuxBinds'"
f (DerivHsBind b) = add1 b
f (DerivTyCon t) = add2 t
f (DerivFamInst t) = add3 t
f (DerivInst i) = add4 i
add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
mk_data_type_name :: TyCon -> RdrName
mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
mk_constr_name :: DataCon -> RdrName
mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
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 loc fun pats_and_exprs
= mkRdrFunBind (L loc fun) matches
where
matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
where
matches' = if null matches
then [mkMatch [] (error_Expr str) emptyLocalBinds]
else matches
str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
box_if_necy :: String
-> TyCon
-> LHsExpr RdrName
-> Type
-> LHsExpr RdrName
box_if_necy cls_str tycon arg arg_ty
| isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
| otherwise = 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
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)
]
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 :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
untag_Expr _ [] expr = expr
untag_Expr tycon ((untag_this, put_tag_here) : more) expr
= nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this]))
[mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr 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, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
a_Expr = nlHsVar a_RDR
c_Expr = nlHsVar c_RDR
f_Expr = nlHsVar f_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
fmap_Expr = nlHsVar fmap_RDR
pure_Expr = nlHsVar pure_RDR
mempty_Expr = nlHsVar mempty_RDR
foldMap_Expr = nlHsVar foldMap_RDR
traverse_Expr = nlHsVar traverse_RDR
a_Pat, b_Pat, c_Pat, d_Pat, f_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
f_Pat = nlVarPat f_RDR
k_Pat = nlVarPat k_RDR
z_Pat = nlVarPat z_RDR
minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
minusInt_RDR = getRdrName (primOpId IntSubOp )
tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
error_RDR = getRdrName eRROR_ID
con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
mkAuxBinderName parent occ_fun
= mkRdrUnqual (occ_fun uniq_parent_occ)
where
uniq_parent_occ = mkOccName (occNameSpace parent_occ) uniq_string
uniq_string
| opt_PprStyle_Debug
= showSDocUnsafe (ppr parent_occ <> underscore <> ppr parent_uniq)
| otherwise
= show parent_uniq
parent_uniq = nameUnique parent
parent_occ = nameOccName parent