Use lengthIs and friends in more places
authorRyan Scott <ryan.gl.scott@gmail.com>
Fri, 2 Jun 2017 17:12:11 +0000 (13:12 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 2 Jun 2017 17:12:13 +0000 (13:12 -0400)
While investigating #12545, I discovered several places in the code
that performed length-checks like so:

```
length ts == 4
```

This is not ideal, since the length of `ts` could be much longer than 4,
and we'd be doing way more work than necessary! There are already a slew
of helper functions in `Util` such as `lengthIs` that are designed to do
this efficiently, so I found every place where they ought to be used and
did just that. I also defined a couple more utility functions for list
length that were common patterns (e.g., `ltLength`).

Test Plan: ./validate

Reviewers: austin, hvr, goldfire, bgamari, simonmar

Reviewed By: bgamari, simonmar

Subscribers: goldfire, rwbarton, thomie

Differential Revision: https://phabricator.haskell.org/D3622

58 files changed:
compiler/basicTypes/DataCon.hs
compiler/basicTypes/Demand.hs
compiler/basicTypes/MkId.hs
compiler/basicTypes/PatSyn.hs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmContFlowOpt.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmTicky.hs
compiler/coreSyn/CoreLint.hs
compiler/coreSyn/CoreUnfold.hs
compiler/coreSyn/CoreUtils.hs
compiler/coreSyn/TrieMap.hs
compiler/deSugar/Check.hs
compiler/deSugar/Coverage.hs
compiler/deSugar/DsExpr.hs
compiler/deSugar/MatchCon.hs
compiler/ghci/ByteCodeGen.hs
compiler/ghci/DebuggerUtils.hs
compiler/hsSyn/Convert.hs
compiler/main/InteractiveEval.hs
compiler/nativeGen/Dwarf/Types.hs
compiler/prelude/PrelInfo.hs
compiler/rename/RnPat.hs
compiler/simplCore/CallArity.hs
compiler/simplCore/FloatIn.hs
compiler/simplCore/OccurAnal.hs
compiler/simplStg/RepType.hs
compiler/simplStg/UnariseStg.hs
compiler/specialise/SpecConstr.hs
compiler/stgSyn/StgLint.hs
compiler/typecheck/FamInst.hs
compiler/typecheck/FunDeps.hs
compiler/typecheck/TcCanonical.hs
compiler/typecheck/TcDeriv.hs
compiler/typecheck/TcDerivInfer.hs
compiler/typecheck/TcErrors.hs
compiler/typecheck/TcFlatten.hs
compiler/typecheck/TcGenDeriv.hs
compiler/typecheck/TcGenGenerics.hs
compiler/typecheck/TcPat.hs
compiler/typecheck/TcSplice.hs
compiler/typecheck/TcTyClsDecls.hs
compiler/typecheck/TcUnify.hs
compiler/typecheck/TcValidity.hs
compiler/types/Class.hs
compiler/types/Coercion.hs
compiler/types/OptCoercion.hs
compiler/types/TyCoRep.hs
compiler/types/TyCon.hs
compiler/types/Type.hs
compiler/utils/ListSetOps.hs
compiler/utils/Util.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
ghc/GHCi/UI/Monad.hs

index 60cffac..cc475e2 100644 (file)
@@ -1130,7 +1130,7 @@ dataConInstArgTys :: DataCon    -- ^ A datacon with no existentials or equality
                   -> [Type]
 dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,
                               dcExTyVars = ex_tvs}) inst_tys
                   -> [Type]
 dataConInstArgTys dc@(MkData {dcUnivTyVars = univ_tvs,
                               dcExTyVars = ex_tvs}) inst_tys
- = ASSERT2( length univ_tvs == length inst_tys
+ = ASSERT2( univ_tvs `equalLength` inst_tys
           , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
    ASSERT2( null ex_tvs, ppr dc )
    map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc)
           , text "dataConInstArgTys" <+> ppr dc $$ ppr univ_tvs $$ ppr inst_tys)
    ASSERT2( null ex_tvs, ppr dc )
    map (substTyWith (binderVars univ_tvs) inst_tys) (dataConRepArgTys dc)
@@ -1147,7 +1147,7 @@ dataConInstOrigArgTys
 dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
                                   dcUnivTyVars = univ_tvs,
                                   dcExTyVars = ex_tvs}) inst_tys
 dataConInstOrigArgTys dc@(MkData {dcOrigArgTys = arg_tys,
                                   dcUnivTyVars = univ_tvs,
                                   dcExTyVars = ex_tvs}) inst_tys
-  = ASSERT2( length tyvars == length inst_tys
+  = ASSERT2( tyvars `equalLength` inst_tys
           , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
     map (substTyWith tyvars inst_tys) arg_tys
   where
           , text "dataConInstOrigArgTys" <+> ppr dc $$ ppr tyvars $$ ppr inst_tys )
     map (substTyWith tyvars inst_tys) arg_tys
   where
index 95c7b79..b6296f4 100644 (file)
@@ -300,7 +300,7 @@ lubStr (SCall _)  (SProd _)    = HeadStr
 lubStr (SProd sx) HyperStr     = SProd sx
 lubStr (SProd _)  HeadStr      = HeadStr
 lubStr (SProd s1) (SProd s2)
 lubStr (SProd sx) HyperStr     = SProd sx
 lubStr (SProd _)  HeadStr      = HeadStr
 lubStr (SProd s1) (SProd s2)
-    | length s1 == length s2   = mkSProd (zipWith lubArgStr s1 s2)
+    | s1 `equalLength` s2      = mkSProd (zipWith lubArgStr s1 s2)
     | otherwise                = HeadStr
 lubStr (SProd _) (SCall _)     = HeadStr
 lubStr HeadStr   _             = HeadStr
     | otherwise                = HeadStr
 lubStr (SProd _) (SCall _)     = HeadStr
 lubStr HeadStr   _             = HeadStr
@@ -325,7 +325,7 @@ bothStr (SCall _)  (SProd _)   = HyperStr  -- Weird
 bothStr (SProd _)  HyperStr    = HyperStr
 bothStr (SProd s1) HeadStr     = SProd s1
 bothStr (SProd s1) (SProd s2)
 bothStr (SProd _)  HyperStr    = HyperStr
 bothStr (SProd s1) HeadStr     = SProd s1
 bothStr (SProd s1) (SProd s2)
-    | length s1 == length s2   = mkSProd (zipWith bothArgStr s1 s2)
+    | s1 `equalLength` s2      = mkSProd (zipWith bothArgStr s1 s2)
     | otherwise                = HyperStr  -- Weird
 bothStr (SProd _) (SCall _)    = HyperStr
 
     | otherwise                = HyperStr  -- Weird
 bothStr (SProd _) (SCall _)    = HyperStr
 
@@ -459,7 +459,7 @@ lubUse (UCall c1 u1) (UCall c2 u2) = UCall (lubCount c1 c2) (lubUse u1 u2)
 lubUse (UCall _ _) _               = Used
 lubUse (UProd ux) UHead            = UProd ux
 lubUse (UProd ux1) (UProd ux2)
 lubUse (UCall _ _) _               = Used
 lubUse (UProd ux) UHead            = UProd ux
 lubUse (UProd ux1) (UProd ux2)
-     | length ux1 == length ux2    = UProd $ zipWith lubArgUse ux1 ux2
+     | ux1 `equalLength` ux2       = UProd $ zipWith lubArgUse ux1 ux2
      | otherwise                   = Used
 lubUse (UProd {}) (UCall {})       = Used
 -- lubUse (UProd {}) Used             = Used
      | otherwise                   = Used
 lubUse (UProd {}) (UCall {})       = Used
 -- lubUse (UProd {}) Used             = Used
@@ -489,7 +489,7 @@ bothUse (UCall _ u1) (UCall _ u2)   = UCall Many (u1 `lubUse` u2)
 bothUse (UCall {}) _                = Used
 bothUse (UProd ux) UHead            = UProd ux
 bothUse (UProd ux1) (UProd ux2)
 bothUse (UCall {}) _                = Used
 bothUse (UProd ux) UHead            = UProd ux
 bothUse (UProd ux1) (UProd ux2)
-      | length ux1 == length ux2    = UProd $ zipWith bothArgUse ux1 ux2
+      | ux1 `equalLength` ux2       = UProd $ zipWith bothArgUse ux1 ux2
       | otherwise                   = Used
 bothUse (UProd {}) (UCall {})       = Used
 -- bothUse (UProd {}) Used             = Used  -- Note [Used should win]
       | otherwise                   = Used
 bothUse (UProd {}) (UCall {})       = Used
 -- bothUse (UProd {}) Used             = Used  -- Note [Used should win]
index e9a57bc..a404e74 100644 (file)
@@ -713,7 +713,7 @@ dataConSrcToImplBang dflags fam_envs arg_ty
       NoSrcUnpack ->
         gopt Opt_UnboxStrictFields dflags
             || (gopt Opt_UnboxSmallStrictFields dflags
       NoSrcUnpack ->
         gopt Opt_UnboxStrictFields dflags
             || (gopt Opt_UnboxSmallStrictFields dflags
-                && length rep_tys <= 1) -- See Note [Unpack one-wide fields]
+                && rep_tys `lengthAtMost` 1) -- See Note [Unpack one-wide fields]
       srcUnpack -> isSrcUnpacked srcUnpack
   = case mb_co of
       Nothing     -> HsUnpack Nothing
       srcUnpack -> isSrcUnpacked srcUnpack
   = case mb_co of
       Nothing     -> HsUnpack Nothing
index 823c838..0e218a3 100644 (file)
@@ -394,7 +394,7 @@ patSynInstArgTys :: PatSyn -> [Type] -> [Type]
 patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                            , psExTyVars = ex_tvs, psArgs = arg_tys })
                  inst_tys
 patSynInstArgTys (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                            , psExTyVars = ex_tvs, psArgs = arg_tys })
                  inst_tys
-  = ASSERT2( length tyvars == length inst_tys
+  = ASSERT2( tyvars `equalLength` inst_tys
           , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
     map (substTyWith tyvars inst_tys) arg_tys
   where
           , text "patSynInstArgTys" <+> ppr name $$ ppr tyvars $$ ppr inst_tys )
     map (substTyWith tyvars inst_tys) arg_tys
   where
@@ -409,7 +409,7 @@ patSynInstResTy :: PatSyn -> [Type] -> Type
 patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                           , psOrigResTy = res_ty })
                 inst_tys
 patSynInstResTy (MkPatSyn { psName = name, psUnivTyVars = univ_tvs
                           , psOrigResTy = res_ty })
                 inst_tys
