} was put in the context
for the instance decl, which it probably wasn't, so the decls
produced don't get through the typechecker.
\end{itemize}
\begin{code}
gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Eq_binds loc tycon
= (method_binds, aux_binds)
where
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
| otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
no_nullary_cons = null nullary_cons
rest | no_nullary_cons
= case tyConSingleDataCon_maybe tycon of
Just _ -> []
Nothing ->
[([nlWildPat, nlWildPat], false_Expr)]
| otherwise
= [([a_Pat, b_Pat],
untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
(genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
aux_binds | no_nullary_cons = []
| otherwise = [GenCon2Tag tycon]
method_binds = listToBag [eq_bind, ne_bind]
eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
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))
\end{code}
%************************************************************************
%* *
Ord instances
%* *
%************************************************************************
Note [Generating Ord instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose constructors are K1..Kn, and some are nullary.
The general form we generate is:
* Do case on first argument
case a of
K1 ... -> rhs_1
K2 ... -> rhs_2
...
Kn ... -> rhs_n
_ -> nullary_rhs
* To make rhs_i
If i = 1, 2, n-1, n, generate a single case.
rhs_2 case b of
K1 {} -> LT
K2 ... -> ...eq_rhs(K2)...
_ -> GT
Otherwise do a tag compare against the bigger range
(because this is the one most likely to succeed)
rhs_3 case tag b of tb ->
if 3 <# tg then GT
else case b of
K3 ... -> ...eq_rhs(K3)....
_ -> LT
* To make eq_rhs(K), which knows that
a = K a1 .. av
b = K b1 .. bv
we just want to compare (a1,b1) then (a2,b2) etc.
Take care on the last field to tail-call into comparing av,bv
* To make nullary_rhs generate this
case con2tag a of a# ->
case con2tag b of ->
a# `compare` b#
Several special cases:
* Two or fewer nullary constructors: don't generate nullary_rhs
* Be careful about unlifted comparisons. When comparing unboxed
values we can't call the overloaded functions.
See function unliftedOrdOp
Note [Do not rely on compare]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It's a bad idea to define only 'compare', and build the other binary
comparisions on top of it; see Trac #2130, #4019. Reason: we don't
want to laboriously make a three-way comparison, only to extract a
binary result, something like this:
(>) (I# x) (I# y) = case <# x y of
True -> False
False -> case ==# x y of
True -> False
False -> True
So for sufficiently small types (few constructors, or all nullary)
we generate all methods; for large ones we just use 'compare'.
\begin{code}
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, DerivAuxBinds)
gen_Ord_binds loc tycon
| null tycon_data_cons
= (unitBag $ mk_FunBind loc compare_RDR [], [])
| otherwise
= (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
where
aux_binds | single_con_type = []
| otherwise = [GenCon2Tag 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
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 (genOpApp (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 (genOpApp (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
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 = genOpApp a_expr (primOpRdrName prim_op) b_expr
a_expr = nlHsVar a
b_expr = nlHsVar b
unliftedCompare :: PrimOp -> PrimOp
-> 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 (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt
nlConWildPat :: DataCon -> LPat RdrName
nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(RecCon (HsRecFields { rec_flds = []
, rec_dotdot = Nothing })))
\end{code}
%************************************************************************
%* *
Enum instances
%* *
%************************************************************************
@Enum@ can only be derived for enumeration types. For a type
\begin{verbatim}
data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}
we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
\begin{verbatim}
instance ... Enum (Foo ...) where
succ x = toEnum (1 + fromEnum x)
pred x = toEnum (fromEnum x - 1)
toEnum i = tag2con_Foo i
enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
-- or, really...
enumFrom a
= case con2tag_Foo a of
a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
enumFromThen a b
= map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
-- or, really...
enumFromThen a b
= case con2tag_Foo a of { a# ->
case con2tag_Foo b of { b# ->
map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
}}
\end{verbatim}
For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
\begin{code}
gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
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 = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag 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))]))
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])
\end{code}
%************************************************************************
%* *
Bounded instances
%* *
%************************************************************************
\begin{code}
gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Bounded_binds loc tycon
| isEnumerationTyCon tycon
= (listToBag [ min_bound_enum, max_bound_enum ], [])
| otherwise
= ASSERT(isSingleton data_cons)
(listToBag [ min_bound_1con, max_bound_1con ], [])
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)
\end{code}
%************************************************************************
%* *
Ix instances
%* *
%************************************************************************
Deriving @Ix@ is only possible for enumeration types and
single-constructor types. We deal with them in turn.
For an enumeration type, e.g.,
\begin{verbatim}
data Foo ... = N1 | N2 | ... | Nn
\end{verbatim}
things go not too differently from @Enum@:
\begin{verbatim}
instance ... Ix (Foo ...) where
range (a, b)
= map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
-- or, really...
range (a, b)
= case (con2tag_Foo a) of { a# ->
case (con2tag_Foo b) of { b# ->
map tag2con_Foo (enumFromTo (I# a#) (I# b#))
}}
-- Generate code for unsafeIndex, becuase using index leads
-- to lots of redundant range tests
unsafeIndex c@(a, b) d
= case (con2tag_Foo d -# con2tag_Foo a) of
r# -> I# r#
inRange (a, b) c
= let
p_tag = con2tag_Foo c
in
p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
-- or, really...
inRange (a, b) c
= case (con2tag_Foo a) of { a_tag ->
case (con2tag_Foo b) of { b_tag ->
case (con2tag_Foo c) of { c_tag ->
if (c_tag >=# a_tag) then
c_tag <=# b_tag
else
False
}}}
\end{verbatim}
(modulo suitable case-ification to handle the unlifted tags)
For a single-constructor type (NB: this includes all tuples), e.g.,
\begin{verbatim}
data Foo ... = MkFoo a b Int Double c c
\end{verbatim}
we follow the scheme given in Figure~19 of the Haskell~1.2 report
(p.~147).
\begin{code}
gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Ix_binds loc tycon
| isEnumerationTyCon tycon
= (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
| otherwise
= (single_con_ixes, [GenCon2Tag 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 (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
(genOpApp (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] $
nlHsDo 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]
\end{code}
%************************************************************************
%* *
Read instances
%* *
%************************************************************************
Example
infix 4 %%
data T = Int %% Int
| T1 { f1 :: Int }
| T2 T
instance Read T where
readPrec =
parens
( prec 4 (
do x <- ReadP.step Read.readPrec
Symbol "%%" <- Lex.lex
y <- ReadP.step Read.readPrec
return (x %% y))
+++
prec (appPrec+1) (
-- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
-- Record construction binds even more tightly than application
do Ident "T1" <- Lex.lex
Punc '{' <- Lex.lex
Ident "f1" <- Lex.lex
Punc '=' <- Lex.lex
x <- ReadP.reset Read.readPrec
Punc '}' <- Lex.lex
return (T1 { f1 = x }))
+++
prec appPrec (
do Ident "T2" <- Lex.lexP
x <- ReadP.step Read.readPrec
return (T2 x))
)
readListPrec = readListPrecDefault
readList = readListDefault
\begin{code}
gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Read_binds get_fixity loc tycon
= (listToBag [read_prec, default_readlist, default_readlistprec], [])
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 = 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 [bindLex (match_con con)] (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_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 "(", bindLex (symbol_pat con_str), read_punc ")"]
| otherwise = [bindLex (ident_pat con_str)]
read_infix_con
| isSym con_str = [bindLex (symbol_pat con_str)]
| otherwise = [read_punc "`", bindLex (ident_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 b]
bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
con_app con as = nlHsVarApps (getRdrName con) as
result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as)
punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)]
ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)]
symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)]
data_con_str con = occNameString (getOccName con)
read_punc c = bindLex (punc_pat c)
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 "(",
bindLex (symbol_pat lbl_str),
read_punc ")"]
| otherwise
= [bindLex (ident_pat lbl_str)]
where
lbl_str = occNameString (getOccName lbl)
\end{code}
%************************************************************************
%* *
Show instances
%* *
%************************************************************************
Example
infixr 5 :^:
data Tree a = Leaf a | Tree a :^: Tree a
instance (Show a) => Show (Tree a) where
showsPrec d (Leaf m) = showParen (d > app_prec) showStr
where
showStr = showString "Leaf " . showsPrec (app_prec+1) m
showsPrec d (u :^: v) = showParen (d > up_prec) showStr
where
showStr = showsPrec (up_prec+1) u .
showString " :^: " .
showsPrec (up_prec+1) v
-- Note: right-associativity of :^: ignored
up_prec = 5 -- Precedence of :^:
app_prec = 10 -- Application has precedence one more than
-- the most tightly-binding operator
\begin{code}
gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Show_binds get_fixity loc tycon
= (listToBag [shows_prec, show_list], [])
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))
\end{code}
\begin{code}
getPrec :: Bool -> FixityEnv -> Name -> Integer
getPrec is_infix get_fixity nm
| not is_infix = appPrecedence
| otherwise = getPrecedence get_fixity nm
appPrecedence :: Integer
appPrecedence = fromIntegral maxPrecedence + 1
getPrecedence :: FixityEnv -> Name -> Integer
getPrecedence get_fixity nm
= case lookupFixity get_fixity nm of
Fixity x _assoc -> fromIntegral x
\end{code}
%************************************************************************
%* *
\subsection{Typeable}
%* *
%************************************************************************
From the data type
data T a b = ....
we generate
instance Typeable2 T where
typeOf2 _ = mkTyConApp (mkTyConRep "T") []
We are passed the Typeable2 class as well as T
\begin{code}
gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
gen_Typeable_binds loc tycon
= unitBag $
mk_easy_FunBind loc
(mk_typeOf_RDR tycon)
[nlWildPat]
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
mk_typeOf_RDR :: TyCon -> RdrName
mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
where
arity = tyConArity tycon
suffix | arity == 0 = ""
| otherwise = show arity
\end{code}
%************************************************************************
%* *
Data instances
%* *
%************************************************************************
From the data type
data T a b = T1 a b | T2
we generate
$cT1 = mkDataCon $dT "T1" Prefix
$cT2 = mkDataCon $dT "T2" Prefix
$dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
-- the [] is for field labels.
instance (Data a, Data b) => Data (T a b) where
gfoldl k z (T1 a b) = z T `k` a `k` b
gfoldl k z T2 = z T2
-- ToDo: add gmapT,Q,M, gfoldr
gunfold k z c = case conIndex c of
I# 1# -> k (k (z T1))
I# 2# -> z T2
toConstr (T1 _ _) = $cT1
toConstr T2 = $cT2
dataTypeOf _ = $dT
dataCast1 = gcast1 -- If T :: * -> *
dataCast2 = gcast2 -- if T :: * -> * -> *
\begin{code}
gen_Data_binds :: SrcSpan
-> TyCon
-> (LHsBinds RdrName,
DerivAuxBinds)
gen_Data_binds loc tycon
= (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
`unionBags` gcast_binds,
MkTyCon tycon : map MkDataCon data_cons)
where
data_cons = tyConDataCons tycon
n_cons = length data_cons
one_constr = n_cons == 1
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 tycon))
tycon_kind = tyConKind tycon
gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
| tycon_kind `eqKind` 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 :: 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")
\end{code}
%************************************************************************
%* *
Functor instances
see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
%* *
%************************************************************************
For the data type:
data T a = T1 Int a | T2 (T a)
We generate the instance:
instance Functor T where
fmap f (T1 b1 a) = T1 b1 (f a)
fmap f (T2 ta) = T2 (fmap f ta)
Notice that we don't simply apply 'fmap' to the constructor arguments.
Rather
- Do nothing to an argument whose type doesn't mention 'a'
- Apply 'f' to an argument of type 'a'
- Apply 'fmap f' to other arguments
That's why we have to recurse deeply into the constructor argument types,
rather than just one level, as we typically do.
What about types with more than one type parameter? In general, we only
derive Functor for the last position:
data S a b = S1 [b] | S2 (a, T a b)
instance Functor (S a) where
fmap f (S1 bs) = S1 (fmap f bs)
fmap f (S2 (p,q)) = S2 (a, fmap f q)
However, we have special cases for
- tuples
- functions
More formally, we write the derivation of fmap code over type variable
'a for type 'b as ($fmap 'a 'b). In this general notation the derived
instance for T is:
instance Functor T where
fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
$(fmap 'a 'b) x = x -- when b does not contain a
$(fmap 'a 'a) x = f x
$(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
$(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
$(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
For functions, the type parameter 'a can occur in a contravariant position,
which means we need to derive a function like:
cofmap :: (a -> b) -> (f b -> f a)
This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
$(cofmap 'a 'b) x = x -- when b does not contain a
$(cofmap 'a 'a) x = error "type variable in contravariant position"
$(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
$(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
$(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
$(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
\begin{code}
gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Functor_binds loc tycon
= (unitBag fmap_bind, [])
where
data_cons = tyConDataCons tycon
fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
where
parts = foldDataConArgs ft_fmap con
eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
(error_Expr "Void fmap")]
| otherwise = map fmap_eqn data_cons
ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
ft_fmap = FT { ft_triv = \x -> return x
, ft_var = \x -> return (nlHsApp f_Expr x)
, ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
, ft_tup = mkSimpleTupleCase match_for_con
, ft_ty_app = \_ g x -> do gg <- mkSimpleLam g
return $ nlHsApps fmap_RDR [gg,x]
, ft_forall = \_ g x -> g x
, ft_bad_app = panic "in other argument"
, ft_co_var = panic "contravariant" }
match_for_con = mkSimpleConMatch $
\con_name xsM -> do xs <- sequence xsM
return (nlHsApps con_name xs)
\end{code}
Utility functions related to Functor deriving.
Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
This function works like a fold: it makes a value of type 'a' in a bottom up way.
\begin{code}
data FFoldType a
= FT { ft_triv :: a
, ft_var :: a
, ft_co_var :: a
, ft_fun :: a -> a -> a
, ft_tup :: Boxity -> [a] -> a
, ft_ty_app :: Type -> a -> a
, ft_bad_app :: a
, ft_forall :: TcTyVar -> a -> a
}
functorLikeTraverse :: 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 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 (PredTy _) b) = go co b
go co (FunTy x 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 (tupleTyConBoxity con) xrs, True)
| or (init xcs) = (caseWrongArg, True)
| otherwise =
(caseTyApp (fst (splitAppTy 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
tv = last (dataConUnivTyVars con)
mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
mkSimpleLam lam = do
(n:names) <- get
put names
body <- lam (nlHsVar n)
return (mkHsLam [nlVarPat n] body)
mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
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 -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch 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 ($) insides (map nlHsVar vars_needed))
return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
-> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
mkSimpleTupleCase match_for_con boxity insides x = do
let con = tupleCon boxity (length insides)
match <- match_for_con [] con insides
return $ nlHsCase x [match]
\end{code}
%************************************************************************
%* *
Foldable instances
see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
%* *
%************************************************************************
Deriving Foldable instances works the same way as Functor instances,
only Foldable instances are not possible for function types at all.
Here the derived instance for the type T above is:
instance Foldable T where
foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
The cases are:
$(foldr 'a 'b) x z = z -- when b does not contain a
$(foldr 'a 'a) x z = f x z
$(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
$(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
Note that the arguments to the real foldr function are the wrong way around,
since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
\begin{code}
gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Foldable_binds loc tycon
= (unitBag foldr_bind, [])
where
data_cons = tyConDataCons tycon
foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
eqns = map foldr_eqn data_cons
foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
where
parts = foldDataConArgs ft_foldr con
ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
ft_foldr = FT { ft_triv = \_ z -> return z
, ft_var = \x z -> return (nlHsApps f_RDR [x,z])
, ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
, ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g
return $ nlHsApps foldable_foldr_RDR [gg,z,x]
, ft_forall = \_ g x z -> g x z
, ft_co_var = panic "covariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z)
\end{code}
%************************************************************************
%* *
Traversable instances
see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
%* *
%************************************************************************
Again, Traversable is much like Functor and Foldable.
The cases are:
$(traverse 'a 'b) x = pure x -- when b does not contain a
$(traverse 'a 'a) x = f x
$(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
$(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
Note that the generated code is not as efficient as it could be. For instance:
data T a = T Int a deriving Traversable
gives the function: traverse f (T x y) = T <$> pure x <*> f y
instead of: traverse f (T x y) = T x <$> f y
\begin{code}
gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Traversable_binds loc tycon
= (unitBag traverse_bind, [])
where
data_cons = tyConDataCons tycon
traverse_bind = L loc $ 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 = foldDataConArgs ft_trav con
ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x])
, ft_var = \x -> return (nlHsApps f_RDR [x])
, ft_tup = mkSimpleTupleCase match_for_con
, ft_ty_app = \_ g x -> do gg <- mkSimpleLam g
return $ nlHsApps traverse_RDR [gg,x]
, ft_forall = \_ g x -> g x
, ft_co_var = panic "covariant"
, ft_fun = panic "function"
, ft_bad_app = panic "in other argument" }
match_for_con = mkSimpleConMatch $
\con_name xsM -> do xs <- sequence xsM
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]
\end{code}
%************************************************************************
%* *
\subsection{Generating extra binds (@con2tag@ and @tag2con@)}
%* *
%************************************************************************
\begin{verbatim}
data Foo ... = ...
con2tag_Foo :: Foo ... -> Int#
tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
maxtag_Foo :: Int -- ditto (NB: not unlifted)
\end{verbatim}
The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
fiddling around.
\begin{code}
genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (GenCon2Tag tycon)
= (mk_FunBind loc rdr_name eqns,
L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
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))))
genAuxBind loc (GenTag2Con 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)))
where
sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
intTy `mkFunTy` mkParentType tycon
rdr_name = tag2con_RDR tycon
genAuxBind loc (GenMaxTag tycon)
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
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)
genAuxBind loc (MkTyCon tycon)
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig (L loc rdr_name) sig_ty))
where
rdr_name = mk_data_type_name tycon
sig_ty = nlHsTyVar dataType_RDR
constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
rhs = nlHsVar mkDataType_RDR
`nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
`nlHsApp` nlList constrs
genAuxBind loc (MkDataCon dc)
= (mkHsVarBind loc rdr_name rhs,
L loc (TypeSig (L loc rdr_name) sig_ty))
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
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
\end{code}
%************************************************************************
%* *
\subsection{Utility bits for generating bindings}
%* *
%************************************************************************
\begin{code}
mk_FunBind :: SrcSpan -> RdrName
-> [([LPat RdrName], LHsExpr RdrName)]
-> LHsBind RdrName
mk_FunBind loc fun pats_and_exprs
= L loc $ mkRdrFunBind (L loc fun) matches
where
matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
mkRdrFunBind fun@(L _ fun_rdr) matches
| null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds]
| otherwise = mkFunBind fun matches
where
str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
\end{code}
\begin{code}
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 box_con_tbl arg_ty
primOrdOps :: String
-> TyCon
-> Type
-> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp)
primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
ord_op_tbl
= [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp))
,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
box_con_tbl :: [(Type, RdrName)]
box_con_tbl =
[(charPrimTy, getRdrName charDataCon)
,(intPrimTy, getRdrName intDataCon)
,(wordPrimTy, wordDataCon_RDR)
,(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 `tcEqType` 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 = genOpApp a eq_op b
where
eq_op | not (isUnLiftedType ty) = eq_RDR
| otherwise = primOpRdrName prim_eq
(_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
\end{code}
\begin{code}
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)
\end{code}
\begin{code}
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 :: 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
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
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 (nameOccName parent))
\end{code}
s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
PrelNames, so PrelNames can't import PrimOp.
\begin{code}
primOpRdrName :: PrimOp -> RdrName
primOpRdrName op = getRdrName (primOpId op)
minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
tagToEnum_RDR :: RdrName
minusInt_RDR = primOpRdrName IntSubOp
eqInt_RDR = primOpRdrName IntEqOp
ltInt_RDR = primOpRdrName IntLtOp
geInt_RDR = primOpRdrName IntGeOp
gtInt_RDR = primOpRdrName IntGtOp
leInt_RDR = primOpRdrName IntLeOp
tagToEnum_RDR = primOpRdrName TagToEnumOp
error_RDR :: RdrName
error_RDR = getRdrName eRROR_ID
\end{code}