Commit a786b136 authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent 811a2986
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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 <+>
......
......@@ -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
......
......@@ -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"
......
......@@ -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
......
......@@ -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)
......
......@@ -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)
......
......@@ -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
......
......@@ -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]
......
......@@ -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
......
......@@ -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!
......
......@@ -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
......
......@@ -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
......
......@@ -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.
......
......@@ -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))))
......
......@@ -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")
......
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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')]
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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"
......
......@@ -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 )
......
......@@ -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) }
......
......@@ -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