-  = ASSERT2( length univ_tvs == length inst_tys
+  = ASSERT2( univ_tvs `equalLength` inst_tys
            , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
     substTyWith (binderVars univ_tvs) inst_tys res_ty
 
            , text "patSynInstResTy" <+> ppr name $$ ppr univ_tvs $$ ppr inst_tys )
     substTyWith (binderVars univ_tvs) inst_tys res_ty
 
index 78c604e..a28feb4 100644 (file)
@@ -174,7 +174,7 @@ buildSRT dflags topSRT cafs =
                mkSRT topSRT =
                  do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
                     return (topSRT, localSRTs)
                mkSRT topSRT =
                  do localSRTs <- procpointSRT dflags (lbl topSRT) (elt_map topSRT) cafs
                     return (topSRT, localSRTs)
-           in if length cafs > maxBmpSize dflags then
+           in if cafs `lengthExceeds` maxBmpSize dflags then
                 mkSRT (foldl add_if_missing topSRT cafs)
               else -- make sure all the cafs are near the bottom of the srt
                 mkSRT (add_if_too_far topSRT cafs)
                 mkSRT (foldl add_if_missing topSRT cafs)
               else -- make sure all the cafs are near the bottom of the srt
                 mkSRT (add_if_too_far topSRT cafs)
index d8740df..142de1e 100644 (file)
@@ -15,6 +15,7 @@ import CmmUtils
 import CmmSwitch (mapSwitchTargets)
 import Maybes
 import Panic
 import CmmSwitch (mapSwitchTargets)
 import Maybes
 import Panic
+import Util
 
 import Control.Monad
 import Prelude hiding (succ, unzip, zip)
 
 import Control.Monad
 import Prelude hiding (succ, unzip, zip)
@@ -392,7 +393,7 @@ predMap blocks = foldr add_preds mapEmpty blocks
 -- Removing unreachable blocks
 removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
 removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
 -- Removing unreachable blocks
 removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
 removeUnreachableBlocksProc proc@(CmmProc info lbl live g)
-   | length used_blocks < mapSize (toBlockMap g)
+   | used_blocks `lengthLessThan` mapSize (toBlockMap g)
    = CmmProc info' lbl live g'
    | otherwise
    = proc
    = CmmProc info' lbl live g'
    | otherwise
    = proc
index 37572b7..8eaee79 100644 (file)
@@ -553,7 +553,7 @@ getCallMethod dflags _ id _ n_args v_args _cg_loc
               (Just (self_loop_id, block_id, args))
   | gopt Opt_Loopification dflags
   , id == self_loop_id
               (Just (self_loop_id, block_id, args))
   | gopt Opt_Loopification dflags
   , id == self_loop_id
-  , n_args - v_args == length args
+  , args `lengthIs` (n_args - v_args)
   -- If these patterns match then we know that:
   --   * loopification optimisation is turned on
   --   * function is performing a self-recursive call in a tail position
   -- If these patterns match then we know that:
   --   * loopification optimisation is turned on
   --   * function is performing a self-recursive call in a tail position
index edf97ee..6e6ad7e 100644 (file)
@@ -562,7 +562,7 @@ chooseReturnBndrs bndr (PrimAlt _) _alts
   = assertNonVoidIds [bndr]
 
 chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]
   = assertNonVoidIds [bndr]
 
 chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]
-  = ASSERT2(n == length ids, ppr n $$ ppr ids $$ ppr _bndr)
+  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)
     assertNonVoidIds ids     -- 'bndr' is not assigned!
 
 chooseReturnBndrs bndr (AlgAlt _) _alts
     assertNonVoidIds ids     -- 'bndr' is not assigned!
 
 chooseReturnBndrs bndr (AlgAlt _) _alts
index dc80036..b123420 100644 (file)
@@ -274,7 +274,7 @@ direct_call :: String
             -> CLabel -> RepArity
             -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
 direct_call caller call_conv lbl arity args
             -> CLabel -> RepArity
             -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind
 direct_call caller call_conv lbl arity args
-  | debugIsOn && real_arity > length args  -- Too few args
+  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args
   = do -- Caller should ensure that there enough args!
        pprPanic "direct_call" $
             text caller <+> ppr arity <+>
   = do -- Caller should ensure that there enough args!
        pprPanic "direct_call" $
             text caller <+> ppr arity <+>
index e0a68f6..1ecd72f 100644 (file)
@@ -619,7 +619,7 @@ emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do
 
 emitPrimOp dflags [res] (VecPackOp vcat n w) es = do
     checkVecCompatibility dflags vcat n w
 
 emitPrimOp dflags [res] (VecPackOp vcat n w) es = do
     checkVecCompatibility dflags vcat n w
-    when (length es /= n) $
+    when (es `lengthIsNot` n) $
         panic "emitPrimOp: VecPackOp has wrong number of arguments"
     doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res
   where
         panic "emitPrimOp: VecPackOp has wrong number of arguments"
     doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res
   where
@@ -637,7 +637,7 @@ emitPrimOp dflags [res] (VecPackOp vcat n w) es = do
 
 emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do
     checkVecCompatibility dflags vcat n w
 
 emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do
     checkVecCompatibility dflags vcat n w
-    when (length res /= n) $
+    when (res `lengthIsNot` n) $
         panic "emitPrimOp: VecUnpackOp has wrong number of results"
     doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res
   where
         panic "emitPrimOp: VecUnpackOp has wrong number of results"
     doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res
   where
index 8e4e5ec..8d86e37 100644 (file)
@@ -124,6 +124,7 @@ import Id
 import BasicTypes
 import FastString
 import Outputable
 import BasicTypes
 import FastString
 import Outputable
+import Util
 
 import DynFlags
 
 
 import DynFlags
 
@@ -381,7 +382,7 @@ tickyUnboxedTupleReturn arity
 -- Ticks at a *call site*:
 tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
 tickyDirectCall arity args
 -- Ticks at a *call site*:
 tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
 tickyDirectCall arity args
-  | arity == length args = tickyKnownCallExact
+  | args `lengthIs` arity = tickyKnownCallExact
   | otherwise = do tickyKnownCallExtraArgs
                    tickySlowCallPat (map argPrimRep (drop arity args))
 
   | otherwise = do tickyKnownCallExtraArgs
                    tickySlowCallPat (map argPrimRep (drop arity args))
 
@@ -412,7 +413,7 @@ tickySlowCallPat :: [PrimRep] -> FCode ()
 tickySlowCallPat args = ifTicky $
   let argReps = map toArgRep args
       (_, n_matched) = slowCallPattern argReps
 tickySlowCallPat args = ifTicky $
   let argReps = map toArgRep args
       (_, n_matched) = slowCallPattern argReps
-  in if n_matched > 0 && n_matched == length args
+  in if n_matched > 0 && args `lengthIs` n_matched
      then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
      else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
 
      then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
      else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
 
index 0888afb..2be1020 100644 (file)
@@ -566,7 +566,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
        -- Check that the binder's arity is within the bounds imposed by
        -- the type and the strictness signature. See Note [exprArity invariant]
        -- and Note [Trimming arity]
        -- Check that the binder's arity is within the bounds imposed by
        -- the type and the strictness signature. See Note [exprArity invariant]
        -- and Note [Trimming arity]
-       ; checkL (idArity binder <= length (typeArity (idType binder)))
+       ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder)
            (text "idArity" <+> ppr (idArity binder) <+>
            text "exceeds typeArity" <+>
            ppr (length (typeArity (idType binder))) <> colon <+>
            (text "idArity" <+> ppr (idArity binder) <+>
            text "exceeds typeArity" <+>
            ppr (length (typeArity (idType binder))) <> colon <+>
@@ -574,7 +574,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 
        ; case splitStrictSig (idStrictness binder) of
            (demands, result_info) | isBotRes result_info ->
 
        ; case splitStrictSig (idStrictness binder) of
            (demands, result_info) | isBotRes result_info ->
-             checkL (idArity binder <= length demands)
+             checkL (demands `lengthAtLeast` idArity binder)
                (text "idArity" <+> ppr (idArity binder) <+>
                text "exceeds arity imposed by the strictness signature" <+>
                ppr (idStrictness binder) <> colon <+>
                (text "idArity" <+> ppr (idArity binder) <+>
                text "exceeds arity imposed by the strictness signature" <+>
                ppr (idStrictness binder) <> colon <+>
@@ -1288,12 +1288,12 @@ lintType ty@(TyConApp tc tys)
   -- should be represented with the FunTy constructor. See Note [Linting
   -- function types] and Note [Representation of function types].
   | isFunTyCon tc
   -- should be represented with the FunTy constructor. See Note [Linting
   -- function types] and Note [Representation of function types].
   | isFunTyCon tc
-  , length tys == 4
+  , tys `lengthIs` 4
   = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))
 
   | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
        -- Also type synonyms and type families
   = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))
 
   | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc
        -- Also type synonyms and type families
-  , length tys < tyConArity tc
+  , tys `lengthLessThan` tyConArity tc
   = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
 
   | otherwise
   = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))
 
   | otherwise
@@ -1715,7 +1715,7 @@ lintCoercion the_co@(NthCo n co)
              , isInjectiveTyCon tc_s r
                  -- see Note [NthCo and newtypes] in TyCoRep
              , tys_s `equalLength` tys_t
              , isInjectiveTyCon tc_s r
                  -- see Note [NthCo and newtypes] in TyCoRep
              , tys_s `equalLength` tys_t
-             , n < length tys_s
+             , tys_s `lengthExceeds` n
              -> return (ks, kt, ts, tt, tr)
              where
                ts = getNth tys_s n
              -> return (ks, kt, ts, tt, tr)
              where
                ts = getNth tys_s n
@@ -1766,7 +1766,7 @@ lintCoercion co@(AxiomInstCo con ind cos)
                         , cab_roles = roles
                         , cab_lhs   = lhs
                         , cab_rhs   = rhs } = coAxiomNthBranch con ind
                         , cab_roles = roles
                         , cab_lhs   = lhs
                         , cab_rhs   = rhs } = coAxiomNthBranch con ind
-       ; unless (length ktvs + length cvs == length cos) $
+       ; unless (cos `equalLength` (ktvs ++ cvs)) $
            bad_ax (text "lengths")
        ; subst <- getTCvSubst
        ; let empty_subst = zapTCvSubst subst
            bad_ax (text "lengths")
        ; subst <- getTCvSubst
        ; let empty_subst = zapTCvSubst subst
index 811ddad..cedc78f 100644 (file)
@@ -578,7 +578,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
                                 foldr (addAltSize . size_up_alt) case_size alts
       where
           case_size
                                 foldr (addAltSize . size_up_alt) case_size alts
       where
           case_size
