Commit 9e933350 authored by sof's avatar sof

[project @ 2001-10-25 02:13:10 by sof]

- Pet peeve removal / code tidyup, replaced various sub-optimal
  uses of 'length' with something a bit better, i.e., replaced
  the following patterns

   *  length as `cmpOp` length bs
   *  length as `cmpOp` val   -- incl. uses where val == 1 and val == 0
   *  {take,drop,splitAt} (length as) bs
   *  length [ () | pat <- as ]

  with uses of misc Util functions.

  I'd be surprised if there's a noticeable reduction in running
  times as a result of these changes, but every little bit helps.

  [ The changes have been tested wrt testsuite/ - I'm seeing a couple
    of unexpected breakages coming from CorePrep, but I'm currently
    assuming that these are due to other recent changes. ]

- compMan/CompManager.lhs: restored 4.08 compilability + some code
  cleanup.

None of these changes are HEADworthy.
parent dccacbf9
......@@ -57,7 +57,7 @@ import StgSyn ( StgOp(..) )
import BitSet ( BitSet, intBS )
import Outputable
import GlaExts
import Util ( nOfThem )
import Util ( nOfThem, lengthExceeds, listLengthCmp )
import ST
......@@ -349,7 +349,7 @@ pprAbsC stmt@(CCallTypedef is_tdef (CCallSpec op_str cconv _) uniq results args)
-- should ignore and a (possibly void) result.
non_void_results =
let nvrs = grab_non_void_amodes results
in ASSERT (length nvrs <= 1) nvrs
in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
pprAbsC (CCodeBlock lbl abs_C) _
= if not (maybeToBool(nonemptyAbsC abs_C)) then
......@@ -800,7 +800,7 @@ pprFCall call@(CCall (CCallSpec target cconv safety)) uniq args results vol_regs
non_void_results =
let nvrs = grab_non_void_amodes results
in ASSERT (length nvrs <= 1) nvrs
in ASSERT (listLengthCmp nvrs 1 /= GT) nvrs
-- there will usually be two results: a (void) state which we
-- should ignore and a (possibly void) result.
......@@ -947,7 +947,7 @@ process_casm results args string = process results args string
in
case (read_int other) of
[(num,css)] ->
if 0 <= num && num < length args
if num >= 0 && args `lengthExceeds` num
then parens (args !! num) <> process ress args css
else error ("process_casm: no such arg #:"++(show num)++" while processing \"" ++ string ++ "\".\n")
_ -> error ("process_casm: not %<num> while processing _casm_ \"" ++ string ++ "\".\n")
......
......@@ -377,4 +377,4 @@ isNeverActive act = False
isAlwaysActive AlwaysActive = True
isAlwaysActive other = False
\end{code}
\ No newline at end of file
\end{code}
......@@ -42,7 +42,7 @@ import Unique ( Unique, Uniquable(..) )
import CmdLineOpts ( opt_UnboxStrictFields )
import Maybe
import ListSetOps ( assoc )
import Util ( zipEqual, zipWithEqual )
import Util ( zipEqual, zipWithEqual, equalLength )
\end{code}
......@@ -216,7 +216,7 @@ mkDataCon :: Name
mkDataCon name arg_stricts fields
tyvars theta ex_tyvars ex_theta orig_arg_tys tycon
work_id wrap_id
= ASSERT(length arg_stricts == length orig_arg_tys)
= ASSERT(equalLength arg_stricts orig_arg_tys)
-- The 'stricts' passed to mkDataCon are simply those for the
-- source-language arguments. We add extra ones for the
-- dictionary arguments right here.
......
......@@ -23,6 +23,7 @@ module Demand(
#include "HsVersions.h"
import Outputable
import Util ( listLengthCmp )
\end{code}
......@@ -191,7 +192,7 @@ isBottomingStrictness (StrictnessInfo _ bot) = bot
isBottomingStrictness NoStrictnessInfo = False
-- appIsBottom returns true if an application to n args would diverge
appIsBottom (StrictnessInfo ds bot) n = bot && (n >= length ds)
appIsBottom (StrictnessInfo ds bot) n = bot && (listLengthCmp ds n /=GT) -- not more than 'n' elts in 'ds'.
appIsBottom NoStrictnessInfo n = False
ppStrictnessInfo NoStrictnessInfo = empty
......
......@@ -101,7 +101,7 @@ import NewDemand ( Demand(..), Keepity(..), DmdResult(..),
StrictSig, mkStrictSig, mkTopDmdType
)
import Outputable
import Util ( seqList )
import Util ( seqList, listLengthCmp )
import List ( replicate )
infixl 1 `setDemandInfo`,
......@@ -133,7 +133,7 @@ To be removed later
\begin{code}
mkNewStrictnessInfo :: Id -> Arity -> Demand.StrictnessInfo -> CprInfo -> StrictSig
mkNewStrictnessInfo id arity (Demand.StrictnessInfo ds res) cpr
| length ds <= arity
| listLengthCmp ds arity /= GT -- length ds <= arity
-- Sometimes the old strictness analyser has more
-- demands than the arity justifies
= mk_strict_sig id arity $
......
......@@ -87,6 +87,7 @@ import Unique ( mkBuiltinUnique )
import Maybes
import PrelNames
import Maybe ( isJust )
import Util ( dropList, isSingleton )
import Outputable
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
......@@ -256,7 +257,7 @@ mkDataConWrapId data_con
-- we want to see that w is strict in its two arguments
wrap_rhs | isNewTyCon tycon
= ASSERT( null ex_tyvars && null ex_dict_args && length orig_arg_tys == 1 )
= ASSERT( null ex_tyvars && null ex_dict_args && isSingleton orig_arg_tys )
-- No existentials on a newtype, but it can have a context
-- e.g. newtype Eq a => T a = MkT (...)
mkLams tyvars $ mkLams dict_args $ Lam id_arg1 $
......@@ -537,7 +538,7 @@ rebuildConArgs (arg:args) (str:stricts) us
= splitProductType "rebuildConArgs" arg_ty
unpacked_args = zipWith (mkSysLocal SLIT("rb")) us con_arg_tys
(binds, args') = rebuildConArgs args stricts (drop (length con_arg_tys) us)
(binds, args') = rebuildConArgs args stricts (dropList con_arg_tys us)
con_app = mkConApp pack_con (map Type tycon_args ++ map Var unpacked_args)
in
(NonRec arg con_app : binds, unpacked_args ++ args')
......
......@@ -23,6 +23,7 @@ module NewDemand(
import BasicTypes ( Arity )
import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
import UniqFM ( ufmToList )
import Util ( listLengthCmp )
import Outputable
\end{code}
......@@ -169,7 +170,7 @@ topSig = StrictSig topDmdType
botSig = StrictSig botDmdType
-- appIsBottom returns true if an application to n args would diverge
appIsBottom (StrictSig (DmdType _ ds BotRes)) n = n >= length ds
appIsBottom (StrictSig (DmdType _ ds BotRes)) n = listLengthCmp ds n /= GT
appIsBottom _ _ = False
isBottomingSig (StrictSig (DmdType _ _ BotRes)) = True
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgClosure.lhs,v 1.50 2001/10/03 13:59:22 simonpj Exp $
% $Id: CgClosure.lhs,v 1.51 2001/10/25 02:13:11 sof Exp $
%
\section[CgClosure]{Code generation for closures}
......@@ -51,7 +51,7 @@ import Module ( Module, pprModule )
import ListSetOps ( minusList )
import PrimRep ( PrimRep(..) )
import PprType ( showTypeCategory )
import Util ( isIn )
import Util ( isIn, splitAtList )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
......@@ -328,9 +328,7 @@ closureCodeBody binder_info closure_info cc all_args body
DirectEntry lbl arity regs -> regs
other -> [] -- "(HWL ignored; no args passed in regs)"
num_arg_regs = length arg_regs
(reg_args, stk_args) = splitAt num_arg_regs all_args
(reg_args, stk_args) = splitAtList arg_regs all_args
(sp_stk_args, stk_offsets, stk_tags)
= mkTaggedVirtStkOffsets vSp idPrimRep stk_args
......
......@@ -69,8 +69,8 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
= ASSERT(not (isDllConApp con args)) -- checks for litlit args too
ASSERT(length args == dataConRepArity con)
= ASSERT( not (isDllConApp con args) ) -- checks for litlit args too
ASSERT( args `lengthIs` dataConRepArity con )
-- LAY IT OUT
getArgAmodes args `thenFC` \ amodes ->
......@@ -234,7 +234,7 @@ bindUnboxedTupleComponents
bindUnboxedTupleComponents args
= -- Assign as many components as possible to registers
let (arg_regs, _leftovers) = assignRegs [] (map idPrimRep args)
(reg_args, stk_args) = splitAt (length arg_regs) args
(reg_args, stk_args) = splitAtList arg_regs args
in
-- Allocate the rest on the stack (ToDo: separate out pointers)
......@@ -268,7 +268,7 @@ sure the @amodes@ passed don't conflict with each other.
cgReturnDataCon :: DataCon -> [CAddrMode] -> Code
cgReturnDataCon con amodes
= ASSERT(length amodes == dataConRepArity con)
= ASSERT( amodes `lengthIs` dataConRepArity con )
getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_sp sequel) ->
case sequel of
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: CgExpr.lhs,v 1.45 2001/10/17 14:24:52 simonmar Exp $
% $Id: CgExpr.lhs,v 1.46 2001/10/25 02:13:11 sof Exp $
%
%********************************************************
%* *
......@@ -48,6 +48,7 @@ import Maybes ( maybeToBool )
import ListSetOps ( assocMaybe )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import Util ( lengthIs )
import Outputable
\end{code}
......@@ -362,7 +363,7 @@ mkRhsClosure bndr cc bi srt
[] -- No args; a thunk
body@(StgApp fun_id args)
| length args + 1 == arity
| args `lengthIs` (arity-1)
&& all isFollowableRep (map idPrimRep fvs)
&& isUpdatable upd_flag
&& arity <= mAX_SPEC_AP_SIZE
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%
% $Id: CgLetNoEscape.lhs,v 1.15 2001/09/26 15:11:50 simonpj Exp $
% $Id: CgLetNoEscape.lhs,v 1.16 2001/10/25 02:13:11 sof Exp $
%
%********************************************************
%* *
......@@ -35,8 +35,9 @@ import CostCentre ( CostCentreStack )
import Id ( idPrimRep, Id )
import Var ( idUnique )
import PrimRep ( PrimRep(..), retPrimRepSize )
import Unique ( Unique )
import BasicTypes ( RecFlag(..) )
import Unique ( Unique )
import Util ( splitAtList )
\end{code}
%************************************************************************
......@@ -198,7 +199,7 @@ cgLetNoEscapeBody binder cc all_args body uniq
let
arg_kinds = map idPrimRep all_args
(arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
(reg_args, stk_args) = splitAt (length arg_regs) all_args
(reg_args, stk_args) = splitAtList arg_regs all_args
(sp_stk_args, stk_offsets, stk_tags)
= mkTaggedVirtStkOffsets sp idPrimRep stk_args
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
% $Id: ClosureInfo.lhs,v 1.49 2001/10/18 16:29:13 simonpj Exp $
% $Id: ClosureInfo.lhs,v 1.50 2001/10/25 02:13:11 sof Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
......@@ -89,7 +89,7 @@ import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
import SMRep -- all of it
import Type ( isUnLiftedType, Type )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel )
import Util ( mapAccumL )
import Util ( mapAccumL, listLengthCmp, lengthIs )
import Outputable
\end{code}
......@@ -635,7 +635,7 @@ getEntryConvention name lf_info arg_kinds
case lf_info of
LFReEntrant _ _ arity _ ->
if arity == 0 || (length arg_kinds) < arity then
if arity == 0 || (listLengthCmp arg_kinds arity == LT) then
StdEntry (mkStdEntryLabel name)
else
DirectEntry (mkFastEntryLabel name arity) arity arg_regs
......@@ -678,7 +678,7 @@ getEntryConvention name lf_info arg_kinds
-> StdEntry (mkReturnPtLabel (nameUnique name))
LFLetNoEscape arity
-> if (arity /= length arg_kinds) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
-> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
where
(arg_regs, _) = assignRegs [] arg_kinds
......
......@@ -77,11 +77,12 @@ import IOExts
import Interpreter ( HValue )
import HscMain ( hscStmt )
import PrelGHC ( unsafeCoerce# )
#endif
-- lang
import Foreign
import CForeign
#endif
import Exception ( Exception, try, throwDyn )
-- std
......@@ -828,9 +829,7 @@ findInSummaries old_summaries mod_name
findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary
findModInSummaries old_summaries mod
= case [s | s <- old_summaries, ms_mod s == mod] of
[] -> Nothing
(s:_) -> Just s
= listToMaybe [s | s <- old_summaries, ms_mod s == mod]
-- Return (names of) all those in modsDone who are part of a cycle
-- as defined by theGraph.
......@@ -848,7 +847,7 @@ findPartiallyCompletedCycles modsDone theGraph
chewed_rest = chew rest
in
if not (null mods_in_this_cycle)
&& length mods_in_this_cycle < length names_in_this_cycle
&& compareLength mods_in_this_cycle names_in_this_cycle == LT
then mods_in_this_cycle ++ chewed_rest
else chewed_rest
......@@ -1018,7 +1017,7 @@ simple_transitive_closure graph set
= let set2 = nub (concatMap dsts set ++ set)
dsts node = fromMaybe [] (lookup node graph)
in
if length set == length set2
if equalLength set set2
then set
else simple_transitive_closure graph set2
......@@ -1071,22 +1070,29 @@ downsweep rootNm old_summaries
getRootSummary file
| haskellish_src_file file
= do exists <- doesFileExist file
if exists then summariseFile file else do
throwDyn (CmdLineError ("can't find file `" ++ file ++ "'"))
when (not exists)
(throwDyn (CmdLineError ("can't find file `" ++ file ++ "'")))
summariseFile file
| otherwise
= do exists <- doesFileExist hs_file
if exists then summariseFile hs_file else do
exists <- doesFileExist lhs_file
if exists then summariseFile lhs_file else do
let mod_name = mkModuleName file
maybe_summary <- getSummary mod_name
case maybe_summary of
Nothing -> packageModErr mod_name
Just s -> return s
= do mb_file <- findFile [hs_file, lhs_file]
case mb_file of
Just x -> summariseFile x
Nothing -> do
let mod_name = mkModuleName file
maybe_summary <- getSummary mod_name
case maybe_summary of
Nothing -> packageModErr mod_name
Just s -> return s
where
hs_file = file ++ ".hs"
lhs_file = file ++ ".lhs"
findFile :: [FilePath] -> IO (Maybe FilePath)
findFile [] = return Nothing
findFile (x:xs) = do
flg <- doesFileExist x
if flg then return (Just x) else findFile xs
getSummary :: ModuleName -> IO (Maybe ModSummary)
getSummary nm
= do found <- findModule nm
......
......@@ -37,6 +37,7 @@ import Maybes
import OrdList
import ErrUtils
import CmdLineOpts
import Util ( listLengthCmp )
import Outputable
\end{code}
......@@ -415,8 +416,9 @@ corePrepExprFloat env expr@(App _ _)
where
stricts = case idNewStrictness v of
StrictSig (DmdType _ demands _)
| depth >= length demands -> demands
| otherwise -> []
| listLengthCmp demands depth /= GT -> demands
-- length demands <= depth
| otherwise -> []
-- If depth < length demands, then we have too few args to
-- satisfy strictness info so we have to ignore all the
-- strictness info, e.g. + (error "urk")
......
......@@ -68,6 +68,7 @@ import BasicTypes ( Arity )
import Unique ( Unique )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
\end{code}
......@@ -623,7 +624,7 @@ exprIsConApp_maybe (Note (Coerce to_ty from_ty) expr)
new_val_args = zipWith mk_coerce to_arg_tys val_args
in
ASSERT( all isTypeArg (take arity args) )
ASSERT( length val_args == length to_arg_tys )
ASSERT( equalLength val_args to_arg_tys )
Just (dc, map Type tc_arg_tys ++ new_val_args)
}}
......@@ -644,7 +645,7 @@ exprIsConApp_maybe expr = analyse (collectArgs expr)
where
analyse (Var fun, args)
| Just con <- isDataConId_maybe fun,
length args >= dataConRepArity con
args `lengthAtLeast` dataConRepArity con
-- Might be > because the arity excludes type args
= Just (con,args)
......@@ -961,7 +962,7 @@ eqExpr e1 e2
eq env (Let (NonRec v1 r1) e1)
(Let (NonRec v2 r2) e2) = eq env r1 r2 && eq (extendVarEnv env v1 v2) e1 e2
eq env (Let (Rec ps1) e1)
(Let (Rec ps2) e2) = length ps1 == length ps2 &&
(Let (Rec ps2) e2) = equalLength ps1 ps2 &&
and (zipWith eq_rhs ps1 ps2) &&
eq env' e1 e2
where
......@@ -969,7 +970,7 @@ eqExpr e1 e2
eq_rhs (_,r1) (_,r2) = eq env' r1 r2
eq env (Case e1 v1 a1)
(Case e2 v2 a2) = eq env e1 e2 &&
length a1 == length a2 &&
equalLength a1 a2 &&
and (zipWith (eq_alt env') a1 a2)
where
env' = extendVarEnv env v1 v2
......
......@@ -38,6 +38,7 @@ import TyCon ( tupleTyConBoxity, isTupleTyCon )
import PprType ( pprParendType, pprTyVarBndr )
import BasicTypes ( tupleParens )
import PprEnv
import Util ( lengthIs )
import Outputable
\end{code}
......@@ -184,7 +185,7 @@ ppr_expr add_par pe expr@(App fun arg)
-> tupleParens (tupleTyConBoxity tc) pp_tup_args
where
tc = dataConTyCon dc
saturated = length val_args == idArity f
saturated = val_args `lengthIs` idArity f
other -> add_par (hang (pOcc pe f) 2 pp_args)
......
......@@ -28,6 +28,7 @@ import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
import UniqSet
import Util ( takeList, splitAtList )
import Outputable
#include "HsVersions.h"
......@@ -187,7 +188,7 @@ check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
check' [] = ([([],[])],emptyUniqSet)
check' [EqnInfo n ctx ps (MatchResult CanFail _)]
| all_vars ps = ([(take (length ps) (repeat new_wild_pat),[])], unitUniqSet n)
| all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n)
check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
| all_vars ps = (pats, addOneToUniqSet indexs n)
......@@ -244,8 +245,8 @@ must be one Variable to be complete.
process_literals :: [HsLit] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
process_literals used_lits qs
| length default_eqns == 0 = ([make_row_vars used_lits (head qs)]++pats,indexs)
| otherwise = (pats_default,indexs_default)
| null default_eqns = ([make_row_vars used_lits (head qs)]++pats,indexs)
| otherwise = (pats_default,indexs_default)
where
(pats,indexs) = process_explicit_literals used_lits qs
default_eqns = (map remove_var (filter is_var qs))
......@@ -283,8 +284,9 @@ same constructor.
split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
split_by_constructor qs | length unused_cons /= 0 = need_default_case used_cons unused_cons qs
| otherwise = no_need_default_case used_cons qs
split_by_constructor qs
| not (null unused_cons) = need_default_case used_cons unused_cons qs
| otherwise = no_need_default_case used_cons qs
where
used_cons = get_used_cons qs
unused_cons = get_unused_cons used_cons
......@@ -319,8 +321,8 @@ no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
need_default_case used_cons unused_cons qs
| length default_eqns == 0 = (pats_default_no_eqns,indexs)
| otherwise = (pats_default,indexs_default)
| null default_eqns = (pats_default_no_eqns,indexs)
| otherwise = (pats_default,indexs_default)
where
(pats,indexs) = no_need_default_case used_cons qs
default_eqns = (map remove_var (filter is_var qs))
......@@ -368,7 +370,7 @@ remove_first_column (ConPat con _ _ _ con_pats) qs =
make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat
make_row_vars used_lits (EqnInfo _ _ pats _ ) =
(VarPatIn new_var:take (length (tail pats)) (repeat new_wild_pat),[(new_var,used_lits)])
(VarPatIn new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)])
where new_var = hash_x
hash_x = mkLocalName unboundKey {- doesn't matter much -}
......@@ -376,7 +378,7 @@ hash_x = mkLocalName unboundKey {- doesn't matter much -}
noSrcLoc
make_row_vars_for_constructor :: EquationInfo -> [WarningPat]
make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = take (length (tail pats)) (repeat new_wild_pat)
make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat)
compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool
compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2
......@@ -524,10 +526,8 @@ make_con (ConPat id _ _ _ _) (p:q:ps, constraints)
make_con (ConPat id _ _ _ pats) (ps,constraints)
| isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints)
| otherwise = (ConPatIn name pats_con : rest_pats, constraints)
where num_args = length pats
name = getName id
pats_con = take num_args ps
rest_pats = drop num_args ps
where name = getName id
(pats_con, rest_pats) = splitAtList pats ps
tc = dataConTyCon id
......@@ -538,7 +538,7 @@ make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wi
fixity = panic "Check.make_whole_con: Guessing fixity"
name = getName con
arity = dataConSourceArity con
pats = take arity (repeat new_wild_pat)
pats = replicate arity new_wild_pat
new_wild_pat :: WarningPat
......
......@@ -63,6 +63,7 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name,
plusIntegerName, timesIntegerName )
import Outputable
import UnicodeUtil ( stringToUtf8 )
import Util ( isSingleton )
\end{code}
......@@ -430,7 +431,7 @@ mkSelectorBinds (VarPat v) val_expr
= returnDs [(v, val_expr)]
mkSelectorBinds pat val_expr
| length binders == 1 || is_simple_pat pat
| isSingleton binders || is_simple_pat pat
= newSysLocalDs (exprType val_expr) `thenDs` \ val_var ->
-- For the error message we don't use mkErrorAppDs to avoid
......
......@@ -27,6 +27,7 @@ import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
import BasicTypes ( Boxity(..) )
import UniqSet
import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
import Util ( lengthExceeds )
import Outputable
\end{code}
......@@ -62,7 +63,7 @@ matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
match vars qs
where (pats,indexs) = check qs
incomplete = dopt Opt_WarnIncompletePatterns dflags
&& (length pats /= 0)
&& (not (null pats))
shadow = dopt Opt_WarnOverlappingPatterns dflags
&& sizeUniqSet indexs < no_eqns
no_eqns = length qs
......@@ -85,7 +86,7 @@ The next two functions create the warning message.
dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn
where
warn | length qs > maximum_output
warn | qs `lengthExceeds` maximum_output
= pp_context ctx (ptext SLIT("are overlapped"))
(\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
ptext SLIT("..."))
......@@ -103,8 +104,8 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
(take maximum_output pats))
$$ dots))
dots | length pats > maximum_output = ptext SLIT("...")
| otherwise = empty
dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
| otherwise = empty
pp_context NoMatchContext msg rest_of_msg_fun
= dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
......
......@@ -538,10 +538,10 @@ schemeT d s p app
| let isVoidRepAtom (_, AnnVar v) = VoidRep == typePrimRep (idType v)
isVoidRepAtom (_, AnnNote n e) = isVoidRepAtom e
in is_con_call && isUnboxedTupleCon con
&& ( (length args_r_to_l == 2 && isVoidRepAtom (last (args_r_to_l)))
|| (length args_r_to_l == 1)
&& ( (args_r_to_l `lengthIs` 2 && isVoidRepAtom (last (args_r_to_l)))
|| (isSingleton args_r_to_l) )
)
= --trace (if length args_r_to_l == 1
= --trace (if isSingleton args_r_to_l
-- then "schemeT: unboxed singleton"
-- else "schemeT: unboxed pair with Void first component") (
schemeT d s p (head args_r_to_l)
......@@ -863,12 +863,12 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep
maybe_getCCallReturnRep fn_ty
= let (a_tys, r_ty) = splitRepFunTys fn_ty
maybe_r_rep_to_go
= if length r_reps == 1 then Nothing else Just (r_reps !! 1)
= if isSingleton r_reps then Nothing else Just (r_reps !! 1)
(r_tycon, r_reps)
= case splitTyConApp_maybe (repType r_ty) of
(Just (tyc, tys)) -> (tyc, map typePrimRep tys)
Nothing -> blargh
ok = ( (length r_reps == 2 && VoidRep == head r_reps)
ok = ( ( r_reps `lengthIs` 2 && VoidRep == head r_reps)
|| r_reps == [VoidRep] )
&& isUnboxedTupleTyCon r_tycon
&& case maybe_r_rep_to_go of
......
......@@ -48,7 +48,7 @@ import Type ( Kind, eqKind )
import BasicTypes ( Arity )
import FiniteMap ( lookupFM )
import CostCentre
import Util ( eqListBy )
import Util ( eqListBy, lengthIs )
import Outputable
\end{code}
......@@ -159,7 +159,7 @@ toUfApp (Var v) as
-> UfTuple (mk_hs_tup_con tc dc) tup_args
where
val_args = dropWhile isTypeArg as
saturated = length val_args == idArity v
saturated = val_args `lengthIs` idArity v
tup_args = map toUfExpr val_args
tc = dataConTyCon dc
;
......
......@@ -42,7 +42,7 @@ import FunDeps ( pprFundeps )
import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString )
import Outputable
import Util ( eqListBy )
import Util ( eqListBy, count )
import SrcLoc ( SrcLoc )
import FastString
......@@ -445,11 +445,17 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
-- class, data, newtype, synonym decls
countTyClDecls decls
= (length [() | ClassDecl {} <- decls],
length [() | TySynonym {} <- decls],
length [() | IfaceSig {} <- decls],
length [() | TyData {tcdND = DataType} <- decls],
length [() | TyData {tcdND = NewType} <- decls])
= (count isClassDecl decls,
count isSynDecl decls,
count isIfaceSigDecl decls,