- 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