-           | is_inline_scrut e, not (lengthExceeds alts 1)  = sizeN (-10)
+           | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)
            | otherwise = sizeZero
                 -- Normally we don't charge for the case itself, but
                 -- we charge one per alternative (see size_up_alt,
            | otherwise = sizeZero
                 -- Normally we don't charge for the case itself, but
                 -- we charge one per alternative (see size_up_alt,
@@ -593,7 +593,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
                 --      case touch# x# of _ -> ...  should cost 0
                 -- (see #4978)
                 --
                 --      case touch# x# of _ -> ...  should cost 0
                 -- (see #4978)
                 --
-                -- I would like to not have the "not (lengthExceeds alts 1)"
+                -- I would like to not have the "lengthAtMost alts 1"
                 -- condition above, but without that some programs got worse
                 -- (spectral/hartel/event and spectral/para).  I don't fully
                 -- understand why. (SDM 24/5/11)
                 -- condition above, but without that some programs got worse
                 -- (spectral/hartel/event and spectral/para).  I don't fully
                 -- understand why. (SDM 24/5/11)
index cc2d172..b839923 100644 (file)
@@ -1391,7 +1391,7 @@ altsAreExhaustive ((con1,_,_) : alts)
   = case con1 of
       DEFAULT   -> True
       LitAlt {} -> False
   = case con1 of
       DEFAULT   -> True
       LitAlt {} -> False
-      DataAlt c -> 1 + length alts == tyConFamilySize (dataConTyCon c)
+      DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1)
       -- It is possible to have an exhaustive case that does not
       -- enumerate all constructors, notably in a GADT match, but
       -- we behave conservatively here -- I don't think it's important
       -- It is possible to have an exhaustive case that does not
       -- enumerate all constructors, notably in a GADT match, but
       -- we behave conservatively here -- I don't think it's important
@@ -1783,7 +1783,7 @@ eqExpr in_scope e1 e2
       && go (rnBndr2 env v1 v2) e1 e2
 
     go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)
       && go (rnBndr2 env v1 v2) e1 e2
 
     go env (Let (Rec ps1) e1) (Let (Rec ps2) e2)
-      = length ps1 == length ps2
+      = equalLength ps1 ps2
       && all2 (go env') rs1 rs2 && go env' e1 e2
       where
         (bs1,rs1) = unzip ps1
       && all2 (go env') rs1 rs2 && go env' e1 e2
       where
         (bs1,rs1) = unzip ps1
@@ -1838,7 +1838,7 @@ diffExpr top env (Let bs1 e1) (Let bs2 e2)
   = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])
     in ds ++ diffExpr top env' e1 e2
 diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
   = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])
     in ds ++ diffExpr top env' e1 e2
 diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)
-  | length a1 == length a2 && not (null a1) || eqTypeX env t1 t2
+  | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2
     -- See Note [Empty case alternatives] in TrieMap
   = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)
   where env' = rnBndr2 env b1 b2
     -- See Note [Empty case alternatives] in TrieMap
   = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)
   where env' = rnBndr2 env b1 b2
@@ -1933,7 +1933,7 @@ diffUnfold _   BootUnfolding  BootUnfolding               = []
 diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []
 diffUnfold env (DFunUnfolding bs1 c1 a1)
                (DFunUnfolding bs2 c2 a2)
 diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []
 diffUnfold env (DFunUnfolding bs1 c1 a1)
                (DFunUnfolding bs2 c2 a2)
