gen_Show_binds,
gen_Data_binds,
gen_Typeable_binds,
- gen_Functor_binds, functorLikeTraverse, deepSubtypesContaining,
+ gen_Functor_binds,
+ FFoldType(..), functorLikeTraverse,
+ deepSubtypesContaining, foldDataConArgs,
gen_Foldable_binds,
gen_Traversable_binds,
genAuxBind
import HscTypes
import PrelInfo
import PrelNames
-import MkId
import PrimOp
import SrcLoc
import TyCon
import TysPrim
import TysWiredIn
import Type
+import Var( TyVar )
import TypeRep
import VarSet
import State
import MonadUtils
import Outputable
import FastString
-import OccName
import Bag
-
import Data.List ( partition, intersperse )
\end{code}
= GenCon2Tag TyCon -- The con2Tag for given TyCon
| GenTag2Con TyCon -- ...ditto tag2Con
| GenMaxTag TyCon -- ...and maxTag
+ -- All these generate ZERO-BASED tag operations
+ -- I.e first constructor has tag 0
-- Scrap your boilerplate
| MkDataCon DataCon -- For constructor C we get $cC :: Constr
%* *
%************************************************************************
-For a derived @Ord@, we concentrate our attentions on @compare@
-\begin{verbatim}
-compare :: a -> a -> Ordering
-data Ordering = LT | EQ | GT deriving ()
-\end{verbatim}
-
-We will use the same example data type as above:
-\begin{verbatim}
-data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
-\end{verbatim}
-
-\begin{itemize}
-\item
- We do all the other @Ord@ methods with calls to @compare@:
-\begin{verbatim}
-instance ... (Ord <wurble> <wurble>) where
- a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
- a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
- a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
- a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
-
- max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
- min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
+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
- -- compare to come...
-\end{verbatim}
+So for sufficiently small types (few constructors, or all nullary)
+we generate all methods; for large ones we just use 'compare'.
-\item
- @compare@ always has two parts. First, we use the compared
- data-constructors' tags to deal with the case of different
- constructors:
-\begin{verbatim}
-compare a b = case (con2tag_Foo a) of { a# ->
- case (con2tag_Foo b) of { b# ->
- case (a# ==# b#) of {
- True -> cmp_eq a b
- False -> case (a# <# b#) of
- True -> _LT
- False -> _GT
- }}}
+\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
+-- Knowing a<b, what is the result for a `op` b?
+ltResult OrdCompare = ltTag_Expr
+ltResult OrdLT = true_Expr
+ltResult OrdLE = true_Expr
+ltResult OrdGE = false_Expr
+ltResult OrdGT = false_Expr
+
+------------
+eqResult :: OrdOp -> LHsExpr RdrName
+-- Knowing a=b, what is the result for a `op` b?
+eqResult OrdCompare = eqTag_Expr
+eqResult OrdLT = false_Expr
+eqResult OrdLE = true_Expr
+eqResult OrdGE = true_Expr
+eqResult OrdGT = false_Expr
+
+------------
+gtResult :: OrdOp -> LHsExpr RdrName
+-- Knowing a>b, what is the result for a `op` b?
+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
+ = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
where
- cmp_eq = ... to come ...
-\end{verbatim}
+ aux_binds | single_con_type = []
+ | otherwise = [GenCon2Tag tycon]
-\item
- We are only left with the ``help'' function @cmp_eq@, to deal with
- comparing data constructors with the same tag.
+ -- Note [Do not rely on compare]
+ other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
+ || null non_nullary_cons -- Or it's an enumeration
+ = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
+ | otherwise
+ = emptyBag
- For the ordinary constructors (if any), we emit the sorta-obvious
- compare-style stuff; for our example:
-\begin{verbatim}
-cmp_eq (O1 a1 b1) (O1 a2 b2)
- = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
-
-cmp_eq (O2 a1) (O2 a2)
- = compare a1 a2
-
-cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
- = case (compare a1 a2) of {
- LT -> LT;
- GT -> GT;
- EQ -> case compare b1 b2 of {
- LT -> LT;
- GT -> GT;
- EQ -> compare c1 c2
- }
- }
-\end{verbatim}
+ get_tag con = dataConTag con - fIRST_TAG
+ -- We want *zero-based* tags, because that's what
+ -- con2Tag returns (generated by untag_Expr)!
- Again, we must be careful about unlifted comparisons. For example,
- if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
- generate:
+ 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
-\begin{verbatim}
-cmp_eq lt eq gt (O2 a1) (O2 a2)
- = compareInt# a1 a2
- -- or maybe the unfolded equivalent
-\end{verbatim}
+ (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
+
-\item
- For the remaining nullary constructors, we already know that the
- tags are equal so:
-\begin{verbatim}
-cmp_eq _ _ = EQ
-\end{verbatim}
-\end{itemize}
+ mkOrdOp :: OrdOp -> LHsBind RdrName
+ -- Returns a binding op a b = ... compares a and b according to op ....
+ mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
-If there is only one constructor in the Data Type we don't need the WildCard Pattern.
-JJQC-30-Nov-1997
+ mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
+ mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
+ | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
+ = nlHsCase (nlHsVar a_RDR) $
+ map (mkOrdOpAlt op) tycon_data_cons
+ -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
+ -- C2 x -> case b of C2 x -> ....comopare x.... }
-\begin{code}
-gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
+ | null non_nullary_cons -- All nullary, so go straight to comparing tags
+ = mkTagCmp op
-gen_Ord_binds loc tycon
- | Just (con, prim_tc) <- primWrapperType_maybe tycon
- = gen_PrimOrd_binds con prim_tc
+ | otherwise -- Mixed nullary and non-nullary
+ = nlHsCase (nlHsVar a_RDR) $
+ (map (mkOrdOpAlt op) non_nullary_cons
+ ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
- | otherwise
- = (unitBag compare, aux_binds)
- -- `AndMonoBinds` compare
- -- The default declaration in PrelBase handles this
- where
- aux_binds | single_con_type = []
- | otherwise = [GenCon2Tag tycon]
-
- compare = L loc (mkFunBind (L loc compare_RDR) compare_matches)
- compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
- cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
-
- compare_rhs
- | single_con_type = cmp_eq_Expr a_Expr b_Expr
- | otherwise
- = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
- (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
- (cmp_eq_Expr a_Expr b_Expr) -- True case
- -- False case; they aren't equal
- -- So we need to do a less-than comparison on the tags
- (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
- tycon_data_cons = tyConDataCons tycon
- single_con_type = isSingleton tycon_data_cons
- (nullary_cons, nonnullary_cons)
- | isNewTyCon tycon = ([], tyConDataCons tycon)
- | otherwise = partition isNullarySrcDataCon tycon_data_cons
-
- cmp_eq = mk_FunBind loc cmp_eq_RDR cmp_eq_match
- cmp_eq_match
- | isEnumerationTyCon tycon
- -- We know the tags are equal, so if it's an enumeration TyCon,
- -- then there is nothing left to do
- -- Catch this specially to avoid warnings
- -- about overlapping patterns from the desugarer,
- -- and to avoid unnecessary pattern-matching
- = [([nlWildPat,nlWildPat], eqTag_Expr)]
+ mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName
+ -- Make the alternative (Ki a1 a2 .. av ->
+ 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 -- lower range is larger
+ = untag_Expr tycon [(b_RDR, bh_RDR)] $
+ nlHsIf (genOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
+ (gtResult op) $ -- Definitely GT
+ nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
+ , mkSimpleHsAlt nlWildPat (ltResult op) ]
+
+ | otherwise -- upper range is larger
+ = untag_Expr tycon [(b_RDR, bh_RDR)] $
+ nlHsIf (genOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
+ (ltResult op) $ -- Definitely LT
+ 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
+ -- First argument 'a' known to be built with K
+ -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
+ 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
+ -- Both constructors known to be nullary
+ -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
+ 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
+-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
+-- where the ai,bi have the given types
+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) generates
+ -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
+ -- but with suitable special cases for
+ mk_compare ty a b lt eq gt
+ | isUnLiftedType ty
+ = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
| otherwise
- = map pats_etc nonnullary_cons ++
- (if single_con_type then -- Omit wildcards when there's just one
- [] -- constructor, to silence desugarer
- else
- [([nlWildPat, nlWildPat], default_rhs)])
-
- default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
- -- inexhaustive patterns
- | otherwise = eqTag_Expr -- Some nullary constructors;
- -- Tags are equal, no args => return EQ
- pats_etc data_con
- = ([con1_pat, con2_pat],
- nested_compare_expr tys_needed as_needed bs_needed)
- where
- 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
-
- nested_compare_expr [ty] [a] [b]
- = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
-
- nested_compare_expr (ty:tys) (a:as) (b:bs)
- = let eq_expr = nested_compare_expr tys as bs
- in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
-
- nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
+ = 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 -- What to cmpare
+ -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
+ -> LHsExpr RdrName
+-- Return (if a < b then lt else if a == b then eq else gt)
+unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
+ = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
+ -- Test (<) first, not (==), becuase the latter
+ -- is true less often, so putting it first would
+ -- mean more tests (dynamically)
+ nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt
+
+nlConWildPat :: DataCon -> LPat RdrName
+-- The pattern (K {})
+nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
+ (RecCon (HsRecFields { rec_flds = []
+ , rec_dotdot = Nothing })))
\end{code}
-Note [Comparision of primitive types]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The general plan does not work well for data types like
- data T = MkT Int# deriving( Ord )
-The general plan defines the 'compare' method, gets (<) etc from it. But
-that means we get silly code like:
- instance Ord T where
- (>) (I# x) (I# y) = case <# x y of
- True -> False
- False -> case ==# x y of
- True -> False
- False -> True
-We would prefer to use the (>#) primop. See also Trac #2130
-\begin{code}
-gen_PrimOrd_binds :: DataCon -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
--- See Note [Comparison of primitive types]
-gen_PrimOrd_binds data_con prim_tc
- = (listToBag [mk_op lt_RDR lt_op, mk_op le_RDR le_op,
- mk_op ge_RDR ge_op, mk_op gt_RDR gt_op], [])
- where
- mk_op op_RDR op = mk_FunBind (getSrcSpan data_con) op_RDR
- [([apat, bpat], genOpApp a_Expr (primOpRdrName op) b_Expr)]
- con_RDR = getRdrName data_con
- apat = nlConVarPat con_RDR [a_RDR]
- bpat = nlConVarPat con_RDR [b_RDR]
-
- (lt_op, le_op, ge_op, gt_op)
- | prim_tc == charPrimTyCon = (CharLtOp, CharLeOp, CharGeOp, CharGtOp)
- | prim_tc == intPrimTyCon = (IntLtOp, IntLeOp, IntGeOp, IntGtOp)
- | prim_tc == wordPrimTyCon = (WordLtOp, WordLeOp, WordGeOp, WordGtOp)
- | prim_tc == addrPrimTyCon = (AddrLtOp, AddrLeOp, AddrGeOp, AddrGtOp)
- | prim_tc == floatPrimTyCon = (FloatLtOp, FloatLeOp, FloatGeOp, FloatGtOp)
- | prim_tc == doublePrimTyCon = (DoubleLtOp, DoubleLeOp, DoubleGeOp, DoubleGtOp)
- | otherwise = pprPanic "Unexpected primitive tycon" (ppr prim_tc)
-
-
-primWrapperType_maybe :: TyCon -> Maybe (DataCon, TyCon)
--- True of data types that are wrappers around prmitive types
--- data T = MkT Word#
--- For these we want to generate all the (<), (<=) etc operations individually
-primWrapperType_maybe tc
- | [con] <- tyConDataCons tc
- , [ty] <- dataConOrigArgTys con
- , Just (prim_tc, []) <- tcSplitTyConApp_maybe ty
- , isPrimTyCon prim_tc
- = Just (con, prim_tc)
- | otherwise
- = Nothing
-\end{code}
-
%************************************************************************
%* *
Enum instances
data_cons = tyConDataCons tycon
----- enum-flavored: ---------------------------
- min_bound_enum = mkVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
- max_bound_enum = mkVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
+ 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
----- single-constructor-flavored: -------------
arity = dataConSourceArity data_con_1
- min_bound_1con = mkVarBind loc minBound_RDR $
+ min_bound_1con = mkHsVarBind loc minBound_RDR $
nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
- max_bound_1con = mkVarBind loc maxBound_RDR $
+ max_bound_1con = mkHsVarBind loc maxBound_RDR $
nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
\end{code}
mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
(nlHsApp (nlHsVar range_RDR)
- (nlTuple [nlHsVar a, nlHsVar b] Boxed))
+ (mkLHsVarTuple [a,b]))
----------------
single_con_index
) plus_RDR (
genOpApp (
(nlHsApp (nlHsVar unsafeRangeSize_RDR)
- (nlTuple [nlHsVar l, nlHsVar u] Boxed))
+ (mkLHsVarTuple [l,u]))
) times_RDR (mk_index rest)
)
mk_one l u i
- = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
+ = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
------------------
single_con_inRange
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 [nlTuple [nlHsVar a, nlHsVar b] Boxed,
- nlHsVar c]
+ in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
\end{code}
%************************************************************************
where
-----------------------------------------------------------------------
default_readlist
- = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
+ = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
default_readlistprec
- = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
+ = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
-----------------------------------------------------------------------
data_cons = tyConDataCons tycon
(nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
- read_prec = mkVarBind loc readPrec_RDR
+ 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_nullary_cons
= case nullary_cons of
[] -> []
- [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
- (result_expr con [])]
+ [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])]
_ -> [nlHsApp (nlHsVar choose_RDR)
(nlList (map mk_pair nullary_cons))]
-
- mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
- result_expr con []]
- Boxed
-
+ -- NB For operators the parens around (:=:) are matched by the
+ -- enclosing "parens" call, so here we must match the naked
+ -- data_con_str con
+
+ match_con con | isSym con_str = symbol_pat con_str
+ | otherwise = ident_pat con_str
+ where
+ con_str = data_con_str con
+ -- For nullary constructors we must match Ident s for normal constrs
+ -- and Symbol s for operators
+
+ 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
= (listToBag [shows_prec, show_list], [])
where
-----------------------------------------------------------------------
- show_list = mkVarBind loc showList_RDR
+ show_list = mkHsVarBind loc showList_RDR
(nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
-----------------------------------------------------------------------
shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
pats_etc data_con
| nullary_con = -- skip the showParen junk...
ASSERT(null bs_needed)
- ([nlWildPat, con_pat], mk_showString_app con_str)
+ ([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))))
[nlWildPat]
(nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
where
- tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
+ tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
mk_typeOf_RDR :: TyCon -> RdrName
-- Use the arity of the TyCon to make the right typeOfn function
dataTypeOf _ = $dT
+ dataCast1 = gcast1 -- If T :: * -> *
+ dataCast2 = gcast2 -- if T :: * -> * -> *
+
+
\begin{code}
gen_Data_binds :: SrcSpan
-> TyCon
-> (LHsBinds RdrName, -- The method bindings
DerivAuxBinds) -- Auxiliary bindings
gen_Data_binds loc tycon
- = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
+ = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
+ `unionBags` gcast_binds,
-- Auxiliary definitions: the data type and constructors
MkTyCon tycon : map MkDataCon data_cons)
where
[nlWildPat]
(nlHsVar (mk_data_type_name tycon))
+ ------------ gcast1/2
+ 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 :: 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")
-mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
-mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
-conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
+ 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
+ Functor instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
%* *
%************************************************************************
\begin{code}
gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Functor_binds loc tycon
- = (listToBag [fmap_bind], [])
+ = (unitBag fmap_bind, [])
where
data_cons = tyConDataCons tycon
- arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
-
- fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
+ fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns
+
fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
- where parts = map derive_fmap_type (dataConOrigArgTys con)
-
- derive_fmap_type :: Type -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
- derive_fmap_type = functorLikeTraverse
- (\ x -> return x) -- fmap f x = x
- (\ x -> return (nlHsApp f_Expr x)) -- fmap f x = f x
- (panic "contravariant")
- (\g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))) -- fmap f x = \b -> h (x (g b))
- (mkSimpleTupleCase match_for_con) -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
- (\_ g x -> do gg <- mkSimpleLam g
- return $ nlHsApps fmap_RDR [gg,x]) -- fmap f x = fmap g x
- (panic "in other argument")
- (\_ g x -> g x)
- arg
+ where
+ parts = foldDataConArgs ft_fmap con
+
+ -- Catch-all eqn looks like fmap _ _ = error "impossible"
+ -- It's needed if there no data cons at all
+ 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))
+ -- Tricky higher order type; I can't say I fully understand this code :-(
+ ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
+ , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
+ , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
+ -- fmap f x = \b -> h (x (g b))
+ , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
+ , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
+ 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
\begin{code}
-- Generic traversal for Functor deriving
-functorLikeTraverse :: a -- ^ Case: does not contain variable
- -> a -- ^ Case: the variable itself
- -> a -- ^ Case: the variable itself, contravariantly
- -> (a -> a -> a) -- ^ Case: function type
- -> (Boxity -> [a] -> a) -- ^ Case: tuple type
- -> (Type -> a -> a) -- ^ Case: type app, variable only in last argument
- -> a -- ^ Case: type app, variable other than in last argument
- -> (TcTyVar -> a -> a) -- ^ Case: forall type
- -> TcTyVar -- ^ Variable to look for
- -> Type -- ^ Type to process
- -> a
-functorLikeTraverse caseTrivial caseVar caseCoVar caseFun caseTuple caseTyApp caseWrongArg caseForAll var ty
- = fst (go False ty)
+data FFoldType a -- Describes how to fold over a Type in a functor like way
+ = FT { ft_triv :: a -- Does not contain variable
+ , ft_var :: a -- The variable itself
+ , ft_co_var :: a -- The variable itself, contravariantly
+ , ft_fun :: a -> a -> a -- Function type
+ , ft_tup :: Boxity -> [a] -> a -- Tuple type
+ , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
+ , ft_bad_app :: a -- Type app, variable other than in last argument
+ , ft_forall :: TcTyVar -> a -> a -- Forall type
+ }
+
+functorLikeTraverse :: TyVar -- ^ Variable to look for
+ -> FFoldType a -- ^ How to fold
+ -> Type -- ^ Type to process
+ -> 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 returns (result of type a, does type contain var)
go co ty | Just ty' <- coreView ty = go co ty'
go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
-- Return all syntactic subterms of ty that contain var somewhere
-- These are the things that should appear in instance constraints
-deepSubtypesContaining :: TcTyVar -> TcType -> [TcType]
-deepSubtypesContaining = functorLikeTraverse
- []
- []
- (panic "contravariant")
- (\x y -> x ++ y) -- function
- (\_ xs -> concat xs) -- tuple
- (\ty x -> ty : x) -- tyapp
- (panic "in other argument")
- (\v x -> filter (not . (v `elemVarSet`) . tyVarsOfType) x) -- forall v
-
+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]
+-- Fold over the arguments of the datacon
+foldDataConArgs ft con
+ = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
+ where
+ tv = last (dataConUnivTyVars con)
+ -- Argument to derive for, 'a in the above description
+ -- The validity checks have ensured that con is
+ -- a vanilla data constructor
-- Make a HsLam using a fresh variable from a State monad
mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
+-- (mkSimpleLam fn) returns (\x. fn(x))
mkSimpleLam lam = do
(n:names) <- get
put names
%************************************************************************
%* *
- Foldable instances
+ Foldable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
+
%* *
%************************************************************************
\begin{code}
gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Foldable_binds loc tycon
- = (listToBag [foldr_bind], [])
+ = (unitBag foldr_bind, [])
where
data_cons = tyConDataCons tycon
- arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
- foldr_bind = L loc $ mkFunBind (L loc foldr_RDR) (map foldr_eqn data_cons)
+ foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) eqns
+ eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat]
+ (error_Expr "Void foldr")]
+ | otherwise = map foldr_eqn data_cons
foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
- where parts = map derive_foldr_type (dataConOrigArgTys con)
-
- derive_foldr_type :: Type -> LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
- derive_foldr_type = functorLikeTraverse
- (\ _ z -> return z) -- foldr f z x = z
- (\ x z -> return (nlHsApps f_RDR [x,z])) -- foldr f z x = f x z
- (panic "function")
- (panic "function")
- (\b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x)
- (\_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
- return $ nlHsApps foldable_foldr_RDR [gg,z,x])
- (panic "in other argument")
- (\_ g x z -> g x z)
- arg
+ 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 -- foldr f z x = z
+ , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f 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 -- foldr f z x = foldr (\xx zz -> g xx zz) z x
+ 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) -- g1 v1 (g2 v2 (.. z))
\end{code}
%************************************************************************
%* *
- Traversable instances
+ Traversable instances
+
+ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
%* *
%************************************************************************
\begin{code}
gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
gen_Traversable_binds loc tycon
- = (listToBag [traverse_bind], [])
+ = (unitBag traverse_bind, [])
where
data_cons = tyConDataCons tycon
- arg = last (tyConTyVars tycon) -- argument to derive for, 'a in the above description
- traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
+ traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) eqns
+ eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
+ (error_Expr "Void traverse")]
+ | otherwise = map traverse_eqn data_cons
traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
- where parts = map derive_travese_type (dataConOrigArgTys con)
-
- derive_travese_type :: Type -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName)
- derive_travese_type = functorLikeTraverse
- (\ x -> return (nlHsApps pure_RDR [x])) -- traverse f x = pure x
- (\ x -> return (nlHsApps f_RDR [x])) -- travese f x = f x
- (panic "function")
- (panic "function")
- (mkSimpleTupleCase match_for_con) -- travese f x z = case x of (a1,a2,..) -> (,,) <$> g1 a1 <*> g2 a2 <*> ..
- (\_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
- return $ nlHsApps traverse_RDR [gg,x])
- (panic "in other argument")
- (\_ g x -> g x)
- arg
+ 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]) -- traverse f x = pure x
+ , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
+ , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
+ -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
+ , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
+ 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
fiddling around.
\begin{code}
-genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
+genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
genAuxBind loc (GenCon2Tag tycon)
- | lots_of_constructors
- = mk_FunBind loc rdr_name [([], get_tag_rhs)]
-
- | otherwise
- = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
-
+ = (mk_FunBind loc rdr_name eqns,
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
rdr_name = con2tag_RDR tycon
- tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
- -- We can't use gerRdrName because that makes an Exact RdrName
- -- and we can't put them in the LocalRdrEnv
+ sig_ty = HsCoreTy $
+ mkForAllTys (tyConTyVars tycon) $
+ mkParentType tycon `mkFunTy` intPrimTy
- -- Give a signature to the bound variable, so
- -- that the case expression generated by getTag is
- -- monomorphic. In the push-enter model we get better code.
- get_tag_rhs = L loc $ ExprWithTySig
- (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
- (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
- (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
+ lots_of_constructors = tyConFamilySize tycon > 8
+ -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
+ -- but we don't do vectored returns any more.
- con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
- `nlHsFunTy`
- nlHsTyVar (getRdrName intPrimTyCon)
+ eqns | lots_of_constructors = [get_tag_eqn]
+ | otherwise = map mk_eqn (tyConDataCons tycon)
- lots_of_constructors = tyConFamilySize tycon > 8
- -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
- -- but we don't do vectored returns any more.
+ get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
- mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
- mk_stuff con = ([nlWildConPat con],
- nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
+ 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
+ = ASSERT( null (tyConTyVars tycon) )
+ (mk_FunBind loc rdr_name
[([nlConVarPat intDataCon_RDR [a_RDR]],
- noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
- (nlHsTyVar (getRdrName tycon))))]
+ nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
+ L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
where
+ sig_ty = HsCoreTy $ intTy `mkFunTy` mkParentType tycon
+
rdr_name = tag2con_RDR tycon
genAuxBind loc (GenMaxTag tycon)
- = mkVarBind loc rdr_name
- (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
+ = (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) -- $dT
- = mkVarBind loc (mk_data_type_name tycon)
- ( nlHsVar mkDataType_RDR
- `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
- `nlHsApp` nlList constrs )
+ = (mkHsVarBind loc rdr_name rhs,
+ L loc (TypeSig (L loc rdr_name) sig_ty))
where
- constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
+ 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) -- $cT1 etc
- = mkVarBind loc (mk_constr_name dc)
- (nlHsApps mkConstr_RDR constr_args)
+ = (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
= [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
mk_constr_name :: DataCon -> RdrName -- "$cC"
mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
+
+mkParentType :: TyCon -> Type
+-- Turn the representation tycon of a family into
+-- a use of its family constructor
+mkParentType tc
+ = case tyConFamInst_maybe tc of
+ Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
+ Just (fam_tc,tys) -> mkTyConApp fam_tc tys
\end{code}
%************************************************************************
ToDo: Better SrcLocs.
\begin{code}
-compare_gen_Case ::
- LHsExpr RdrName -- What to do for equality
- -> LHsExpr RdrName -> LHsExpr RdrName
- -> LHsExpr RdrName
-careful_compare_Case :: -- checks for primitive types...
- TyCon -- The tycon we are deriving for
- -> Type
- -> LHsExpr RdrName -- What to do for equality
- -> LHsExpr RdrName -> LHsExpr RdrName
- -> LHsExpr RdrName
-
-cmp_eq_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
-cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
- -- Was: compare_gen_Case cmp_eq_RDR
-
-compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
- = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
-compare_gen_Case eq a b -- General case
- = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
- [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
- mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
- mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
-
-careful_compare_Case tycon ty eq a b
- | not (isUnLiftedType ty)
- = compare_gen_Case eq a b
- | otherwise -- We have to do something special for primitive things...
- = nlHsIf (genOpApp a relevant_lt_op b) -- Test (<) first, not (==), becuase the latter
- ltTag_Expr -- is true less often, so putting it first would
- -- mean more tests (dynamically)
- (nlHsIf (genOpApp a relevant_eq_op b) eq gtTag_Expr)
- where
- relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
- relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
-
-
box_if_necy :: String -- The class involved
-> TyCon -- The tycon involved
-> LHsExpr RdrName -- The argument
where
box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
+---------------------
+primOrdOps :: String -- The class involved
+ -> TyCon -- The tycon involved
+ -> Type -- The type
+ -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
+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 -- The class involved
-> TyCon -- The tycon involved
-> [(Type,a)] -- The table
where
res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
-eq_op_tbl :: [(Type, PrimOp)]
-eq_op_tbl =
- [(charPrimTy, CharEqOp)
- ,(intPrimTy, IntEqOp)
- ,(wordPrimTy, WordEqOp)
- ,(addrPrimTy, AddrEqOp)
- ,(floatPrimTy, FloatEqOp)
- ,(doublePrimTy, DoubleEqOp)
- ]
-
-lt_op_tbl :: [(Type, PrimOp)]
-lt_op_tbl =
- [(charPrimTy, CharLtOp)
- ,(intPrimTy, IntLtOp)
- ,(wordPrimTy, WordLtOp)
- ,(addrPrimTy, AddrLtOp)
- ,(floatPrimTy, FloatLtOp)
- ,(doublePrimTy, DoubleLtOp)
- ]
-
-box_con_tbl :: [(Type, RdrName)]
-box_con_tbl =
- [(charPrimTy, getRdrName charDataCon)
- ,(intPrimTy, getRdrName intDataCon)
- ,(wordPrimTy, wordDataCon_RDR)
- ,(floatPrimTy, getRdrName floatDataCon)
- ,(doublePrimTy, getRdrName doubleDataCon)
- ]
-
-----------------------------------------------------------------------
and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
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 (assoc_ty_id "Eq" tycon eq_op_tbl ty)
- -- we have to do something special for primitive things...
+ eq_op | not (isUnLiftedType ty) = eq_RDR
+ | otherwise = primOpRdrName prim_eq
+ (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
\end{code}
\begin{code}
= nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
[mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
-cmp_tags_Expr :: RdrName -- Comparison op
- -> RdrName -> RdrName -- Things to compare
- -> LHsExpr RdrName -- What to return if true
- -> LHsExpr RdrName -- What to return if false
- -> LHsExpr RdrName
-
-cmp_tags_Expr op a b true_case false_case
- = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
-
enum_from_to_Expr
:: LHsExpr RdrName -> LHsExpr RdrName
-> LHsExpr RdrName
-- impossible_Expr is used in case RHSs that should never happen.
-- We generate these to keep the desugarer from complaining that they *might* happen!
-impossible_Expr :: LHsExpr RdrName
-impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
+error_Expr :: String -> LHsExpr RdrName
+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
-- illegal_Expr is used when signalling error conditions in the RHS of a derived
-- method. It is currently only used by Enum.{succ,pred}
\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,
- cmp_eq_RDR :: RdrName
+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")
bh_RDR = mkVarUnqual (fsLit "b#")
ch_RDR = mkVarUnqual (fsLit "c#")
dh_RDR = mkVarUnqual (fsLit "d#")
-cmp_eq_RDR = mkVarUnqual (fsLit "cmp_eq")
as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
-a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
+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
-b_Expr = nlHsVar b_RDR
+-- b_Expr = nlHsVar b_RDR
c_Expr = nlHsVar c_RDR
f_Expr = nlHsVar f_RDR
z_Expr = nlHsVar z_RDR
primOpRdrName :: PrimOp -> RdrName
primOpRdrName op = getRdrName (primOpId op)
-minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, leInt_RDR,
+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
projects / ghc-hetmet.git / blobdiff