+
+ 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