-  | c1 == c2 && length bs1 == length bs2
+  | c1 == c2 && equalLength bs1 bs2
   = concatMap (uncurry (diffExpr False env')) (zip a1 a2)
   where env' = rnBndrs2 env bs1 bs2
 diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
   = concatMap (uncurry (diffExpr False env')) (zip a1 a2)
   where env' = rnBndrs2 env bs1 bs2
 diffUnfold env (CoreUnfolding t1 _ _ v1 cl1 wf1 x1 g1)
index 9058d03..a6b9db4 100644 (file)
@@ -41,6 +41,7 @@ import Var
 import UniqDFM
 import Unique( Unique )
 import FastString(FastString)
 import UniqDFM
 import Unique( Unique )
 import FastString(FastString)
+import Util
 
 import qualified Data.Map    as Map
 import qualified Data.IntMap as IntMap
 
 import qualified Data.Map    as Map
 import qualified Data.IntMap as IntMap
@@ -526,7 +527,7 @@ instance Eq (DeBruijn CoreExpr) where
       && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2
 
     go (Let (Rec ps1) e1) (Let (Rec ps2) e2)
       && D (extendCME env1 v1) e1 == D (extendCME env2 v2) e2
 
     go (Let (Rec ps1) e1) (Let (Rec ps2) e2)
-      = length ps1 == length ps2
+      = equalLength ps1 ps2
       && D env1' rs1 == D env2' rs2
       && D env1' e1  == D env2' e2
       where
       && D env1' rs1 == D env2' rs2
       && D env1' e1  == D env2' e2
       where
index 4b01aac..8234ccc 100644 (file)
@@ -112,13 +112,9 @@ getResult ls = do
       | null us && null rs && null is = old
       | otherwise =
         let PmResult prov' rs' (UncoveredPatterns us') is' = new
       | null us && null rs && null is = old
       | otherwise =
         let PmResult prov' rs' (UncoveredPatterns us') is' = new
-            lr  = length rs
-            lr' = length rs'
-            li  = length is
-            li' = length is'
-        in case compare (length us) (length us')
-                `mappend` (compare li li')
-                `mappend` (compare lr lr')
+        in case compareLength us us'
+                `mappend` (compareLength is is')
+                `mappend` (compareLength rs rs')
                 `mappend` (compare prov prov') of
               GT  -> Just new
               EQ  -> Just new
                 `mappend` (compare prov prov') of
               GT  -> Just new
               EQ  -> Just new
@@ -709,7 +705,7 @@ translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))
     -- Generate a simple constructor pattern and make up fresh variables for
     -- the rest of the fields
   | matched_lbls `subsetOf` orig_lbls
     -- Generate a simple constructor pattern and make up fresh variables for
     -- the rest of the fields
   | matched_lbls `subsetOf` orig_lbls
-  = ASSERT(length orig_lbls == length arg_tys)
+  = ASSERT(orig_lbls `equalLength` arg_tys)
       let translateOne (lbl, ty) = case lookup lbl matched_pats of
             Just p  -> translatePat fam_insts p
             Nothing -> mkPmVars [ty]
       let translateOne (lbl, ty) = case lookup lbl matched_pats of
             Just p  -> translatePat fam_insts p
             Nothing -> mkPmVars [ty]
index 2421333..92002bf 100644 (file)
@@ -187,7 +187,7 @@ writeMixEntries dflags mod count entries filename
         modTime <- getModificationUTCTime filename
         let entries' = [ (hpcPos, box)
                        | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
         modTime <- getModificationUTCTime filename
         let entries' = [ (hpcPos, box)
                        | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ]
-        when (length entries' /= count) $ do
+        when (entries' `lengthIsNot` count) $ do
           panic "the number of .mix entries are inconsistent"
         let hashNo = mixHash filename modTime tabStop entries'
         mixCreate hpc_mod_dir mod_name
           panic "the number of .mix entries are inconsistent"
         let hashNo = mixHash filename modTime tabStop entries'
         mixCreate hpc_mod_dir mod_name
index 2a41ede..cfd9996 100644 (file)
@@ -853,9 +853,9 @@ dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id]
 dsExplicitList elt_ty Nothing xs
   = do { dflags <- getDynFlags
        ; xs' <- mapM dsLExprNoLP xs
 dsExplicitList elt_ty Nothing xs
   = do { dflags <- getDynFlags
        ; xs' <- mapM dsLExprNoLP xs
-       ; if length xs' > maxBuildLength
+       ; if xs' `lengthExceeds` maxBuildLength
                 -- Don't generate builds if the list is very long.
                 -- Don't generate builds if the list is very long.
-         || length xs' == 0
+         || null xs'
                 -- Don't generate builds when the [] constructor will do
          || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
                 -- Don't generate a build if there are no rules to eliminate it!
                 -- Don't generate builds when the [] constructor will do
          || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off
                 -- Don't generate a build if there are no rules to eliminate it!
index 0e1aa80..47d1276 100644 (file)
@@ -177,7 +177,7 @@ matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor
       | RecCon flds <- arg_pats
       , let rpats = rec_flds flds
       , not (null rpats)     -- Treated specially; cf conArgPats
       | RecCon flds <- arg_pats
       , let rpats = rec_flds flds
       , not (null rpats)     -- Treated specially; cf conArgPats
-      = ASSERT2( length fields1 == length arg_vars,
+      = ASSERT2( fields1 `equalLength` arg_vars,
                  ppr con1 $$ ppr fields1 $$ ppr arg_vars )
         map lookup_fld rpats
       | otherwise
                  ppr con1 $$ ppr fields1 $$ ppr arg_vars )
         map lookup_fld rpats
       | otherwise
index 0033df1..7ad51a7 100644 (file)
@@ -600,7 +600,7 @@ schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1, bind2], rhs)])
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
    | isUnboxedTupleCon dc
 
 schemeE d s p (AnnCase scrut bndr _ [(DataAlt dc, [bind1], rhs)])
    | isUnboxedTupleCon dc
-   , length (typePrimRep (idType bndr)) <= 1 -- handles unit tuples
+   , typePrimRep (idType bndr) `lengthAtMost` 1 -- handles unit tuples
    = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
 
 schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
    = doCase d s p scrut bind1 [(DEFAULT, [], rhs)] (Just bndr)
 
 schemeE d s p (AnnCase scrut bndr _ alt@[(DEFAULT, [], _)])
@@ -729,7 +729,7 @@ mkConAppCode _ _ _ con []       -- Nullary constructor
         -- copy of this constructor, use the single shared version.
 
 mkConAppCode orig_d _ p con args_r_to_l
         -- copy of this constructor, use the single shared version.
 
 mkConAppCode orig_d _ p con args_r_to_l
-  = ASSERT( dataConRepArity con == length args_r_to_l )
+  = ASSERT( args_r_to_l `lengthIs` dataConRepArity con )
     do_pushery orig_d (non_ptr_args ++ ptr_args)
  where
         -- The args are already in reverse order, which is the way PACK
     do_pushery orig_d (non_ptr_args ++ ptr_args)
  where
         -- The args are already in reverse order, which is the way PACK
index 096b809..9e3d56e 100644 (file)
@@ -110,14 +110,14 @@ dataConInfoPtrToName x = do
    -- Warning: this code assumes that the string is well formed.
    parse :: [Word8] -> ([Word8], [Word8], [Word8])
    parse input
    -- Warning: this code assumes that the string is well formed.
    parse :: [Word8] -> ([Word8], [Word8], [Word8])
    parse input
-      = ASSERT(all (>0) (map length [pkg, mod, occ])) (pkg, mod, occ)
+      = ASSERT(all (`lengthExceeds` 0) ([pkg, mod, occ])) (pkg, mod, occ)
       where
       dot = fromIntegral (ord '.')
       (pkg, rest1) = break (== fromIntegral (ord ':')) input
       (mod, occ)
          = (concat $ intersperse [dot] $ reverse modWords, occWord)
          where
       where
       dot = fromIntegral (ord '.')
       (pkg, rest1) = break (== fromIntegral (ord ':')) input
       (mod, occ)
          = (concat $ intersperse [dot] $ reverse modWords, occWord)
          where
-         (modWords, occWord) = ASSERT(length rest1 > 0) (parseModOcc [] (tail rest1))
+         (modWords, occWord) = ASSERT(rest1 `lengthExceeds` 0) (parseModOcc [] (tail rest1))
       parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
       -- We only look for dots if str could start with a module name,
       -- i.e. if it starts with an upper case character.
       parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
       -- We only look for dots if str could start with a module name,
       -- i.e. if it starts with an upper case character.
index 5f67515..e64c4ea 100644 (file)
@@ -1183,7 +1183,7 @@ cvtTypeKind ty_str ty
   = do { (head_ty, tys') <- split_ty_app ty
        ; case head_ty of
            TupleT n
   = do { (head_ty, tys') <- split_ty_app ty
        ; case head_ty of
            TupleT n
-             | length tys' == n         -- Saturated
+             | tys' `lengthIs` n         -- Saturated
              -> if n==1 then return (head tys') -- Singleton tuples treated
                                                 -- like nothing (ie just parens)
                         else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
              -> if n==1 then return (head tys') -- Singleton tuples treated
                                                 -- like nothing (ie just parens)
                         else returnL (HsTupleTy HsBoxedOrConstraintTuple tys')
@@ -1193,7 +1193,7 @@ cvtTypeKind ty_str ty
              -> mk_apps (HsTyVar NotPromoted
                                (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
            UnboxedTupleT n
              -> mk_apps (HsTyVar NotPromoted
                                (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
            UnboxedTupleT n
-             | length tys' == n         -- Saturated
+             | tys' `lengthIs` n         -- Saturated
              -> returnL (HsTupleTy HsUnboxedTuple tys')
              | otherwise
              -> mk_apps (HsTyVar NotPromoted
              -> returnL (HsTupleTy HsUnboxedTuple tys')
              | otherwise
              -> mk_apps (HsTyVar NotPromoted
@@ -1204,7 +1204,7 @@ cvtTypeKind ty_str ty
                    vcat [ text "Illegal sum arity:" <+> text (show n)
                         , nest 2 $
                             text "Sums must have an arity of at least 2" ]
                    vcat [ text "Illegal sum arity:" <+> text (show n)
                         , nest 2 $
                             text "Sums must have an arity of at least 2" ]
-             | length tys' == n -- Saturated
+             | tys' `lengthIs` n -- Saturated
              -> returnL (HsSumTy tys')
              | otherwise
              -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
              -> returnL (HsSumTy tys')
              | otherwise
              -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n))))
index b56d8d6..8b5a6b6 100644 (file)
@@ -80,6 +80,7 @@ import RtClosureInspect
 import Outputable
 import FastString
 import Bag
 import Outputable
 import FastString
 import Bag
+import Util
 import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
 import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
 
 import qualified Lexer (P (..), ParseResult(..), unP, mkPState)
 import qualified Parser (parseStmt, parseModule, parseDeclaration, parseImport)
 
@@ -400,7 +401,7 @@ moveHist fn = do
             history = resumeHistory r
             new_ix = fn ix
         --
             history = resumeHistory r
             new_ix = fn ix
         --
-        when (new_ix > length history) $ liftIO $
+        when (history `lengthLessThan` new_ix) $ liftIO $
            throwGhcExceptionIO (ProgramError "no more logged breakpoints")
         when (new_ix < 0) $ liftIO $
            throwGhcExceptionIO (ProgramError "already at the beginning of the history")
            throwGhcExceptionIO (ProgramError "no more logged breakpoints")
         when (new_ix < 0) $ liftIO $
            throwGhcExceptionIO (ProgramError "already at the beginning of the history")
index d4d8e24..bc278b1 100644 (file)
@@ -32,6 +32,7 @@ import Platform
 import Unique
 import Reg
 import SrcLoc
 import Unique
 import Reg
 import SrcLoc
+import Util
 
 import Dwarf.Constants
 
 
 import Dwarf.Constants
 
@@ -577,7 +578,7 @@ pprString' str = text "\t.asciz \"" <> str <> char '"'
 pprString :: String -> SDoc
 pprString str
   = pprString' $ hcat $ map escapeChar $
 pprString :: String -> SDoc
 pprString str
   = pprString' $ hcat $ map escapeChar $
-    if utf8EncodedLength str == length str
+    if str `lengthIs` utf8EncodedLength str
     then str
     else map (chr . fromIntegral) $ bytesFS $ mkFastString str
 
     then str
     else map (chr . fromIntegral) $ bytesFS $ mkFastString str
 
index 471b61e..8e26d80 100644 (file)
@@ -170,7 +170,7 @@ knownKeyNamesOkay all_names
   where
     namesEnv      = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
                           emptyUFM all_names
   where
     namesEnv      = foldl (\m n -> extendNameEnv_Acc (:) singleton m n n)
                           emptyUFM all_names
-    badNamesEnv   = filterNameEnv (\ns -> length ns > 1) namesEnv
+    badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv
     badNamesPairs = nonDetUFMToList badNamesEnv
       -- It's OK to use nonDetUFMToList here because the ordering only affects
       -- the message when we get a panic
     badNamesPairs = nonDetUFMToList badNamesEnv
       -- It's OK to use nonDetUFMToList here because the ordering only affects
       -- the message when we get a panic
index 7c4663c..30dd61b 100644 (file)
@@ -625,7 +625,7 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })
     rn_dotdot (Just {}) Nothing _flds   -- Constructor out of scope
       = return []
     rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
     rn_dotdot (Just {}) Nothing _flds   -- Constructor out of scope
       = return []
     rn_dotdot (Just n) (Just con) flds -- ".." on record construction / pat match
-      = ASSERT( n == length flds )
+      = ASSERT( flds `lengthIs` n )
         do { loc <- getSrcSpanM -- Rather approximate
            ; dd_flag <- xoptM LangExt.RecordWildCards
            ; checkErr dd_flag (needFlagDotDot ctxt)
         do { loc <- getSrcSpanM -- Rather approximate
            ; dd_flag <- xoptM LangExt.RecordWildCards
            ; checkErr dd_flag (needFlagDotDot ctxt)
index e23314b..0cf0c2f 100644 (file)
@@ -18,6 +18,7 @@ import CoreArity ( typeArity )
 import CoreUtils ( exprIsCheap, exprIsTrivial )
 import UnVarGraph
 import Demand
 import CoreUtils ( exprIsCheap, exprIsTrivial )
 import UnVarGraph
 import Demand
+import Util
 
 import Control.Arrow ( first, second )
 
 
 import Control.Arrow ( first, second )
 
@@ -671,11 +672,11 @@ callArityRecEnv any_boring ae_rhss ae_body
 
     cross_calls
         -- See Note [Taking boring variables into account]
 
     cross_calls
         -- See Note [Taking boring variables into account]
-        | any_boring          = completeGraph (domRes ae_combined)
+        | any_boring               = completeGraph (domRes ae_combined)
         -- Also, calculating cross_calls is expensive. Simply be conservative
         -- if the mutually recursive group becomes too large.
         -- Also, calculating cross_calls is expensive. Simply be conservative
         -- if the mutually recursive group becomes too large.
-        | length ae_rhss > 25 = completeGraph (domRes ae_combined)
-        | otherwise           = unionUnVarGraphs $ map cross_call ae_rhss
+        | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)
+        | otherwise                = unionUnVarGraphs $ map cross_call ae_rhss
     cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v
       where
         is_thunk = idCallArity v == 0
     cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v
       where
         is_thunk = idCallArity v == 0
index 02a7f74..3e44e81 100644 (file)
@@ -665,7 +665,7 @@ sepBindsByDropPoint dflags is_case drop_pts floaters
   = [] : [[] | _ <- drop_pts]
 
   | otherwise
   = [] : [[] | _ <- drop_pts]
 
   | otherwise
-  = ASSERT( length drop_pts >= 2 )
+  = ASSERT( drop_pts `lengthAtLeast` 2 )
     go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
   where
     n_alts = length drop_pts
     go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))
   where
     n_alts = length drop_pts
index 98c81ce..5dd30aa 100644 (file)
@@ -2572,7 +2572,7 @@ adjustRhsUsage mb_join_arity rec_flag bndrs usage
                  Nothing            -> all isOneShotBndr bndrs
 
     exact_join = case mb_join_arity of
                  Nothing            -> all isOneShotBndr bndrs
 
     exact_join = case mb_join_arity of
-                   Just join_arity -> join_arity == length bndrs
+                   Just join_arity -> bndrs `lengthIs` join_arity
                    _               -> False
 
 type IdWithOccInfo = Id
                    _               -> False
 
 type IdWithOccInfo = Id
@@ -2718,7 +2718,7 @@ decideJoinPointHood NotTopLevel usage bndrs
 
     ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans
     ok_rule join_arity (Rule { ru_args = args })
 
     ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans
     ok_rule join_arity (Rule { ru_args = args })
-      = length args == join_arity
+      = args `lengthIs` join_arity
         -- Invariant 1 as applied to LHSes of rules
 
 willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
         -- Invariant 1 as applied to LHSes of rules
 
 willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity
index 91e4285..2acc815 100644 (file)
@@ -155,7 +155,7 @@ ubxSumRepType constrs0
   -- has at least two disjuncts. But it could happen if a user writes, e.g.,
   -- forall (a :: TYPE (SumRep [IntRep])). ...
   -- which could never be instantiated. We still don't want to panic.
   -- has at least two disjuncts. But it could happen if a user writes, e.g.,
   -- forall (a :: TYPE (SumRep [IntRep])). ...
   -- which could never be instantiated. We still don't want to panic.
-  | length constrs0 < 2
+  | constrs0 `lengthLessThan` 2
   = [WordSlot]
 
   | otherwise
   = [WordSlot]
 
   | otherwise
index 3f67bc2..2e8fbda 100644 (file)
@@ -420,7 +420,7 @@ unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]
 unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
   | isUnboxedTupleBndr bndr
   = do (rho', ys1) <- unariseConArgBinders rho ys
 unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]
   | isUnboxedTupleBndr bndr
   = do (rho', ys1) <- unariseConArgBinders rho ys
-       MASSERT(n == length ys1)
+       MASSERT(ys1 `lengthIs` n)
        let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
        e' <- unariseExpr rho'' e
        return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
        let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))
        e' <- unariseExpr rho'' e
        return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]
index 39ec7e6..e5af0b8 100644 (file)
@@ -1984,7 +1984,7 @@ callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
         --      over the following term variables
         -- The [CoreExpr] are the argument patterns for the rule
 callToPats env bndr_occs (Call _ args con_env)
         --      over the following term variables
         -- The [CoreExpr] are the argument patterns for the rule
 callToPats env bndr_occs (Call _ args con_env)
-  | length args < length bndr_occs      -- Check saturated
+  | args `ltLength` bndr_occs      -- Check saturated
   = return Nothing
   | otherwise
   = do  { let in_scope      = substInScope (sc_subst env)
   = return Nothing
   | otherwise
   = do  { let in_scope      = substInScope (sc_subst env)
index 02d989c..7a1ed4d 100644 (file)
@@ -249,7 +249,7 @@ lintAlt scrut_ty (DataAlt con, args, rhs) = do
                 -- This does not work for existential constructors
 
          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
                 -- This does not work for existential constructors
 
          checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con)
-         checkL (length args == dataConRepArity con) (mkAlgAltMsg3 con args)
+         checkL (args `lengthIs` dataConRepArity con) (mkAlgAltMsg3 con args)
          when (isVanillaDataCon con) $
            mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
          return ()
          when (isVanillaDataCon con) $
            mapM_ check (zipEqual "lintAlgAlt:stg" arg_tys args)
          return ()
@@ -398,7 +398,7 @@ checkFunApp fun_ty arg_tys msg
 
       | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
       , isNewTyCon tc
 
       | Just (tc,tc_args) <- splitTyConApp_maybe fun_ty
       , isNewTyCon tc
-      = if length tc_args < tyConArity tc
+      = if tc_args `lengthLessThan` tyConArity tc
         then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
              (Nothing, Nothing)   -- This is odd, but I've seen it
         else cfa False (newTyConInstRhs tc tc_args) arg_tys
         then WARN( True, text "cfa: unsaturated newtype" <+> ppr fun_ty $$ msg )
              (Nothing, Nothing)   -- This is odd, but I've seen it
         else cfa False (newTyConInstRhs tc tc_args) arg_tys
index f69e412..cabfb33 100644 (file)
@@ -789,7 +789,7 @@ isTFHeaded ty | Just ty' <- coreView ty
               = isTFHeaded ty'
 isTFHeaded ty | (TyConApp tc args) <- ty
               , isTypeFamilyTyCon tc
               = isTFHeaded ty'
 isTFHeaded ty | (TyConApp tc args) <- ty
               , isTypeFamilyTyCon tc
-              = tyConArity tc == length args
+              = args `lengthIs` tyConArity tc
 isTFHeaded _  = False
 
 
 isTFHeaded _  = False
 
 
index fff8979..789254d 100644 (file)
@@ -255,8 +255,8 @@ improveClsFD clas_tvs fd
   = []          -- Filter out ones that can't possibly match,
 
   | otherwise
   = []          -- Filter out ones that can't possibly match,
 
   | otherwise
-  = ASSERT2( length tys_inst == length tys_actual     &&
-             length tys_inst == length clas_tvs
+  = ASSERT2( equalLength tys_inst tys_actual &&
+             equalLength tys_inst clas_tvs
             , ppr tys_inst <+> ppr tys_actual )
 
     case tcMatchTyKis ltys1 ltys2 of
             , ppr tys_inst <+> ppr tys_actual )
 
     case tcMatchTyKis ltys1 ltys2 of
index 77bf63d..ff00d42 100644 (file)
@@ -917,7 +917,7 @@ canTyConApp :: CtEvidence -> EqRel
 -- See Note [Decomposing TyConApps]
 canTyConApp ev eq_rel tc1 tys1 tc2 tys2
   | tc1 == tc2
 -- See Note [Decomposing TyConApps]
 canTyConApp ev eq_rel tc1 tys1 tc2 tys2
   | tc1 == tc2
-  , length tys1 == length tys2
+  , tys1 `equalLength` tys2
   = do { inerts <- getTcSInerts
        ; if can_decompose inerts
          then do { traceTcS "canTyConApp"
   = do { inerts <- getTcSInerts
        ; if can_decompose inerts
          then do { traceTcS "canTyConApp"
index 8076115..5bdfae7 100644 (file)
@@ -613,7 +613,7 @@ deriveTyData tvs tc tc_args deriv_strat deriv_pred
                 -- Typeable is special, because Typeable :: forall k. k -> Constraint
                 -- so the argument kind 'k' is not decomposable by splitKindFunTys
                 -- as is the case for all other derivable type classes
                 -- Typeable is special, because Typeable :: forall k. k -> Constraint
                 -- so the argument kind 'k' is not decomposable by splitKindFunTys
                 -- as is the case for all other derivable type classes
-        ; when (length cls_arg_kinds /= 1) $
+        ; when (cls_arg_kinds `lengthIsNot` 1) $
             failWithTc (nonUnaryErr deriv_pred)
         ; let [cls_arg_kind] = cls_arg_kinds
         ; if className cls == typeableClassName
             failWithTc (nonUnaryErr deriv_pred)
         ; let [cls_arg_kind] = cls_arg_kinds
         ; if className cls == typeableClassName
@@ -1101,7 +1101,7 @@ mkNewTypeEqn dflags overlap_mode tvs
              cls cls_tys tycon tc_args rep_tycon rep_tc_args
              mtheta deriv_strat
 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
              cls cls_tys tycon tc_args rep_tycon rep_tc_args
              mtheta deriv_strat
 -- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...
-  = ASSERT( length cls_tys + 1 == classArity cls )
+  = ASSERT( cls_tys `lengthIs` (classArity cls - 1) )
     case deriv_strat of
       Just StockStrategy    -> mk_eqn_stock dflags mtheta cls cls_tys rep_tycon
                                  go_for_it_other bale_out
     case deriv_strat of
       Just StockStrategy    -> mk_eqn_stock dflags mtheta cls cls_tys rep_tycon
                                  go_for_it_other bale_out
@@ -1302,7 +1302,7 @@ mkNewTypeEqn dflags overlap_mode tvs
            && isNothing at_without_last_cls_tv
 
         -- Check that eta reduction is OK
            && isNothing at_without_last_cls_tv
 
         -- Check that eta reduction is OK
-        eta_ok = nt_eta_arity <= length rep_tc_args
+        eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity
                 -- The newtype can be eta-reduced to match the number
                 --     of type argument actually supplied
                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
                 -- The newtype can be eta-reduced to match the number
                 --     of type argument actually supplied
                 --        newtype T a b = MkT (S [a] b) deriving( Monad )
index 93dcf43..02c0103 100644 (file)
@@ -67,12 +67,12 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType
 inferConstraints tvs main_cls cls_tys inst_ty
                  rep_tc rep_tc_args
                  mechanism
 inferConstraints tvs main_cls cls_tys inst_ty
                  rep_tc rep_tc_args
                  mechanism
-  | is_generic && not is_anyclass     -- Generic constraints are easy
+  | is_generic && not is_anyclass          -- Generic constraints are easy
   = return ([], tvs, inst_tys)
 
   = return ([], tvs, inst_tys)
 
-  | is_generic1 && not is_anyclass    -- Generic1 needs Functor
-  = ASSERT( length rep_tc_tvs > 0 )   -- See Note [Getting base classes]
-    ASSERT( length cls_tys   == 1 )   -- Generic1 has a single kind variable
+  | is_generic1 && not is_anyclass         -- Generic1 needs Functor
+  = ASSERT( rep_tc_tvs `lengthExceeds` 0 ) -- See Note [Getting base classes]
+    ASSERT( cls_tys `lengthIs` 1 )         -- Generic1 has a single kind variable
     do { functorClass <- tcLookupClass functorClassName
        ; con_arg_constraints (get_gen1_constraints functorClass) }
 
     do { functorClass <- tcLookupClass functorClassName
        ; con_arg_constraints (get_gen1_constraints functorClass) }
 
index 324391f..4411d6a 100644 (file)
@@ -1548,7 +1548,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2
 
     has_unknown_roles ty
       | Just (tc, tys) <- tcSplitTyConApp_maybe ty
 
     has_unknown_roles ty
       | Just (tc, tys) <- tcSplitTyConApp_maybe ty
-      = length tys >= tyConArity tc  -- oversaturated tycon
+      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon
       | Just (s, _) <- tcSplitAppTy_maybe ty
       = has_unknown_roles s
       | isTyVarTy ty
       | Just (s, _) <- tcSplitAppTy_maybe ty
       = has_unknown_roles s
       | isTyVarTy ty
@@ -2503,7 +2503,7 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
     -- Overlap error because of Safe Haskell (first
     -- match should be the most specific match)
     safe_haskell_msg
     -- Overlap error because of Safe Haskell (first
     -- match should be the most specific match)
     safe_haskell_msg
-     = ASSERT( length matches == 1 && not (null unsafe_ispecs) )
+     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )
        vcat [ addArising orig (text "Unsafe overlapping instances for"
                        <+> pprType (mkClassPred clas tys))
             , sep [text "The matching instance is:",
        vcat [ addArising orig (text "Unsafe overlapping instances for"
                        <+> pprType (mkClassPred clas tys))
             , sep [text "The matching instance is:",
@@ -2706,7 +2706,7 @@ pprPotentials dflags sty herald insts
                      <+> text "involving out-of-scope types")
            2 (ppWhen show_potentials (pprInstances not_in_scope))
 
                      <+> text "involving out-of-scope types")
            2 (ppWhen show_potentials (pprInstances not_in_scope))
 
-    flag_hint = ppUnless (show_potentials || length show_these == length insts) $
+    flag_hint = ppUnless (show_potentials || equalLength show_these insts) $
                 text "(use -fprint-potential-instances to see them all)"
 
 {- Note [Displaying potential instances]
                 text "(use -fprint-potential-instances to see them all)"
 
 {- Note [Displaying potential instances]
index 650cbd8..1bb4a71 100644 (file)
@@ -1132,7 +1132,7 @@ flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)
   --   flatten_exact_fam_app_fully lifts out the application to top level
   -- Postcondition: Coercion :: Xi ~ F tys
 flatten_fam_app tc tys  -- Can be over-saturated
   --   flatten_exact_fam_app_fully lifts out the application to top level
   -- Postcondition: Coercion :: Xi ~ F tys
 flatten_fam_app tc tys  -- Can be over-saturated
-    = ASSERT2( tyConArity tc <= length tys
+    = ASSERT2( tys `lengthAtLeast` tyConArity tc
              , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
                  -- Type functions are saturated
                  -- The type function might be *over* saturated
              , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)
                  -- Type functions are saturated
                  -- The type function might be *over* saturated
index d8fb620..d46b67c 100644 (file)
@@ -381,7 +381,7 @@ gen_Ord_binds loc tycon = do
 
     mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr RdrName
     mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op
 
     mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr RdrName
     mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op
-      | length nullary_cons <= 2  -- Two nullary or fewer, so use cases
+      | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
       = nlHsCase (nlHsVar a_RDR) $
         map (mkOrdOpAlt dflags op) tycon_data_cons
         -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
       = nlHsCase (nlHsVar a_RDR) $
         map (mkOrdOpAlt dflags op) tycon_data_cons
         -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
@@ -1027,7 +1027,7 @@ gen_Read_binds get_fixity loc tycon
         labels       = map flLabel $ dataConFieldLabels data_con
         dc_nm        = getName data_con
         is_infix     = dataConIsInfix data_con
         labels       = map flLabel $ dataConFieldLabels data_con
         dc_nm        = getName data_con
         is_infix     = dataConIsInfix data_con
-        is_record    = length labels > 0
+        is_record    = labels `lengthExceeds` 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
         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
index 51451a6..fc0209d 100644 (file)
@@ -348,7 +348,7 @@ mkBindsRep gk tycon =
         (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
           where gk_ = case gk of
                   Gen0 -> Gen0_
         (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons
           where gk_ = case gk of
                   Gen0 -> Gen0_
-                  Gen1 -> ASSERT(length tyvars >= 1)
+                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)
                           Gen1_ (last tyvars)
                     where tyvars = tyConTyVars tycon
 
                           Gen1_ (last tyvars)
                     where tyvars = tyConTyVars tycon
 
@@ -572,7 +572,7 @@ tc_mkRepTy gk_ tycon k =
         prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
         prod [] _  _  _  = mkTyConApp u1 [k]
         prod l  sb ib fl = foldBal mkProd
         prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type
         prod [] _  _  _  = mkTyConApp u1 [k]
         prod l  sb ib fl = foldBal mkProd
-                                   [ ASSERT(null fl || length fl > j)
+                                   [ ASSERT(null fl || lengthExceeds fl j)
                                      arg t sb' ib' (if null fl
                                                        then Nothing
                                                        else Just (fl !! j))
                                      arg t sb' ib' (if null fl
                                                        then Nothing
                                                        else Just (fl !! j))
@@ -617,7 +617,7 @@ tc_mkRepTy gk_ tycon k =
         buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
                                              , mkNumLitTy (fromIntegral n)]
 
         buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
                                              , mkNumLitTy (fromIntegral n)]
 
-        isRec c = mkTyConTy $ if length (dataConFieldLabels c) > 0
+        isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0
                               then promotedTrueDataCon
                               else promotedFalseDataCon
 
                               then promotedTrueDataCon
                               else promotedFalseDataCon
 
index 486210c..07f945c 100644 (file)
@@ -468,7 +468,7 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside
                 | otherwise                 = unmangled_result
 
         ; pat_ty <- readExpType pat_ty
                 | otherwise                 = unmangled_result
 
         ; pat_ty <- readExpType pat_ty
-        ; ASSERT( length con_arg_tys == length pats ) -- Syntactically enforced
+        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced
           return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
         }
 
           return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)
         }
 
index 962ad2e..b989aa1 100644 (file)
@@ -1468,7 +1468,7 @@ reifyDataCon isGadtDataCon tys dc
                 -- constructors can be declared infix.
                 -- See Note [Infix GADT constructors] in TcTyClsDecls.
               | dataConIsInfix dc && not isGadtDataCon ->
                 -- constructors can be declared infix.
                 -- See Note [Infix GADT constructors] in TcTyClsDecls.
               | dataConIsInfix dc && not isGadtDataCon ->
-                  ASSERT( length arg_tys == 2 ) do
+                  ASSERT( arg_tys `lengthIs` 2 ) do
                   { let [r_a1, r_a2] = r_arg_tys
                         [s1,   s2]   = dcdBangs
                   ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
                   { let [r_a1, r_a2] = r_arg_tys
                         [s1,   s2]   = dcdBangs
                   ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }
@@ -1486,7 +1486,7 @@ reifyDataCon isGadtDataCon tys dc
                          { cxt <- reifyCxt theta'
                          ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
                          ; return (TH.ForallC ex_tvs'' cxt main_con) }
                          { cxt <- reifyCxt theta'
                          ; ex_tvs'' <- reifyTyVars ex_tvs' Nothing
                          ; return (TH.ForallC ex_tvs'' cxt main_con) }
-       ; ASSERT( length arg_tys == length dcdBangs )
+       ; ASSERT( arg_tys `equalLength` dcdBangs )
          ret_con }
 
 -- Note [Reifying GADT data constructors]
          ret_con }
 
 -- Note [Reifying GADT data constructors]
index cb46c69..6076c75 100644 (file)
@@ -1087,7 +1087,7 @@ tcDefaultAssocDecl fam_tc [L loc (TyFamEqn { tfe_tycon = L _ tc_name
          checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
        -- Arity check
          checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
 
        -- Arity check
-       ; checkTc (length exp_vars == fam_arity)
+       ; checkTc (exp_vars `lengthIs` fam_arity)
                  (wrongNumberOfParmsErr fam_arity)
 
        -- Typecheck RHS
                  (wrongNumberOfParmsErr fam_arity)
 
        -- Typecheck RHS
@@ -2295,7 +2295,7 @@ checkValidTyConTyVars tc
                          2 (vcat (map pp_tv stripped_tvs)) ])) }
   where
     tvs = tyConTyVars tc
                          2 (vcat (map pp_tv stripped_tvs)) ])) }
   where
     tvs = tyConTyVars tc
-    duplicate_vars = sizeVarSet (mkVarSet tvs) < length tvs
+    duplicate_vars = tvs `lengthExceeds` sizeVarSet (mkVarSet tvs)
 
     pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
 
 
     pp_tv tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)
 
index f106268..a1a2add 100644 (file)
@@ -1329,7 +1329,7 @@ uType origin t_or_k orig_ty1 orig_ty2
 
     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
       -- See Note [Mismatched type lists and application decomposition]
 
     go (TyConApp tc1 tys1) (TyConApp tc2 tys2)
       -- See Note [Mismatched type lists and application decomposition]
-      | tc1 == tc2, length tys1 == length tys2
+      | tc1 == tc2, equalLength tys1 tys2
       = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
         do { cos <- zipWithM (uType origin t_or_k) tys1 tys2
            ; return $ mkTyConAppCo Nominal tc1 cos }
       = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )
         do { cos <- zipWithM (uType origin t_or_k) tys1 tys2
            ; return $ mkTyConAppCo Nominal tc1 cos }
index 0a7a0ad..a938d12 100644 (file)
@@ -504,7 +504,7 @@ check_syn_tc_app :: TidyEnv -> UserTypeCtxt -> Rank -> KindOrType
 -- which must be saturated,
 -- but not data families, which need not be saturated
 check_syn_tc_app env ctxt rank ty tc tys
 -- which must be saturated,
 -- but not data families, which need not be saturated
 check_syn_tc_app env ctxt rank ty tc tys
-  | tc_arity <= length tys   -- Saturated
+  | tys `lengthAtLeast` tc_arity   -- Saturated
        -- Check that the synonym has enough args
        -- This applies equally to open and closed synonyms
        -- It's OK to have an *over-applied* type synonym
        -- Check that the synonym has enough args
        -- This applies equally to open and closed synonyms
        -- It's OK to have an *over-applied* type synonym
@@ -739,7 +739,7 @@ check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TyCon -> [TcType] -> TcM ()
 check_eq_pred env dflags pred tc tys
   =         -- Equational constraints are valid in all contexts if type
             -- families are permitted
 check_eq_pred env dflags pred tc tys
   =         -- Equational constraints are valid in all contexts if type
             -- families are permitted
-    do { checkTc (length tys == tyConArity tc) (tyConArityErr tc tys)
+    do { checkTc (tys `lengthIs` tyConArity tc) (tyConArityErr tc tys)
        ; checkTcM (xopt LangExt.TypeFamilies dflags
                    || xopt LangExt.GADTs dflags)
                   (eqPredTyErr env pred) }
        ; checkTcM (xopt LangExt.TypeFamilies dflags
                    || xopt LangExt.GADTs dflags)
                   (eqPredTyErr env pred) }
@@ -814,7 +814,7 @@ check_class_pred env dflags ctxt pred cls tys
        ; when warn_simp check_simplifiable_class_constraint
        ; checkTcM arg_tys_ok (predTyVarErr env pred) }
   where
        ; when warn_simp check_simplifiable_class_constraint
        ; checkTcM arg_tys_ok (predTyVarErr env pred) }
   where
-    check_arity = checkTc (classArity cls == length tys)
+    check_arity = checkTc (tys `lengthIs` classArity cls)
                           (tyConArityErr (classTyCon cls) tys)
 
     -- Check the arguments of a class constraint
                           (tyConArityErr (classTyCon cls) tys)
 
     -- Check the arguments of a class constraint
@@ -1047,7 +1047,7 @@ checkValidInstHead ctxt clas cls_args
                        all tcInstHeadTyAppAllTyVars ty_args)
                  (instTypeErr clas cls_args head_type_args_tyvars_msg)
             ; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||
                        all tcInstHeadTyAppAllTyVars ty_args)
                  (instTypeErr clas cls_args head_type_args_tyvars_msg)
             ; checkTc (xopt LangExt.MultiParamTypeClasses dflags ||
-                       length ty_args == 1 ||  -- Only count type arguments
+                       lengthIs ty_args 1 ||  -- Only count type arguments
                        (xopt LangExt.NullaryTypeClasses dflags &&
                         null ty_args))
                  (instTypeErr clas cls_args head_one_type_msg) }
                        (xopt LangExt.NullaryTypeClasses dflags &&
                         null ty_args))
                  (instTypeErr clas cls_args head_one_type_msg) }
@@ -1239,7 +1239,7 @@ validDerivPred tv_set pred
     check_tys cls tys
               = hasNoDups fvs
                    -- use sizePred to ignore implicit args
     check_tys cls tys
               = hasNoDups fvs
                    -- use sizePred to ignore implicit args
-                && sizePred pred == fromIntegral (length fvs)
+                && lengthIs fvs (sizePred pred)
                 && all (`elemVarSet` tv_set) fvs
       where tys' = filterOutInvisibleTypes (classTyCon cls) tys
             fvs  = fvTypes tys'
                 && all (`elemVarSet` tv_set) fvs
       where tys' = filterOutInvisibleTypes (classTyCon cls) tys
             fvs  = fvTypes tys'
@@ -1738,7 +1738,7 @@ checkValidFamPats mb_clsinfo fam_tc tvs cvs ty_pats
          --     type family F a :: * -> *
          --     type instance F Int y = y
          -- because then the type (F Int) would be like (\y.y)
          --     type family F a :: * -> *
          --     type instance F Int y = y
          -- because then the type (F Int) would be like (\y.y)
-         checkTc (length ty_pats == fam_arity) $
+         checkTc (ty_pats `lengthIs` fam_arity) $
            wrongNumberOfParmsErr (fam_arity - count isInvisibleTyConBinder fam_bndrs)
              -- report only explicit arguments
 
            wrongNumberOfParmsErr (fam_arity - count isInvisibleTyConBinder fam_bndrs)
              -- report only explicit arguments
 
index ecc7e2e..ae1047e 100644 (file)
@@ -245,7 +245,7 @@ classSCSelId :: Class -> Int -> Id
 -- where n is 0-indexed, and counts
 --    *all* superclasses including equalities
 classSCSelId (Class { classBody = ConcreteClass { classSCSels = sc_sels } }) n
 -- where n is 0-indexed, and counts
 --    *all* superclasses including equalities
 classSCSelId (Class { classBody = ConcreteClass { classSCSels = sc_sels } }) n
-  = ASSERT( n >= 0 && n < length sc_sels )
+  = ASSERT( n >= 0 && lengthExceeds sc_sels n )
     sc_sels !! n
 classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
 
     sc_sels !! n
 classSCSelId c n = pprPanic "classSCSelId" (ppr c <+> ppr n)
 
index e1dcfde..3f5036c 100644 (file)
@@ -797,7 +797,7 @@ mkAxInstCo role ax index tys cos
 -- worker function; just checks to see if it should produce Refl
 mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
 mkAxiomInstCo ax index args
 -- worker function; just checks to see if it should produce Refl
 mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion
 mkAxiomInstCo ax index args
-  = ASSERT( coAxiomArity ax index == length args )
+  = ASSERT( args `lengthIs` coAxiomArity ax index )
     AxiomInstCo ax index args
 
 -- to be used only with unbranched axioms
     AxiomInstCo ax index args
 
 -- to be used only with unbranched axioms
@@ -1210,7 +1210,7 @@ promoteCoercion co = case co of
 
     NthCo n co1
       | Just (_, args) <- splitTyConAppCo_maybe co1
 
     NthCo n co1
       | Just (_, args) <- splitTyConAppCo_maybe co1
-      , n < length args
+      , args `lengthExceeds` n
       -> promoteCoercion (args !! n)
 
       | Just _ <- splitForAllCo_maybe co
       -> promoteCoercion (args !! n)
 
       | Just _ <- splitForAllCo_maybe co
@@ -1837,7 +1837,7 @@ coercionKind co = go co
     go (TransCo co1 co2)      = Pair (pFst $ go co1) (pSnd $ go co2)
     go g@(NthCo d co)
       | Just argss <- traverse tyConAppArgs_maybe tys
     go (TransCo co1 co2)      = Pair (pFst $ go co1) (pSnd $ go co2)
     go g@(NthCo d co)
       | Just argss <- traverse tyConAppArgs_maybe tys
-      = ASSERT( and $ ((d <) . length) <$> argss )
+      = ASSERT( and $ (`lengthExceeds` d) <$> argss )
         (`getNth` d) <$> argss
 
       | d == 0
         (`getNth` d) <$> argss
 
       | d == 0
index 871840e..6764409 100644 (file)
@@ -583,13 +583,13 @@ opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)
 -- Eta rules
 opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
   | Just cos2 <- etaTyConAppCo_maybe tc co2
 -- Eta rules
 opt_trans_rule is co1@(TyConAppCo r tc cos1) co2
   | Just cos2 <- etaTyConAppCo_maybe tc co2
-  = ASSERT( length cos1 == length cos2 )
+  = ASSERT( cos1 `equalLength` cos2 )
     fireTransRule "EtaCompL" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
 opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
   | Just cos1 <- etaTyConAppCo_maybe tc co1
     fireTransRule "EtaCompL" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
 opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)
   | Just cos1 <- etaTyConAppCo_maybe tc co1
-  = ASSERT( length cos1 == length cos2 )
+  = ASSERT( cos1 `equalLength` cos2 )
     fireTransRule "EtaCompR" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
     fireTransRule "EtaCompR" co1 co2 $
     mkTyConAppCo r tc (opt_transList is cos1 cos2)
 
@@ -934,7 +934,7 @@ etaTyConAppCo_maybe tc co
   , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in TyCoRep
   , let n = length tys1
   = ASSERT( tc == tc1 )
   , isInjectiveTyCon tc r  -- See Note [NthCo and newtypes] in TyCoRep
   , let n = length tys1
   = ASSERT( tc == tc1 )
-    ASSERT( n == length tys2 )
+    ASSERT( tys2 `lengthIs` n )
     Just (decomposeCo n co)
     -- NB: n might be <> tyConArity tc
     -- e.g.   data family T a :: * -> *
     Just (decomposeCo n co)
     -- NB: n might be <> tyConArity tc
     -- e.g.   data family T a :: * -> *
index 74ebfbe..e6afece 100644 (file)
@@ -676,7 +676,7 @@ mkPiTys tbs ty = foldr mkPiTy ty tbs
 isCoercionType :: Type -> Bool
 isCoercionType (TyConApp tc tys)
   | (tc `hasKey` eqPrimTyConKey) || (tc `hasKey` eqReprPrimTyConKey)
 isCoercionType :: Type -> Bool
 isCoercionType (TyConApp tc tys)
   | (tc `hasKey` eqPrimTyConKey) || (tc `hasKey` eqReprPrimTyConKey)
-  , length tys == 4
+  , tys `lengthIs` 4
   = True
 isCoercionType _ = False
 
   = True
 isCoercionType _ = False
 
@@ -1897,7 +1897,7 @@ mkTyCoInScopeSet tys cos
 zipTvSubst :: [TyVar] -> [Type] -> TCvSubst
 zipTvSubst tvs tys
   | debugIsOn
 zipTvSubst :: [TyVar] -> [Type] -> TCvSubst
 zipTvSubst tvs tys
   | debugIsOn
-  , not (all isTyVar tvs) || length tvs /= length tys
+  , not (all isTyVar tvs) || neLength tvs tys
   = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst
   | otherwise
   = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv
   = pprTrace "zipTvSubst" (ppr tvs $$ ppr tys) emptyTCvSubst
   | otherwise
   = mkTvSubst (mkInScopeSet (tyCoVarsOfTypes tys)) tenv
@@ -1909,7 +1909,7 @@ zipTvSubst tvs tys
 zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst
 zipCvSubst cvs cos
   | debugIsOn
 zipCvSubst :: [CoVar] -> [Coercion] -> TCvSubst
 zipCvSubst cvs cos
   | debugIsOn
-  , not (all isCoVar cvs) || length cvs /= length cos
+  , not (all isCoVar cvs) || neLength cvs cos
   = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst
   | otherwise
   = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv
   = pprTrace "zipCvSubst" (ppr cvs $$ ppr cos) emptyTCvSubst
   | otherwise
   = TCvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv cenv
@@ -2008,7 +2008,7 @@ ForAllCo tv (sym h) (sym g[tv |-> tv |> sym h])
 substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type
 -- Works only if the domain of the substitution is a
 -- superset of the type being substituted into
 substTyWith :: HasCallStack => [TyVar] -> [Type] -> Type -> Type
 -- Works only if the domain of the substitution is a
 -- superset of the type being substituted into
-substTyWith tvs tys = ASSERT( length tvs == length tys )
+substTyWith tvs tys = ASSERT( tvs `equalLength` tys )
                       substTy (zipTvSubst tvs tys)
 
 -- | Type substitution, see 'zipTvSubst'. Disables sanity checks.
                       substTy (zipTvSubst tvs tys)
 
 -- | Type substitution, see 'zipTvSubst'. Disables sanity checks.
@@ -2018,7 +2018,7 @@ substTyWith tvs tys = ASSERT( length tvs == length tys )
 -- substTy and remove this function. Please don't use in new code.
 substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type
 substTyWithUnchecked tvs tys
 -- substTy and remove this function. Please don't use in new code.
 substTyWithUnchecked :: [TyVar] -> [Type] -> Type -> Type
 substTyWithUnchecked tvs tys
-  = ASSERT( length tvs == length tys )
+  = ASSERT( tvs `equalLength` tys )
     substTyUnchecked (zipTvSubst tvs tys)
 
 -- | Substitute tyvars within a type using a known 'InScopeSet'.
     substTyUnchecked (zipTvSubst tvs tys)
 
 -- | Substitute tyvars within a type using a known 'InScopeSet'.
@@ -2027,13 +2027,13 @@ substTyWithUnchecked tvs tys
 -- and of 'ty' minus the domain of the subst.
 substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type
 substTyWithInScope in_scope tvs tys ty =
 -- and of 'ty' minus the domain of the subst.
 substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type
 substTyWithInScope in_scope tvs tys ty =
-  ASSERT( length tvs == length tys )
+  ASSERT( tvs `equalLength` tys )
   substTy (mkTvSubst in_scope tenv) ty
   where tenv = zipTyEnv tvs tys
 
 -- | Coercion substitution, see 'zipTvSubst'
 substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion
   substTy (mkTvSubst in_scope tenv) ty
   where tenv = zipTyEnv tvs tys
 
 -- | Coercion substitution, see 'zipTvSubst'
 substCoWith :: HasCallStack => [TyVar] -> [Type] -> Coercion -> Coercion
-substCoWith tvs tys = ASSERT( length tvs == length tys )
+substCoWith tvs tys = ASSERT( tvs `equalLength` tys )
                       substCo (zipTvSubst tvs tys)
 
 -- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.
                       substCo (zipTvSubst tvs tys)
 
 -- | Coercion substitution, see 'zipTvSubst'. Disables sanity checks.
@@ -2043,7 +2043,7 @@ substCoWith tvs tys = ASSERT( length tvs == length tys )
 -- substCo and remove this function. Please don't use in new code.
 substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion
 substCoWithUnchecked tvs tys
 -- substCo and remove this function. Please don't use in new code.
 substCoWithUnchecked :: [TyVar] -> [Type] -> Coercion -> Coercion
 substCoWithUnchecked tvs tys
-  = ASSERT( length tvs == length tys )
+  = ASSERT( tvs `equalLength` tys )
     substCoUnchecked (zipTvSubst tvs tys)
 
 
     substCoUnchecked (zipTvSubst tvs tys)
 
 
@@ -2054,12 +2054,12 @@ substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)
 
 -- | Type substitution, see 'zipTvSubst'
 substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
 
 -- | Type substitution, see 'zipTvSubst'
 substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
-substTysWith tvs tys = ASSERT( length tvs == length tys )
+substTysWith tvs tys = ASSERT( tvs `equalLength` tys )
                        substTys (zipTvSubst tvs tys)
 
 -- | Type substitution, see 'zipTvSubst'
 substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]
                        substTys (zipTvSubst tvs tys)
 
 -- | Type substitution, see 'zipTvSubst'
 substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]
-substTysWithCoVars cvs cos = ASSERT( length cvs == length cos )
+substTysWithCoVars cvs cos = ASSERT( cvs `equalLength` cos )
                              substTys (zipCvSubst cvs cos)
 
 -- | Substitute within a 'Type' after adding the free variables of the type
                              substTys (zipCvSubst cvs cos)
 
 -- | Substitute within a 'Type' after adding the free variables of the type
index 9f6486b..7b433fa 100644 (file)
@@ -891,7 +891,7 @@ okParent :: Name -> AlgTyConFlav -> Bool
 okParent _       (VanillaAlgTyCon {})            = True
 okParent _       (UnboxedAlgTyCon {})            = True
 okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)
 okParent _       (VanillaAlgTyCon {})            = True
 okParent _       (UnboxedAlgTyCon {})            = True
 okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)
