diff options
author | Ryan Scott <ryan.gl.scott@gmail.com> | 2017-06-02 13:12:11 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-06-02 13:12:13 -0400 |
commit | a786b136f48dfcf907dad55bcdbc4fcd247f2794 (patch) | |
tree | 9c6abee43aa398fdd8168b1cb7bd2d3fb5e6bacf | |
parent | 811a2986475d88f73bb22b4600970039e1b582d6 (diff) | |
download | haskell-a786b136f48dfcf907dad55bcdbc4fcd247f2794.tar.gz |
Use lengthIs and friends in more places
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, 170 insertions, 132 deletions
diff --git a/compiler/basicTypes/DataCon.hs b/compiler/basicTypes/DataCon.hs index 60cffac2ab..cc475e29d7 100644 --- a/compiler/basicTypes/DataCon.hs +++ b/compiler/basicTypes/DataCon.hs @@ -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 - = 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) @@ -1147,7 +1147,7 @@ dataConInstOrigArgTys 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 diff --git a/compiler/basicTypes/Demand.hs b/compiler/basicTypes/Demand.hs index 95c7b79b4f..b6296f49f7 100644 --- a/compiler/basicTypes/Demand.hs +++ b/compiler/basicTypes/Demand.hs @@ -300,7 +300,7 @@ lubStr (SCall _) (SProd _) = HeadStr 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 @@ -325,7 +325,7 @@ bothStr (SCall _) (SProd _) = HyperStr -- Weird 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 @@ -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) - | 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 @@ -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) - | 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] diff --git a/compiler/basicTypes/MkId.hs b/compiler/basicTypes/MkId.hs index e9a57bc02e..a404e74e12 100644 --- a/compiler/basicTypes/MkId.hs +++ b/compiler/basicTypes/MkId.hs @@ -713,7 +713,7 @@ dataConSrcToImplBang dflags fam_envs arg_ty 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 diff --git a/compiler/basicTypes/PatSyn.hs b/compiler/basicTypes/PatSyn.hs index 823c838c05..0e218a39c1 100644 --- a/compiler/basicTypes/PatSyn.hs +++ b/compiler/basicTypes/PatSyn.hs @@ -394,7 +394,7 @@ patSynInstArgTys :: PatSyn -> [Type] -> [Type] 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 @@ -409,7 +409,7 @@ patSynInstResTy :: PatSyn -> [Type] -> Type 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 diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 78c604e067..a28feb4a2b 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -174,7 +174,7 @@ buildSRT dflags topSRT cafs = 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) diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index d8740df3f2..142de1e828 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -15,6 +15,7 @@ import CmmUtils import CmmSwitch (mapSwitchTargets) import Maybes import Panic +import Util 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) - | length used_blocks < mapSize (toBlockMap g) + | used_blocks `lengthLessThan` mapSize (toBlockMap g) = CmmProc info' lbl live g' | otherwise = proc diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index 37572b7d4e..8eaee795a5 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -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 - , 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 diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index edf97eeb0a..6e6ad7e9d7 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -562,7 +562,7 @@ chooseReturnBndrs bndr (PrimAlt _) _alts = 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 diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index dc80036b55..b123420d58 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -274,7 +274,7 @@ direct_call :: String -> 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 <+> diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index e0a68f68d8..1ecd72f9db 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -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 - 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 @@ -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 - 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 diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 8e4e5ece5a..8d86e37ddf 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -124,6 +124,7 @@ import Id import BasicTypes import FastString import Outputable +import Util import DynFlags @@ -381,7 +382,7 @@ tickyUnboxedTupleReturn arity -- 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)) @@ -412,7 +413,7 @@ tickySlowCallPat :: [PrimRep] -> FCode () 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" diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 0888afbeeb..2be1020674 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -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] - ; 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 <+> @@ -574,7 +574,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) ; 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 <+> @@ -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 - , 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 - , length tys < tyConArity tc + , tys `lengthLessThan` tyConArity tc = 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 - , n < length tys_s + , tys_s `lengthExceeds` 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 - ; unless (length ktvs + length cvs == length cos) $ + ; unless (cos `equalLength` (ktvs ++ cvs)) $ bad_ax (text "lengths") ; subst <- getTCvSubst ; let empty_subst = zapTCvSubst subst diff --git a/compiler/coreSyn/CoreUnfold.hs b/compiler/coreSyn/CoreUnfold.hs index 811ddad00e..cedc78fcfa 100644 --- a/compiler/coreSyn/CoreUnfold.hs +++ b/compiler/coreSyn/CoreUnfold.hs @@ -578,7 +578,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr 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, @@ -593,7 +593,7 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr -- 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) diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index cc2d1724a5..b8399237da 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -1391,7 +1391,7 @@ altsAreExhaustive ((con1,_,_) : alts) = 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 @@ -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) - = length ps1 == length ps2 + = equalLength ps1 ps2 && 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) - | 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 @@ -1933,7 +1933,7 @@ diffUnfold _ BootUnfolding BootUnfolding = [] 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) diff --git a/compiler/coreSyn/TrieMap.hs b/compiler/coreSyn/TrieMap.hs index 9058d03b57..a6b9db46cb 100644 --- a/compiler/coreSyn/TrieMap.hs +++ b/compiler/coreSyn/TrieMap.hs @@ -41,6 +41,7 @@ import Var import UniqDFM import Unique( Unique ) import FastString(FastString) +import Util 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) - = length ps1 == length ps2 + = equalLength ps1 ps2 && D env1' rs1 == D env2' rs2 && D env1' e1 == D env2' e2 where diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 4b01aac323..8234cccb5c 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -112,13 +112,9 @@ getResult ls = do | 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 @@ -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 - = 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] diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 24213330ef..92002bf793 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -187,7 +187,7 @@ writeMixEntries dflags mod count entries filename 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 diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 2a41ede6c9..cfd9996f1a 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -853,9 +853,9 @@ dsExplicitList :: Type -> Maybe (SyntaxExpr Id) -> [LHsExpr Id] 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. - || 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! diff --git a/compiler/deSugar/MatchCon.hs b/compiler/deSugar/MatchCon.hs index 0e1aa802e9..47d1276ba6 100644 --- a/compiler/deSugar/MatchCon.hs +++ b/compiler/deSugar/MatchCon.hs @@ -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 - = ASSERT2( length fields1 == length arg_vars, + = ASSERT2( fields1 `equalLength` arg_vars, ppr con1 $$ ppr fields1 $$ ppr arg_vars ) map lookup_fld rpats | otherwise diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs index 0033df1cea..7ad51a7138 100644 --- a/compiler/ghci/ByteCodeGen.hs +++ b/compiler/ghci/ByteCodeGen.hs @@ -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 - , 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, [], _)]) @@ -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 - = 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 diff --git a/compiler/ghci/DebuggerUtils.hs b/compiler/ghci/DebuggerUtils.hs index 096b809c26..9e3d56e0d1 100644 --- a/compiler/ghci/DebuggerUtils.hs +++ b/compiler/ghci/DebuggerUtils.hs @@ -110,14 +110,14 @@ dataConInfoPtrToName x = do -- 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 - (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. diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 5f67515c71..e64c4eaed5 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -1183,7 +1183,7 @@ cvtTypeKind ty_str ty = 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') @@ -1193,7 +1193,7 @@ cvtTypeKind ty_str ty -> 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 @@ -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" ] - | length tys' == n -- Saturated + | tys' `lengthIs` n -- Saturated -> returnL (HsSumTy tys') | otherwise -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index b56d8d61e0..8b5a6b6af7 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -80,6 +80,7 @@ import RtClosureInspect import Outputable import FastString import Bag +import Util 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 -- - 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") diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs index d4d8e2429e..bc278b119e 100644 --- a/compiler/nativeGen/Dwarf/Types.hs +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -32,6 +32,7 @@ import Platform import Unique import Reg import SrcLoc +import Util import Dwarf.Constants @@ -577,7 +578,7 @@ pprString' str = text "\t.asciz \"" <> str <> char '"' 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 diff --git a/compiler/prelude/PrelInfo.hs b/compiler/prelude/PrelInfo.hs index 471b61ee09..8e26d80a6a 100644 --- a/compiler/prelude/PrelInfo.hs +++ b/compiler/prelude/PrelInfo.hs @@ -170,7 +170,7 @@ knownKeyNamesOkay 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 diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 7c4663c080..30dd61bece 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -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 - = ASSERT( n == length flds ) + = ASSERT( flds `lengthIs` n ) do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM LangExt.RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) diff --git a/compiler/simplCore/CallArity.hs b/compiler/simplCore/CallArity.hs index e23314b569..0cf0c2f44f 100644 --- a/compiler/simplCore/CallArity.hs +++ b/compiler/simplCore/CallArity.hs @@ -18,6 +18,7 @@ import CoreArity ( typeArity ) import CoreUtils ( exprIsCheap, exprIsTrivial ) import UnVarGraph import Demand +import Util 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] - | 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. - | 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 diff --git a/compiler/simplCore/FloatIn.hs b/compiler/simplCore/FloatIn.hs index 02a7f741c5..3e44e81cea 100644 --- a/compiler/simplCore/FloatIn.hs +++ b/compiler/simplCore/FloatIn.hs @@ -665,7 +665,7 @@ sepBindsByDropPoint dflags is_case drop_pts floaters = [] : [[] | _ <- 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 diff --git a/compiler/simplCore/OccurAnal.hs b/compiler/simplCore/OccurAnal.hs index 98c81ce026..5dd30aa668 100644 --- a/compiler/simplCore/OccurAnal.hs +++ b/compiler/simplCore/OccurAnal.hs @@ -2572,7 +2572,7 @@ adjustRhsUsage mb_join_arity rec_flag bndrs usage 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 @@ -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 }) - = length args == join_arity + = args `lengthIs` join_arity -- Invariant 1 as applied to LHSes of rules willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity diff --git a/compiler/simplStg/RepType.hs b/compiler/simplStg/RepType.hs index 91e4285341..2acc815125 100644 --- a/compiler/simplStg/RepType.hs +++ b/compiler/simplStg/RepType.hs @@ -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. - | length constrs0 < 2 + | constrs0 `lengthLessThan` 2 = [WordSlot] | otherwise diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index 3f67bc278f..2e8fbda02b 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -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 - 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')] diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 39ec7e6946..e5af0b8a3c 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -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) - | length args < length bndr_occs -- Check saturated + | args `ltLength` bndr_occs -- Check saturated = return Nothing | otherwise = do { let in_scope = substInScope (sc_subst env) diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index 02d989cec0..7a1ed4df92 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -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) - 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 () @@ -398,7 +398,7 @@ checkFunApp fun_ty arg_tys msg | 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 diff --git a/compiler/typecheck/FamInst.hs b/compiler/typecheck/FamInst.hs index f69e41209f..cabfb3376b 100644 --- a/compiler/typecheck/FamInst.hs +++ b/compiler/typecheck/FamInst.hs @@ -789,7 +789,7 @@ isTFHeaded ty | Just ty' <- coreView ty = isTFHeaded ty' isTFHeaded ty | (TyConApp tc args) <- ty , isTypeFamilyTyCon tc - = tyConArity tc == length args + = args `lengthIs` tyConArity tc isTFHeaded _ = False diff --git a/compiler/typecheck/FunDeps.hs b/compiler/typecheck/FunDeps.hs index fff8979e0d..789254d230 100644 --- a/compiler/typecheck/FunDeps.hs +++ b/compiler/typecheck/FunDeps.hs @@ -255,8 +255,8 @@ improveClsFD clas_tvs fd = [] -- 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 diff --git a/compiler/typecheck/TcCanonical.hs b/compiler/typecheck/TcCanonical.hs index 77bf63d98e..ff00d4220b 100644 --- a/compiler/typecheck/TcCanonical.hs +++ b/compiler/typecheck/TcCanonical.hs @@ -917,7 +917,7 @@ canTyConApp :: CtEvidence -> EqRel -- 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" diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs index 8076115b6c..5bdfae70ac 100644 --- a/compiler/typecheck/TcDeriv.hs +++ b/compiler/typecheck/TcDeriv.hs @@ -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 - ; 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 @@ -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 ... - = 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 @@ -1302,7 +1302,7 @@ mkNewTypeEqn dflags overlap_mode tvs && 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 ) diff --git a/compiler/typecheck/TcDerivInfer.hs b/compiler/typecheck/TcDerivInfer.hs index 93dcf4383c..02c0103eec 100644 --- a/compiler/typecheck/TcDerivInfer.hs +++ b/compiler/typecheck/TcDerivInfer.hs @@ -67,12 +67,12 @@ inferConstraints :: [TyVar] -> Class -> [TcType] -> TcType 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) - | 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) } diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 324391f68b..4411d6ac51 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -1548,7 +1548,7 @@ mkCoercibleExplanation rdr_env fam_envs ty1 ty2 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 @@ -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 - = 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:", @@ -2706,7 +2706,7 @@ pprPotentials dflags sty herald insts <+> 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] diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs index 650cbd8219..1bb4a7165b 100644 --- a/compiler/typecheck/TcFlatten.hs +++ b/compiler/typecheck/TcFlatten.hs @@ -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 - = 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 diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index d8fb62044b..d46b67c248 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -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 - | 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... @@ -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 - 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 diff --git a/compiler/typecheck/TcGenGenerics.hs b/compiler/typecheck/TcGenGenerics.hs index 51451a6d1a..fc0209d805 100644 --- a/compiler/typecheck/TcGenGenerics.hs +++ b/compiler/typecheck/TcGenGenerics.hs @@ -348,7 +348,7 @@ mkBindsRep gk tycon = (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 @@ -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 - [ 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)) @@ -617,7 +617,7 @@ tc_mkRepTy gk_ tycon k = 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 diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index 486210cb07..07f945ccf3 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -468,7 +468,7 @@ tc_pat penv (TuplePat pats boxity _) pat_ty thing_inside | 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) } diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index 962ad2e0e0..b989aa18d6 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -1468,7 +1468,7 @@ reifyDataCon isGadtDataCon tys dc -- 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) } @@ -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) } - ; ASSERT( length arg_tys == length dcdBangs ) + ; ASSERT( arg_tys `equalLength` dcdBangs ) ret_con } -- Note [Reifying GADT data constructors] diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index cb46c69832..6076c75f30 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -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 (length exp_vars == fam_arity) + ; checkTc (exp_vars `lengthIs` fam_arity) (wrongNumberOfParmsErr fam_arity) -- Typecheck RHS @@ -2295,7 +2295,7 @@ checkValidTyConTyVars 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) diff --git a/compiler/typecheck/TcUnify.hs b/compiler/typecheck/TcUnify.hs index f106268455..a1a2add2b7 100644 --- a/compiler/typecheck/TcUnify.hs +++ b/compiler/typecheck/TcUnify.hs @@ -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] - | 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 } diff --git a/compiler/typecheck/TcValidity.hs b/compiler/typecheck/TcValidity.hs index 0a7a0adf7f..a938d12a08 100644 --- a/compiler/typecheck/TcValidity.hs +++ b/compiler/typecheck/TcValidity.hs @@ -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 - | 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 @@ -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 - 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) } @@ -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 - 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 @@ -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 || - 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) } @@ -1239,7 +1239,7 @@ validDerivPred tv_set pred 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' @@ -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) - checkTc (length ty_pats == fam_arity) $ + checkTc (ty_pats `lengthIs` fam_arity) $ wrongNumberOfParmsErr (fam_arity - count isInvisibleTyConBinder fam_bndrs) -- report only explicit arguments diff --git a/compiler/types/Class.hs b/compiler/types/Class.hs index ecc7e2efa2..ae1047ebde 100644 --- a/compiler/types/Class.hs +++ b/compiler/types/Class.hs @@ -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 - = 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) diff --git a/compiler/types/Coercion.hs b/compiler/types/Coercion.hs index e1dcfde811..3f5036c4dd 100644 --- a/compiler/types/Coercion.hs +++ b/compiler/types/Coercion.hs @@ -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 - = ASSERT( coAxiomArity ax index == length args ) + = ASSERT( args `lengthIs` coAxiomArity ax index ) 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 - , n < length args + , args `lengthExceeds` n -> 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 - = ASSERT( and $ ((d <) . length) <$> argss ) + = ASSERT( and $ (`lengthExceeds` d) <$> argss ) (`getNth` d) <$> argss | d == 0 diff --git a/compiler/types/OptCoercion.hs b/compiler/types/OptCoercion.hs index 871840ed13..67644094ed 100644 --- a/compiler/types/OptCoercion.hs +++ b/compiler/types/OptCoercion.hs @@ -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 - = 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 - = ASSERT( length cos1 == length cos2 ) + = ASSERT( cos1 `equalLength` 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 ) - ASSERT( n == length tys2 ) + ASSERT( tys2 `lengthIs` n ) Just (decomposeCo n co) -- NB: n might be <> tyConArity tc -- e.g. data family T a :: * -> * diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 74ebfbeb9a..e6afeceb7f 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -676,7 +676,7 @@ mkPiTys tbs ty = foldr mkPiTy ty tbs isCoercionType :: Type -> Bool isCoercionType (TyConApp tc tys) | (tc `hasKey` eqPrimTyConKey) || (tc `hasKey` eqReprPrimTyConKey) - , length tys == 4 + , tys `lengthIs` 4 = True isCoercionType _ = False @@ -1897,7 +1897,7 @@ mkTyCoInScopeSet tys cos 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 @@ -1909,7 +1909,7 @@ zipTvSubst tvs tys 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 @@ -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 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. @@ -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 - = ASSERT( length tvs == length tys ) + = ASSERT( tvs `equalLength` tys ) 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 = - 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 -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. @@ -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 - = ASSERT( length tvs == length tys ) + = ASSERT( tvs `equalLength` 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] -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] -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 diff --git a/compiler/types/TyCon.hs b/compiler/types/TyCon.hs index 9f6486b182..7b433fab9e 100644 --- a/compiler/types/TyCon.hs +++ b/compiler/types/TyCon.hs @@ -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 _ (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 @@ -1734,7 +1734,7 @@ isDataSumTyCon_maybe :: TyCon -> Maybe [DataCon] 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 } @@ -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 - = 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, []) - GT -> Nothing + LT -> Nothing | otherwise = Nothing diff --git a/compiler/types/Type.hs b/compiler/types/Type.hs index 65c02ba719..8621e6cd52 100644 --- a/compiler/types/Type.hs +++ b/compiler/types/Type.hs @@ -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 - = 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) @@ -1094,7 +1094,7 @@ tyConAppArgN :: Int -> Type -> Type -- 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 @@ -1587,9 +1587,9 @@ isPredTy ty = go ty [] 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 @@ -1890,7 +1890,7 @@ mkFamilyTyConApp :: TyCon -> [Type] -> Type 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 diff --git a/compiler/utils/ListSetOps.hs b/compiler/utils/ListSetOps.hs index 88af48e41a..f1aa2c3755 100644 --- a/compiler/utils/ListSetOps.hs +++ b/compiler/utils/ListSetOps.hs @@ -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 - = 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 diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs index a4bc8d4653..35a6340fd4 100644 --- a/compiler/utils/Util.hs +++ b/compiler/utils/Util.hs @@ -36,9 +36,10 @@ module Util ( foldl1', foldl2, count, all2, - lengthExceeds, lengthIs, lengthAtLeast, + lengthExceeds, lengthIs, lengthIsNot, + lengthAtLeast, lengthAtMost, lengthLessThan, listLengthCmp, atLength, - equalLength, compareLength, leLength, + equalLength, neLength, compareLength, leLength, ltLength, isSingleton, only, singleton, notNull, snocView, @@ -494,6 +495,7 @@ lengthExceeds lst n | otherwise = atLength notNull False lst n +-- | @(lengthAtLeast xs n) = (length xs >= n)@ lengthAtLeast :: [a] -> Int -> Bool lengthAtLeast = atLength (const True) False @@ -505,6 +507,24 @@ lengthIs 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 @@ -514,10 +534,17 @@ listLengthCmp = atLength atLen atEnd atLen _ = GT equalLength :: [a] -> [b] -> Bool +-- ^ True if length xs == length ys 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 @@ -531,6 +558,13 @@ leLength xs ys = case compareLength xs ys of 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] diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 612c051a2c..9526feddaf 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -365,7 +365,7 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls 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) } diff --git a/compiler/vectorise/Vectorise/Utils/PADict.hs b/compiler/vectorise/Vectorise/Utils/PADict.hs index 9cd740cf53..4d32f5df74 100644 --- a/compiler/vectorise/Vectorise/Utils/PADict.hs +++ b/compiler/vectorise/Vectorise/Utils/PADict.hs @@ -22,6 +22,7 @@ import Var import Outputable import DynFlags import FastString +import Util import Control.Monad @@ -199,7 +200,7 @@ prDFunApply dfun tys = return $ Var dfun `mkTyApps` tys | Just tycons <- ctxs - , length tycons == length tys + , tycons `equalLength` tys = do pa <- builtin paTyCon pr <- builtin prTyCon diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs index b57a5a0a64..bb946cc7b1 100644 --- a/ghc/GHCi/UI/Monad.hs +++ b/ghc/GHCi/UI/Monad.hs @@ -46,6 +46,7 @@ import GHCi import GHCi.RemoteTypes import HsSyn (ImportDecl) import RdrName (RdrName) +import Util import Exception import Numeric @@ -396,8 +397,8 @@ printTimes dflags mallocs secs 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 |