-okParent _       (DataFamInstTyCon _ fam_tc tys) = tyConArity fam_tc == length tys
+okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthIs` tyConArity fam_tc
 
 isNoParent :: AlgTyConFlav -> Bool
 isNoParent (VanillaAlgTyCon {}) = True
 
 isNoParent :: AlgTyConFlav -> Bool
 isNoParent (VanillaAlgTyCon {}) = True
@@ -1734,7 +1734,7 @@ isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon]
 isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })
   = case rhs of
       DataTyCon { data_cons = cons }
 isDataSumTyCon_maybe (AlgTyCon { algTcRhs = rhs })
   = case rhs of
       DataTyCon { data_cons = cons }
-        | length cons > 1
+        | cons `lengthExceeds` 1
         , all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this?
         -> Just cons
       SumTyCon { data_cons = cons }
         , all (null . dataConExTyVars) cons -- FIXME(osa): Why do we need this?
         -> Just cons
       SumTyCon { data_cons = cons }
@@ -2024,10 +2024,10 @@ expandSynTyCon_maybe
 -- ^ Expand a type synonym application, if any
 expandSynTyCon_maybe tc tys
   | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc
 -- ^ Expand a type synonym application, if any
 expandSynTyCon_maybe tc tys
   | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc
-  = case arity `compare` length tys of
-        LT -> Just (tvs `zip` tys, rhs, drop arity tys)
+  = case tys `listLengthCmp` arity of
+        GT -> Just (tvs `zip` tys, rhs, drop arity tys)
         EQ -> Just (tvs `zip` tys, rhs, [])
         EQ -> Just (tvs `zip` tys, rhs, [])
-        GT -> Nothing
+        LT -> Nothing
    | otherwise
    = Nothing
 
    | otherwise
    = Nothing
 
index 65c02ba..8621e6c 100644 (file)
@@ -1030,7 +1030,7 @@ applyTysX :: [TyVar] -> Type -> [Type] -> Type
 -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
 -- Assumes that (/\tvs. body_ty) is closed
 applyTysX tvs body_ty arg_tys
 -- applyTyxX beta-reduces (/\tvs. body_ty) arg_tys
 -- Assumes that (/\tvs. body_ty) is closed
 applyTysX tvs body_ty arg_tys
-  = ASSERT2( length arg_tys >= n_tvs, pp_stuff )
+  = ASSERT2( arg_tys `lengthAtLeast` n_tvs, pp_stuff )
     ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )
     mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty)
              (drop n_tvs arg_tys)
     ASSERT2( tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs, pp_stuff )
     mkAppTys (substTyWith tvs (take n_tvs arg_tys) body_ty)
              (drop n_tvs arg_tys)
@@ -1094,7 +1094,7 @@ tyConAppArgN :: Int -> Type -> Type
 -- Executing Nth
 tyConAppArgN n ty
   = case tyConAppArgs_maybe ty of
 -- Executing Nth
 tyConAppArgN n ty
   = case tyConAppArgs_maybe ty of
-      Just tys -> ASSERT2( n < length tys, ppr n <+> ppr tys ) tys `getNth` n
+      Just tys -> ASSERT2( tys `lengthExceeds` n, ppr n <+> ppr tys ) tys `getNth` n
       Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)
 
 -- | Attempts to tease a type apart into a type constructor and the application
       Nothing  -> pprPanic "tyConAppArgN" (ppr n <+> ppr ty)
 
 -- | Attempts to tease a type apart into a type constructor and the application
@@ -1587,9 +1587,9 @@ isPredTy ty = go ty []
     go_tc :: TyCon -> [KindOrType] -> Bool
     go_tc tc args
       | tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey
     go_tc :: TyCon -> [KindOrType] -> Bool
     go_tc tc args
       | tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey
-                  = length args == 4  -- ~# and ~R# sadly have result kind #
-                                      -- not Constraint; but we still want
-                                      -- isPredTy to reply True.
+                  = args `lengthIs` 4  -- ~# and ~R# sadly have result kind #
+                                       -- not Constraint; but we still want
+                                       -- isPredTy to reply True.
       | otherwise = go_k (tyConKind tc) args
 
     go_k :: Kind -> [KindOrType] -> Bool
       | otherwise = go_k (tyConKind tc) args
 
     go_k :: Kind -> [KindOrType] -> Bool
@@ -1890,7 +1890,7 @@ mkFamilyTyConApp :: TyCon -> [Type] -> Type
 mkFamilyTyConApp tc tys
   | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
   , let tvs = tyConTyVars tc
 mkFamilyTyConApp tc tys
   | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc
   , let tvs = tyConTyVars tc
-        fam_subst = ASSERT2( length tvs == length tys, ppr tc <+> ppr tys )
+        fam_subst = ASSERT2( tvs `equalLength` tys, ppr tc <+> ppr tys )
                     zipTvSubst tvs tys
   = mkTyConApp fam_tc (substTys fam_subst fam_tys)
   | otherwise
                     zipTvSubst tvs tys
   = mkTyConApp fam_tc (substTys fam_subst fam_tys)
   | otherwise
index 88af48e..f1aa2c3 100644 (file)
@@ -46,7 +46,7 @@ getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs )
 unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
 -- Assumes that the arguments contain no duplicates
 unionLists xs ys
 unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
 -- Assumes that the arguments contain no duplicates
 unionLists xs ys
-  = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys)
+  = WARN(lengthExceeds xs 100 || lengthExceeds ys 100, ppr xs $$ ppr ys)
     [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
 
 -- | Calculate the set difference of two lists. This is
     [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
 
 -- | Calculate the set difference of two lists. This is
index a4bc8d4..35a6340 100644 (file)
@@ -36,9 +36,10 @@ module Util (
 
         foldl1', foldl2, count, all2,
 
 
         foldl1', foldl2, count, all2,
 
-        lengthExceeds, lengthIs, lengthAtLeast,
+        lengthExceeds, lengthIs, lengthIsNot,
+        lengthAtLeast, lengthAtMost, lengthLessThan,
         listLengthCmp, atLength,
         listLengthCmp, atLength,
-        equalLength, compareLength, leLength,
+        equalLength, neLength, compareLength, leLength, ltLength,
 
         isSingleton, only, singleton,
         notNull, snocView,
 
         isSingleton, only, singleton,
         notNull, snocView,
@@ -494,6 +495,7 @@ lengthExceeds lst n
   | otherwise
   = atLength notNull False lst n
 
   | otherwise
   = atLength notNull False lst n
 
+-- | @(lengthAtLeast xs n) = (length xs >= n)@
 lengthAtLeast :: [a] -> Int -> Bool
 lengthAtLeast = atLength (const True) False
 
 lengthAtLeast :: [a] -> Int -> Bool
 lengthAtLeast = atLength (const True) False
 
@@ -505,6 +507,24 @@ lengthIs lst n
   | otherwise
   = atLength null False lst n
 
   | otherwise
   = atLength null False lst n
 
+-- | @(lengthIsNot xs n) = (length xs /= n)@
+lengthIsNot :: [a] -> Int -> Bool
+lengthIsNot lst n
+  | n < 0 = True
+  | otherwise = atLength notNull True lst n
+
+-- | @(lengthAtMost xs n) = (length xs <= n)@
+lengthAtMost :: [a] -> Int -> Bool
+lengthAtMost lst n
+  | n < 0
+  = False
+  | otherwise
+  = atLength null True lst n
+
+-- | @(lengthLessThan xs n) == (length xs < n)@
+lengthLessThan :: [a] -> Int -> Bool
+lengthLessThan = atLength (const False) True
+
 listLengthCmp :: [a] -> Int -> Ordering
 listLengthCmp = atLength atLen atEnd
  where
 listLengthCmp :: [a] -> Int -> Ordering
 listLengthCmp = atLength atLen atEnd
  where
@@ -514,10 +534,17 @@ listLengthCmp = atLength atLen atEnd
   atLen _      = GT
 
 equalLength :: [a] -> [b] -> Bool
   atLen _      = GT
 
 equalLength :: [a] -> [b] -> Bool
+-- ^ True if length xs == length ys
 equalLength []     []     = True
 equalLength (_:xs) (_:ys) = equalLength xs ys
 equalLength _      _      = False
 
 equalLength []     []     = True
 equalLength (_:xs) (_:ys) = equalLength xs ys
 equalLength _      _      = False
 
+neLength :: [a] -> [b] -> Bool
+-- ^ True if length xs /= length ys
+neLength []     []     = False
+neLength (_:xs) (_:ys) = neLength xs ys
+neLength _      _      = True
+
 compareLength :: [a] -> [b] -> Ordering
 compareLength []     []     = EQ
 compareLength (_:xs) (_:ys) = compareLength xs ys
 compareLength :: [a] -> [b] -> Ordering
 compareLength []     []     = EQ
 compareLength (_:xs) (_:ys) = compareLength xs ys
@@ -531,6 +558,13 @@ leLength xs ys = case compareLength xs ys of
                    EQ -> True
                    GT -> False
 
                    EQ -> True
                    GT -> False
 
+ltLength :: [a] -> [b] -> Bool
+-- ^ True if length xs < length ys
+ltLength xs ys = case compareLength xs ys of
+                   LT -> True
+                   EQ -> False
+                   GT -> False
+
 ----------------------------
 singleton :: a -> [a]
 singleton x = [x]
 ----------------------------
 singleton :: a -> [a]
 singleton x = [x]
index 612c051..9526fed 100644 (file)
@@ -365,7 +365,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
         defDataCons
           | isAbstract = return ()
           | otherwise
         defDataCons
           | isAbstract = return ()
           | otherwise
-          = do { MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon))
+          = do { MASSERT(tyConDataCons origTyCon `equalLength` tyConDataCons vectTyCon)
                ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon)
                }
 
                ; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon)
                }
 
index 9cd740c..4d32f5d 100644 (file)
@@ -22,6 +22,7 @@ import Var
 import Outputable
 import DynFlags
 import FastString
 import Outputable
 import DynFlags
 import FastString
+import Util
 import Control.Monad
 
 
 import Control.Monad
 
 
@@ -199,7 +200,7 @@ prDFunApply dfun tys
   = return $ Var dfun `mkTyApps` tys
 
   | Just tycons <- ctxs
   = return $ Var dfun `mkTyApps` tys
 
   | Just tycons <- ctxs
-  , length tycons == length tys
+  , tycons `equalLength` tys
   = do
       pa <- builtin paTyCon
       pr <- builtin prTyCon
   = do
       pa <- builtin paTyCon
       pr <- builtin prTyCon
index b57a5a0..bb946cc 100644 (file)
@@ -46,6 +46,7 @@ import GHCi
 import GHCi.RemoteTypes
 import HsSyn (ImportDecl)
 import RdrName (RdrName)
 import GHCi.RemoteTypes
 import HsSyn (ImportDecl)
 import RdrName (RdrName)
+import Util
 
 import Exception
 import Numeric
 
 import Exception
 import Numeric
@@ -396,8 +397,8 @@ printTimes dflags mallocs secs
   where
     separateThousands n = reverse . sep . reverse . show $ n
       where sep n'
   where
     separateThousands n = reverse . sep . reverse . show $ n
       where sep n'
-              | length n' <= 3 = n'
-              | otherwise = take 3 n' ++ "," ++ sep (drop 3 n')
+              | n' `lengthAtMost` 3 = n'
+              | otherwise           = take 3 n' ++ "," ++ sep (drop 3 n')
 
 -----------------------------------------------------------------------------
 -- reverting CAFs
 
 -----------------------------------------------------------------------------
 -- reverting CAFs