import BitSet ( BitSet, intBS )
import Outputable
import GlaExts
-import Util ( nOfThem )
+import Util ( nOfThem, lengthExceeds, listLengthCmp )
import ST
-- 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
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.
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")
isAlwaysActive AlwaysActive = True
isAlwaysActive other = False
-\end{code}
\ No newline at end of file
+\end{code}
import CmdLineOpts ( opt_UnboxStrictFields )
import Maybe
import ListSetOps ( assoc )
-import Util ( zipEqual, zipWithEqual )
+import Util ( zipEqual, zipWithEqual, equalLength )
\end{code}
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.
#include "HsVersions.h"
import Outputable
+import Util ( listLengthCmp )
\end{code}
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
StrictSig, mkStrictSig, mkTopDmdType
)
import Outputable
-import Util ( seqList )
+import Util ( seqList, listLengthCmp )
import List ( replicate )
infixl 1 `setDemandInfo`,
\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 $
import Maybes
import PrelNames
import Maybe ( isJust )
+import Util ( dropList, isSingleton )
import Outputable
import ListSetOps ( assoc, assocMaybe )
import UnicodeUtil ( stringToUtf8 )
-- 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 $
= 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')
import BasicTypes ( Arity )
import VarEnv ( VarEnv, emptyVarEnv, isEmptyVarEnv )
import UniqFM ( ufmToList )
+import Util ( listLengthCmp )
import Outputable
\end{code}
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}
import ListSetOps ( minusList )
import PrimRep ( PrimRep(..) )
import PprType ( showTypeCategory )
-import Util ( isIn )
+import Util ( isIn, splitAtList )
import CmdLineOpts ( opt_SccProfilingOn )
import Outputable
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
-> [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 ->
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)
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 $
%
%********************************************************
%* *
import ListSetOps ( assocMaybe )
import Unique ( mkBuiltinUnique )
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
+import Util ( lengthIs )
import Outputable
\end{code}
[] -- 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 $
%
%********************************************************
%* *
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}
%************************************************************************
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}
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}
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
-> 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
import Interpreter ( HValue )
import HscMain ( hscStmt )
import PrelGHC ( unsafeCoerce# )
-#endif
-- lang
import Foreign
import CForeign
+#endif
+
import Exception ( Exception, try, throwDyn )
-- std
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.
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
= 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
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
import OrdList
import ErrUtils
import CmdLineOpts
+import Util ( listLengthCmp )
import Outputable
\end{code}
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")
import Unique ( Unique )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
+import Util ( equalLength, lengthAtLeast )
\end{code}
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)
}}
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)
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
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
import PprType ( pprParendType, pprTyVarBndr )
import BasicTypes ( tupleParens )
import PprEnv
+import Util ( lengthIs )
import Outputable
\end{code}
-> 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)
import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
import UniqSet
+import Util ( takeList, splitAtList )
import Outputable
#include "HsVersions.h"
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)
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))
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
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))
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 -}
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
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
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
plusIntegerName, timesIntegerName )
import Outputable
import UnicodeUtil ( stringToUtf8 )
+import Util ( isSingleton )
\end{code}
= 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
import BasicTypes ( Boxity(..) )
import UniqSet
import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
+import Util ( lengthExceeds )
import Outputable
\end{code}
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
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("..."))
(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))
| 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)
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
import BasicTypes ( Arity )
import FiniteMap ( lookupFM )
import CostCentre
-import Util ( eqListBy )
+import Util ( eqListBy, lengthIs )
import Outputable
\end{code}
-> 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
;
import Class ( FunDep, DefMeth(..) )
import CStrings ( CLabelString )
import Outputable
-import Util ( eqListBy )
+import Util ( eqListBy, count )
import SrcLoc ( SrcLoc )
import FastString
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,
+ count isDataTy decls,
+ count isNewTy decls)
+ where
+ isDataTy TyData{tcdND=DataType} = True
+ isDataTy _ = False
+
+ isNewTy TyData{tcdND=NewType} = True
+ isNewTy _ = False
\end{code}
\begin{code}
usOnceTyConName, usManyTyConName
)
import FiniteMap
-import Util ( eqListBy )
+import Util ( eqListBy, lengthIs )
import Outputable
\end{code}
where
generic_case = foldl HsAppTy (HsTyVar (getName tc)) tys'
tys' = map toHsType tys
- saturated = length tys == tyConArity tc
+ saturated = tys `lengthIs` tyConArity tc
toHsType ty@(ForAllTy _ _) = case tcSplitSigmaTy ty of
(tvs, preds, tau) -> HsForAllTy (Just (map toHsTyVar tvs))
= ([],[],env,args,funty)
get_term_args n max args env funty
| (case known_clo of
- Just (_,_,needed,_) -> (length needed == n)
+ Just (_,_,needed,_) -> needed `lengthIs` n
Nothing -> False)
-- Stop if we have the optimal number for a direct call
= ([],[],env,args,funty)
-- the "callfunc" case.
basic_call_instr =
case known_clo of
- Just (known_env,fun,needed,fvs) | (length needed == length now_args) &&
+ Just (known_env,fun,needed,fvs) | (equalLength needed now_args) &&
all (\x -> elemIlxTyEnv x env) free_ilx_tvs ->
vcat [text "callclo class",
nameReference env (idName fun) <+> singleQuotes (ilxEnvQualifyByModule env (ppr fun)),
import Maybe
import PrimOp
+import Util ( lengthIs )
#include "HsVersions.h"
-- If we've got the wrong one, this is _|_, and the
-- casting will catch this with an exception.
-javaCase r e x [(DataAlt d,bs,rhs)] | length bs > 0
+javaCase r e x [(DataAlt d,bs,rhs)] | not (null bs)
= java_expr PushExpr e ++
[ var [Final] (javaName x)
(whnf primRep (vmPOP (primRepToType primRep))) ] ++
| otherwise = javaApp r f as
javaApp r (CoreSyn.Var f) as
= case isDataConId_maybe f of {
- Just dc | length as == dataConRepArity dc
+ Just dc | as `lengthIs` dataConRepArity dc
-- NOTE: Saturated constructors never returning a primitive at this point
--
-- We push the arguments backwards, because we are using
import Outputable
import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt )
+import List ( replicate )
import System ( ExitCode(..), exitWith )
import IO ( hPutStr, hPutStrLn, stderr )
\end{code}
doc,
text ""]
where
- line = text (take 20 (repeat '='))
+ line = text (replicate 20 '=')
\end{code}
}}}
compMsg use_object mod location =
- mod_str ++ take (max 0 (16 - length mod_str)) (repeat ' ')
+ mod_str ++ replicate (max 0 (16 - length mod_str)) ' '
++" ( " ++ unJust "hscRecomp" (ml_hs_file location) ++ ", "
++ (if use_object
then unJust "hscRecomp" (ml_obj_file location)
import HsSyn
import Outputable
import Char ( isSpace )
+import Util ( count )
\end{code}
%************************************************************************
trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls)
- fixity_ds = length [() | FixD d <- decls]
+ fixity_ds = count (\ x -> case x of { FixD{} -> True; _ -> False}) decls
-- NB: this omits fixity decls on local bindings and
-- in class decls. ToDo
inst_decls = [d | InstD d <- decls]
inst_ds = length inst_decls
- default_ds = length [() | DefD _ <- decls]
+ default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
val_decls = [d | ValD d <- decls]
real_exports = case exports of { Nothing -> []; Just es -> es }
n_exports = length real_exports
- export_ms = length [() | IEModuleContents _ <- real_exports]
+ export_ms = count (\ e -> case e of { IEModuleContents{} -> True;_ -> False})
+ real_exports
export_ds = n_exports - export_ms
export_all = case exports of { Nothing -> 1; other -> 0 }
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.88 2001/10/22 13:45:15 simonmar Exp $
+-- $Id: Main.hs,v 1.89 2001/10/25 02:13:13 sof Exp $
--
-- GHC Driver program
--
-- -ohi sanity checking
ohi <- readIORef v_Output_hi
if (isJust ohi &&
- (mode == DoMake || mode == DoInteractive || length srcs > 1))
+ (mode == DoMake || mode == DoInteractive || srcs `lengthExceeds` 1))
then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
else do
-- -o sanity checking
o_file <- readIORef v_Output_file
- if (length srcs > 1 && isJust o_file && mode /= DoLink && mode /= DoMkDLL)
+ if (srcs `lengthExceeds` 1 && isJust o_file && mode /= DoLink && mode /= DoMkDLL)
then throwDyn (UsageError "can't apply -o to multiple source files")
else do
= mkPrimTyCon name kind arity arg_vrcs rep
where
arity = length arg_vrcs
- kind = mkArrowKinds (take arity (repeat liftedTypeKind)) result_kind
+ kind = mkArrowKinds (replicate arity liftedTypeKind) result_kind
result_kind = unliftedTypeKind -- all primitive types are unlifted
pcPrimTyCon0 :: Name -> PrimRep -> TyCon
import VarEnv
import CoreLint ( showPass, endPass )
import Outputable
-import Util ( mapAccumL )
+import Util ( mapAccumL, lengthExceeds )
import UniqFM
\end{code}
= CS (addToUFM_C combine cs hash [(id, expr)]) in_scope sub
where
hash = hashExpr expr
- combine old new = WARN( length result > 4, text "extendCSEnv: long list:" <+> ppr result )
+ combine old new = WARN( result `lengthExceeds` 4, text "extendCSEnv: long list:" <+> ppr result )
result
where
result = new ++ old
import Var ( Id, idType, isTyVar )
import Type ( isUnLiftedType )
import VarSet
-import Util ( zipEqual, zipWithEqual )
+import Util ( zipEqual, zipWithEqual, count )
import Outputable
\end{code}
-- E -> ...not mentioning x...
n_alts = length used_in_flags
- n_used_alts = length [() | True <- used_in_flags]
+ n_used_alts = count id used_in_flags -- returns number of Trues in list.
can_push = n_used_alts == 1 -- Used in just one branch
|| (is_case && -- We are looking at case alternatives
case r of
-- [Andre] test: do it only if we have more than one static argument.
--Just (tyargs,args) | any isStatic args
- Just (tyargs,args) | length (filter isStatic args) > 1
+ Just (tyargs,args) | (filter isStatic args) `lengthExceeds` 1
-> newSATName binder (new_ty tyargs args) `thenSAT` \ binder' ->
mkNewRhs binder binder' tyargs args rhs `thenSAT` \ new_rhs ->
trace ("SAT "++ show (length (filter isStatic args))) (
-- now, we drop the ones that are
-- static, that is, the ones we will not pass to the local function
- l = length dict_tys
tv_tmpl' = dropStatics tyargs tv_tmpl
- dict_tys' = dropStatics (take l args) dict_tys
- reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
+
+ (args1, args2) = splitAtList dict_tys args
+ dict_tys' = dropStatics args1 dict_tys
+ reg_arg_tys' = dropStatics args2 reg_arg_tys
+
tau_ty' = glueTyArgs reg_arg_tys' res_type
mk_inst_tyenv [] _ = emptyVarEnv
import Util ( mapAccumL )
#ifdef DEBUG
+import Util ( lengthIs )
import Outputable
#endif
\end{code}
srt_info | srt_length == 0 = NoSRT
| otherwise = SRT initial_offset srt_length
- in ASSERT( srt_length == length this_srt )
+ in ASSERT( this_srt `lengthIs` srt_length )
(srt_info, this_srt, new_offset)
\end{code}
]
where
results = unionManyBags (map (ruleCheckBind (phase, rule_pat)) binds)
- line = text (take 20 (repeat '-'))
+ line = text (replicate 20 '-')
type RuleCheckEnv = (CompilerPhase, String) -- Phase and Pattern
import Outputable
import Maybes ( orElse )
-import Util ( mapAccumL )
+import Util ( mapAccumL, lengthAtLeast )
import List ( nubBy, partition )
import UniqSupply
import Outputable
good_calls :: [[CoreArg]]
good_calls = [ pats
| (con_env, call_args) <- all_calls,
- length call_args >= n_bndrs, -- App is saturated
+ call_args `lengthAtLeast` n_bndrs, -- App is saturated
let call = (bndrs `zip` call_args),
any (good_arg con_env occs) call, -- At least one arg is a constr app
let (_, pats) = argsToPats con_env us call_args
is_con_app_maybe env expr
= case collectArgs expr of
(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 (DataAlt con,args)
import BasicTypes ( Activation( AlwaysActive ) )
import Bag
import List ( partition )
-import Util ( zipEqual, zipWithEqual, cmpList )
+import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
+ equalLength, lengthAtLeast )
import Outputable
specDefn subst calls (fn, rhs)
-- The first case is the interesting one
- | n_tyvars == length rhs_tyvars -- Rhs of fn's defn has right number of big lambdas
- && n_dicts <= length rhs_bndrs -- and enough dict args
+ | rhs_tyvars `lengthIs` n_tyvars -- Rhs of fn's defn has right number of big lambdas
+ && rhs_bndrs `lengthAtLeast` n_dicts -- and enough dict args
&& not (null calls_for_me) -- And there are some calls to specialise
&& not (isDataConWrapId fn) -- And it's not a data con wrapper, which have
-- stupid overloading that simply discard the dictionary
UsageDetails, -- Usage details from specialised body
CoreRule) -- Info for the Id's SpecEnv
spec_call (CallKey call_ts, (call_ds, call_fvs))
- = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts )
+ = ASSERT( call_ts `lengthIs` n_tyvars && call_ds `lengthIs` n_dicts )
-- Calls are only recorded for properly-saturated applications
-- Suppose f's defn is f = /\ a b c d -> \ d1 d2 -> rhs
where
my_zipEqual doc xs ys
- | length xs /= length ys = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
- | otherwise = zipEqual doc xs ys
+ | not (equalLength xs ys) = pprPanic "my_zipEqual" (ppr xs $$ ppr ys $$ (ppr fn <+> ppr call_ts) $$ ppr rhs)
+ | otherwise = zipEqual doc xs ys
dropInline :: CoreExpr -> (Bool, CoreExpr)
dropInline (Note InlineMe rhs) = (True, rhs)
mkCallUDs subst f args
| null theta
- || length spec_tys /= n_tyvars
- || length dicts /= n_dicts
+ || not (spec_tys `lengthIs` n_tyvars)
+ || not ( dicts `lengthIs` n_dicts)
|| maybeToBool (lookupRule (\act -> True) (substInScope subst) f args)
-- There's already a rule covering this call. A typical case
-- is where there's an explicit user-provided rule. Then
import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity )
import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
import FastTypes hiding ( fastOr )
+import Util ( listLengthCmp )
import Outputable
infixr 9 `thenLne`
any top-level PAPs.
\begin{code}
-isPAP (StgApp f args) = idArity f > length args
+isPAP (StgApp f args) = listLengthCmp args (idArity f) == LT -- idArity f > length args
isPAP _ = False
\end{code}
isUnLiftedType, isTyVarTy, splitForAllTys, Type
)
import TyCon ( TyCon, isDataTyCon, tyConDataCons )
-import Util ( zipEqual )
+import Util ( zipEqual, equalLength )
import Outputable
infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
-- This almost certainly does not work for existential constructors
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
- checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
+ checkL (equalLength arg_tys args) (mkAlgAltMsg3 con args)
`thenL_`
mapL check (zipEqual "lintAlgAlt:stg" arg_tys args) `thenL_`
returnL ()
keysUFM, minusUFM, ufmToList, filterUFM )
import Type ( isUnLiftedType )
import CoreLint ( showPass, endPass )
-import Util ( mapAndUnzip, mapAccumL, mapAccumR )
+import Util ( mapAndUnzip, mapAccumL, mapAccumR, lengthIs, equalLength )
import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive )
import Maybes ( orElse, expectJust )
import Outputable
-- ds can be empty, when we are just seq'ing the thing
-- If so we must make up a suitable bunch of demands
dmd_ds | null ds = replicate arity Abs
- | otherwise = ASSERT( length ds == arity ) ds
+ | otherwise = ASSERT( ds `lengthIs` arity ) ds
arg_ds = case k of
Keep -> bothLazy_s dmd_ds
-- A Seq can have an empty list of demands, in the polymorphic case.
lubs [] ds2 = ds2
lubs ds1 [] = ds1
-lubs ds1 ds2 = ASSERT( length ds1 == length ds2 ) zipWith lub ds1 ds2
+lubs ds1 ds2 = ASSERT( equalLength ds1 ds2 ) zipWith lub ds1 ds2
-----------------------------------
-- A Seq can have an empty list of demands, in the polymorphic case.
boths [] ds2 = ds2
boths ds1 [] = ds1
-boths ds1 ds2 = ASSERT( length ds1 == length ds2 ) zipWith both ds1 ds2
+boths ds1 ds2 = ASSERT( equalLength ds1 ds2 ) zipWith both ds1 ds2
\end{code}
\begin{code}
isUnLiftedType, Type )
import TyCon ( tyConUnique )
import PrelInfo ( numericTyKeys )
-import Util ( isIn, nOfThem, zipWithEqual )
+import Util ( isIn, nOfThem, zipWithEqual, equalLength )
import Outputable
\end{code}
AbsTop -> False
AbsBot -> True
AbsProd vals
- | length vals /= length demand_info -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
+ | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalStrictness" (ppr demand_info $$ ppr val)
False
| otherwise -> or (zipWithEqual "evalStrictness" evalStrictness demand_info vals)
AbsTop -> False -- No poison in here
AbsBot -> True -- Pure poison
AbsProd vals
- | length vals /= length demand_info -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
+ | not (equalLength vals demand_info) -> pprTrace "TELL SIMON: evalAbsence" (ppr demand_info $$ ppr val)
True
| otherwise -> or (zipWithEqual "evalAbsence" evalAbsence demand_info vals)
_ -> pprTrace "TELL SIMON: evalAbsence"
-- type; so the constructor in this alternative must be the right one
-- so we can go ahead and bind the constructor args to the components
-- of the product value.
- ASSERT(length arg_vals == length val_bndrs)
+ ASSERT(equalLength arg_vals val_bndrs)
absEval anal rhs rhs_env
where
val_bndrs = filter isId bndrs
import SaAbsInt
import SaLib
import Demand ( Demand, wwStrict, isStrict, isLazy )
-import Util ( zipWith3Equal, stretchZipWith )
+import Util ( zipWith3Equal, stretchZipWith, compareLength )
import BasicTypes ( Activation( NeverActive ) )
import Outputable
import FastTypes
where
arg_dmds = case fun of
Var var -> case lookupAbsValEnv str_env var of
- Just (AbsApproxFun ds _) | length ds >= length args
+ Just (AbsApproxFun ds _)
+ | compareLength ds args /= LT
+ -- 'ds' is at least as long as 'args'.
-> ds ++ minDemands
other -> minDemands
other -> minDemands
import Maybes ( orElse )
import CmdLineOpts
import WwLib
+import Util ( lengthIs )
import Outputable
\end{code}
---------------------
splitFun fn_id fn_info wrap_dmds res_info inline_prag rhs
- = WARN( arity /= length wrap_dmds, ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
+ = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
-- The arity should match the signature
mkWwBodies fun_ty wrap_dmds res_info one_shots `thenUs` \ (work_demands, wrap_fn, work_fn) ->
getUniqueUs `thenUs` \ work_uniq ->
import VarSet ( elemVarSet, emptyVarSet, unionVarSet )
import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames( fromIntegerName, fromRationalName )
-import Util ( thenCmp )
+import Util ( thenCmp, equalLength )
import Bag
import Outputable
\end{code}
= -- Get the Id type and instantiate it at the specified types
let
(tyvars,rho) = tcSplitForAllTys (idType real_id)
- rho_ty = ASSERT( length tyvars == length tys )
+ rho_ty = ASSERT( equalLength tyvars tys )
substTy (mkTopTyVarSubst tyvars tys) rho
(theta, tau) = tcSplitRhoTy rho_ty
in
import Var ( tyVarKind )
import VarSet
import Bag
-import Util ( isIn )
+import Util ( isIn, equalLength )
import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isNotTopLevel,
isAlwaysActive )
import FiniteMap ( listToFM, lookupFM )
returnTc (sig_avails, map instToId sig_dicts)
where
sig1_dict_tys = map mkPredTy theta1
- n_sig1_theta = length theta1
sig_meths = concat [insts | TySigInfo _ _ _ _ _ _ insts _ <- sigs]
check_one sig@(TySigInfo _ id _ theta _ _ _ src_loc)
= tcAddErrCtxt (sigContextsCtxt id1 id) $
- checkTc (length theta == n_sig1_theta) sigContextsErr `thenTc_`
+ checkTc (equalLength theta theta1) sigContextsErr `thenTc_`
unifyTauTyLists sig1_dict_tys (map mkPredTy theta)
checkSigsTyVars sigs = mapTc_ check_one sigs
import VarSet ( mkVarSet, emptyVarSet )
import CmdLineOpts
import ErrUtils ( dumpIfSet )
-import Util ( count )
+import Util ( count, isSingleton, lengthIs, equalLength )
import Maybes ( seqMaybe, maybeToBool )
\end{code}
-- The renamer has already checked that the context mentions
-- only the type variable of the class decl.
-- Context is already kind-checked
- ASSERT( length context == length sc_sel_names )
+ ASSERT( equalLength context sc_sel_names )
tcHsTheta context `thenTc` \ sc_theta ->
-- CHECK THE CLASS SIGNATURES,
where
n_generic = count (maybeToBool . maybeGenericMatch) matches
none_generic = n_generic == 0
- all_generic = n_generic == length matches
+ all_generic = matches `lengthIs` n_generic
\end{code}
doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
-- Check that the class is unary, unless GlaExs
- checkTc (arity > 0) (nullaryClassErr cls) `thenTc_`
+ checkTc (not (null tyvars)) (nullaryClassErr cls) `thenTc_`
checkTc (gla_exts || unary) (classArityErr cls) `thenTc_`
-- Check the super-classes
where
(tyvars, theta, _, op_stuff) = classBigSig cls
- arity = length tyvars
- unary = arity == 1
+ unary = isSingleton tyvars
no_generics = null [() | (_, GenDefMeth) <- op_stuff]
check_op (sel_id, dm)
in
-- Arguments
- let n_args = length args
- tv_idxs | n_args == 0 = []
- | otherwise = [1..n_args]
+ let tv_idxs | null args = []
+ | otherwise = [1..length args]
in
newTyVarTys (length tv_idxs) openTypeKind `thenNF_Tc` \ arg_tys ->
tcMonoExprs args arg_tys `thenTc` \ (args', args_lie) ->
(exp_args, _) = tcSplitFunTys exp_ty''
(act_args, _) = tcSplitFunTys act_ty''
- message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
- | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
- | otherwise = appCtxt fun args
+ len_act_args = length act_args
+ len_exp_args = length exp_args
+
+ message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
+ | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
+ | otherwise = appCtxt fun args
in
returnNF_Tc (env2, message)
field_info = zipEqual "missingFields"
field_labels
- (drop (length ex_theta) (dataConStrictMarks data_con))
+ (dropList ex_theta (dataConStrictMarks data_con))
-- The 'drop' is because dataConStrictMarks
-- includes the existential dictionaries
(_, _, _, ex_theta, _, _) = dataConSig data_con
import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
floatPrimTy, doublePrimTy
)
-import Util ( mapAccumL, zipEqual, zipWithEqual,
+import Util ( mapAccumL, zipEqual, zipWithEqual, isSingleton,
zipWith3Equal, nOfThem )
import Panic ( panic, assertPanic )
import Maybes ( maybeToBool, orElse )
cmp_eq =
mk_FunMonoBind tycon_loc
cmp_eq_RDR
- (if null nonnullary_cons && (length nullary_cons == 1) then
+ (if null nonnullary_cons && isSingleton nullary_cons then
-- catch this specially to avoid warnings
-- about overlapping patterns from the desugarer.
let
else
map pats_etc nonnullary_cons ++
-- leave out wildcards to silence desugarer.
- (if length tycon_data_cons == 1 then
+ (if isSingleton tycon_data_cons then
[]
else
[([WildPatIn, WildPatIn], default_rhs)]))
= if isEnumerationTyCon tycon then
min_bound_enum `AndMonoBinds` max_bound_enum
else
- ASSERT(length data_cons == 1)
+ ASSERT(isSingleton data_cons)
min_bound_1con `AndMonoBinds` max_bound_1con
where
data_cons = tyConDataCons tycon
import Name ( Name, nameIsLocalOrFrom )
import ErrUtils ( pprBagOfErrors )
import Outputable
-import Util ( zipWithEqual )
+import Util ( zipWithEqual, dropList, equalLength )
import HscTypes ( TyThing(..) )
\end{code}
ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars]
ex_tys' = mkTyVarTys ex_tyvars'
arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
- id_names = drop (length ex_tyvars) names
+ id_names = dropList ex_tyvars names
arg_ids
#ifdef DEBUG
- | length id_names /= length arg_tys
+ | not (equalLength id_names arg_tys)
= pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
(ppr main_tyvars <+> ppr ex_tyvars) $$
ppr arg_tys)
#endif
= zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
in
- ASSERT( con `elem` tyConDataCons tycon && length inst_tys == length main_tyvars )
+ ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars )
tcExtendTyVarEnv ex_tyvars' $
tcExtendGlobalValEnv arg_ids $
tcCoreExpr rhs `thenTc` \ rhs' ->
import Name ( Name )
import SrcLoc ( SrcLoc )
import Unique ( Uniquable(..) )
+import Util ( lengthExceeds )
import BasicTypes ( NewOrData(..), Fixity )
import ErrUtils ( dumpIfSet_dyn )
import ListSetOps ( Assoc, emptyAssoc, plusAssoc_C, mapAssoc,
tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos]
bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos,
- length group > 1]
+ group `lengthExceeds` 1]
get_uniq (tc,_) = getUnique tc
in
mapTc (addErrTc . dupGenericInsts) bad_groups `thenTc_`
import CmdLineOpts ( dopt, DynFlag(..) )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
-import Util ( nOfThem )
+import Util ( nOfThem, isSingleton, equalLength )
import ListSetOps ( removeDups )
import Outputable
\end{code}
= check_tyvars dflags clas tys
-- WITH HASKELL 1.4, MUST HAVE C (T a b c)
- | length tys == 1,
+ | isSingleton tys,
Just (tycon, arg_tys) <- tcSplitTyConApp_maybe first_ty,
not (isSynTyCon tycon), -- ...but not a synonym
all tcIsTyVarTy arg_tys, -- Applied to type variables
- length (varSetElems (tyVarsOfTypes arg_tys)) == length arg_tys
+ equalLength (varSetElems (tyVarsOfTypes arg_tys)) arg_tys
-- This last condition checks that all the type variables are distinct
= returnTc ()
-- Type constructors must match
uTys ps_ty1 (TyConApp con1 tys1) ps_ty2 (TyConApp con2 tys2)
- | con1 == con2 && length tys1 == length tys2
+ | con1 == con2 && equalLength tys1 tys2
= unifyTauTyLists tys1 tys2
| con1 == openKindCon
import VarSet
import Var ( Id )
import Bag
+import Util ( isSingleton )
import Outputable
+
import List ( nub )
\end{code}
\begin{code}
sameNoOfArgs :: [RenamedMatch] -> Bool
-sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
+sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
where
args_in_match :: RenamedMatch -> Int
args_in_match (Match _ pats _ _) = length pats
type TcWarning = Message
ctxt_to_use ctxt | opt_PprStyle_Debug = ctxt
- | otherwise = takeAtMost 3 ctxt
- where
- takeAtMost :: Int -> [a] -> [a]
- takeAtMost 0 ls = []
- takeAtMost n [] = []
- takeAtMost n (x:xs) = x:takeAtMost (n-1) xs
+ | otherwise = take 3 ctxt
arityErr kind name n m
= hsep [ text kind, quotes (ppr name), ptext SLIT("should have"),
import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon )
import BasicTypes ( Boxity(..) )
import SrcLoc ( SrcLoc )
-import Util ( isSingleton )
+import Util ( isSingleton, lengthIs )
import Outputable
\end{code}
returnTc (mkListTy tau_ty)
tc_type (HsTupleTy (HsTupCon _ boxity arity) tys)
- = ASSERT( arity == length tys )
+ = ASSERT( tys `lengthIs` arity )
tc_types tys `thenTc` \ tau_tys ->
returnTc (mkTupleTy boxity arity tau_tys)
import TysWiredIn ( ptrTyCon, funPtrTyCon, addrTyCon, unitTyCon )
import Unique ( Unique, Uniquable(..) )
import SrcLoc ( SrcLoc )
-import Util ( cmpList, thenCmp )
+import Util ( cmpList, thenCmp, equalLength )
import Maybes ( maybeToBool, expectJust )
import Outputable
\end{code}
-- Type constructors must match
uTysX (TyConApp con1 tys1) (TyConApp con2 tys2) k subst
- | (con1 == con2 && length tys1 == length tys2)
+ | (con1 == con2 && equalLength tys1 tys2)
= uTyListsX tys1 tys2 k subst
-- Applications need a bit of care!
import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo )
import CoreUnfold ( mkTopUnfolding )
-import Unique ( mkBuiltinUnique )
import SrcLoc ( builtinSrcLoc )
+import Unique ( mkBuiltinUnique )
+import Util ( takeList )
import Outputable
#include "HsVersions.h"
= EP { fromEP = mk_hs_lam [tuple_pat] from_body,
toEP = mk_hs_lam [tuple_pat] to_body }
where
- names = take (length eps) genericNames
+ names = takeList eps genericNames
tuple_pat = TuplePatIn (map VarPatIn names) Boxed
eps_w_names = eps `zip` names
to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed
import Name ( getOccString, getOccName )
import Outputable
import Unique ( Uniquable(..) )
+import Util ( lengthIs )
import BasicTypes ( tupleParens )
import PrelNames -- quite a few *Keys
\end{code}
-- TUPLE CASE (boxed and unboxed)
| isTupleTyCon tycon,
- length tys == tyConArity tycon -- No magic if partially applied
+ tys `lengthIs` tyConArity tycon -- No magic if partially applied
= tupleParens (tupleTyConBoxity tycon)
(sep (punctuate comma (map (ppr_ty tOP_PREC) tys)))
import Name ( Name, nameUnique, NamedThing(getName) )
import PrelNames ( Unique, Uniquable(..), anyBoxConKey )
import PrimRep ( PrimRep(..), isFollowableRep )
+import Util ( lengthIs )
import Outputable
import FastString
\end{code}
\begin{code}
tyConDataCons :: TyCon -> [DataCon]
-tyConDataCons tycon = ASSERT2( length cons == tyConFamilySize tycon, ppr tycon )
+tyConDataCons tycon = ASSERT2( cons `lengthIs` (tyConFamilySize tycon), ppr tycon )
cons
where
cons = tyConDataConsIfAvailable tycon
import SrcLoc ( noSrcLoc )
import PrimRep ( PrimRep(..) )
import Unique ( Uniquable(..) )
-import Util ( mapAccumL, seqList )
+import Util ( mapAccumL, seqList, lengthIs )
import Outputable
import UniqSet ( sizeUniqSet ) -- Should come via VarSet
\end{code}
| isNewTyCon tycon, -- A saturated newtype application;
not (isRecursiveTyCon tycon), -- Not recursive (we don't use SourceTypes for them)
- length tys == tyConArity tycon -- use the SourceType form
+ tys `lengthIs` tyConArity tycon -- use the SourceType form
= SourceTy (NType tycon tys)
| otherwise
| n_args == arity -- Exactly saturated
= mk_syn tys
| n_args > arity -- Over-saturated
- = foldl AppTy (mk_syn (take arity tys)) (drop arity tys)
+ = case splitAt arity tys of { (as,bs) -> foldl AppTy (mk_syn as) bs }
| otherwise -- Un-saturated
= TyConApp tycon tys
-- For the un-saturated case we build TyConApp directly
repType (NoteTy _ ty) = repType ty
repType (SourceTy p) = repType (sourceTypeRep p)
repType (UsageTy _ ty) = repType ty
-repType (TyConApp tc tys) | isNewTyCon tc && length tys == tyConArity tc
+repType (TyConApp tc tys) | isNewTyCon tc && tys `lengthIs` tyConArity tc
= repType (newTypeRep tc tys)
repType ty = ty
splitNewType_maybe ty
= case splitTyConApp_maybe ty of
- Just (tc,tys) | isNewTyCon tc -> ASSERT( length tys == tyConArity tc )
+ Just (tc,tys) | isNewTyCon tc -> ASSERT( tys `lengthIs` tyConArity tc )
-- The assert should hold because repType should
-- only be applied to *types* (of kind *)
Just (newTypeRep tc tys)
-- Should only be applied to *types*; hence the assert
isAlgType :: Type -> Bool
isAlgType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
isAlgTyCon tc
other -> False
\end{code}
-- Most of these are unlifted, but now that we interact with .NET, we
-- may have primtive (foreign-imported) types that are lifted
isPrimitiveType ty = case splitTyConApp_maybe ty of
- Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc )
+ Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc )
isPrimTyCon tc
other -> False
\end{code}
import VarSet
import UniqSupply ( UniqSupply, UniqSM,
initUs, splitUniqSupply )
+import Util ( lengthExceeds )
import Outputable
import Maybes ( expectJust )
import List ( unzip4 )
pessN co ve (NoteTy (FTVNote _) ty) = pessN co ve ty
pessN co ve (TyVarTy _) = emptyUConSet
pessN co ve (AppTy _ _) = emptyUConSet
- pessN co ve (TyConApp tc tys) = ASSERT( not((isFunTyCon tc)&&(length tys > 1)) )
+ pessN co ve (TyConApp tc tys) = ASSERT( not((isFunTyCon tc)&&( tys `lengthExceeds` 1)) )
emptyUConSet
pessN co ve (FunTy ty1 ty2) = pess (not co) ve ty1 `unionUCS` pess co ve ty2
pessN co ve (ForAllTy _ ty) = pessN co ve ty
import VarEnv
import PrimOp ( PrimOp, primOpUsg )
import UniqSupply ( UniqSupply, UniqSM, initUs, getUniqueUs, thenUs, returnUs )
+import Util ( lengthExceeds )
import Outputable
pessimiseN co (NoteTy note@(FTVNote _ ) ty) = NoteTy note (pessimiseN co ty)
pessimiseN co ty0@(TyVarTy _) = ty0
pessimiseN co ty0@(AppTy _ _) = ty0
-pessimiseN co ty0@(TyConApp tc tys) = ASSERT( not ((isFunTyCon tc) && (length tys > 1)) )
+pessimiseN co ty0@(TyConApp tc tys) = ASSERT( not ((isFunTyCon tc) && (tys `lengthExceeds` 1)) )
ty0
pessimiseN co (FunTy ty1 ty2) = FunTy (pessimise (not co) ty1)
(pessimise co ty2)
draw (Node x ts) = grp this (space (length this)) (stLoop ts)
where this = s1 ++ x ++ " "
- space n = take n (repeat ' ')
+ space n = replicate n ' '
stLoop [] = [""]
stLoop [t] = grp s2 " " (draw t)
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy, stretchZipWith,
mapAndUnzip, mapAndUnzip3,
- nOfThem, lengthExceeds, isSingleton, only,
+ nOfThem,
+ lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
+ isSingleton, only,
snocView,
isIn, isn'tIn,
-- accumulating
mapAccumL, mapAccumR, mapAccumB,
foldl2, count,
+
+ takeList, dropList, splitAtList,
-- comparisons
- eqListBy, thenCmp, cmpList, prefixMatch, suffixMatch,
+ eqListBy, equalLength, compareLength,
+ thenCmp, cmpList, prefixMatch, suffixMatch,
-- strictness
foldl', seqList,
nOfThem :: Int -> a -> [a]
nOfThem n thing = replicate n thing
+-- 'atLength atLen atEnd ls n' unravels list 'ls' to position 'n';
+-- specification:
+--
+-- atLength atLenPred atEndPred ls n
+-- | n < 0 = atLenPred n
+-- | length ls < n = atEndPred (n - length ls)
+-- | otherwise = atLenPred (drop n ls)
+--
+atLength :: ([a] -> b)
+ -> (Int -> b)
+ -> [a]
+ -> Int
+ -> b
+atLength atLenPred atEndPred ls n
+ | n < 0 = atEndPred n
+ | otherwise = go n ls
+ where
+ go n [] = atEndPred n
+ go 0 ls = atLenPred ls
+ go n (_:xs) = go (n-1) xs
+
+-- special cases.
lengthExceeds :: [a] -> Int -> Bool
--- (lengthExceeds xs n) is True if length xs > n
-(x:xs) `lengthExceeds` n = n < 1 || xs `lengthExceeds` (n - 1)
-[] `lengthExceeds` n = n < 0
+lengthExceeds = atLength (not.null) (const False)
+
+lengthAtLeast :: [a] -> Int -> Bool
+lengthAtLeast = atLength (not.null) (== 0)
+
+lengthIs :: [a] -> Int -> Bool
+lengthIs = atLength null (==0)
+
+listLengthCmp :: [a] -> Int -> Ordering
+listLengthCmp = atLength atLen atEnd
+ where
+ atEnd 0 = EQ
+ atEnd x
+ | x > 0 = LT -- not yet seen 'n' elts, so list length is < n.
+ | otherwise = GT
+
+ atLen [] = EQ
+ atLen _ = GT
isSingleton :: [a] -> Bool
isSingleton [x] = True
| otherwise = count p xs
\end{code}
+@splitAt@, @take@, and @drop@ but with length of another
+list giving the break-off point:
+
+\begin{code}
+takeList :: [b] -> [a] -> [a]
+takeList [] _ = []
+takeList (_:xs) ls =
+ case ls of
+ [] -> []
+ (y:ys) -> y : takeList xs ys
+
+dropList :: [b] -> [a] -> [a]
+dropList [] xs = xs
+dropList _ xs@[] = xs
+dropList (_:xs) (_:ys) = dropList xs ys
+
+
+splitAtList :: [b] -> [a] -> ([a], [a])
+splitAtList [] xs = ([], xs)
+splitAtList _ xs@[] = (xs, xs)
+splitAtList (_:xs) (y:ys) = (y:ys', ys'')
+ where
+ (ys', ys'') = splitAtList xs ys
+
+\end{code}
+
%************************************************************************
%* *
eqListBy eq (x:xs) (y:ys) = eq x y && eqListBy eq xs ys
eqListBy eq xs ys = False
+equalLength :: [a] -> [b] -> Bool
+equalLength [] [] = True
+equalLength (_:xs) (_:ys) = equalLength xs ys
+equalLength xs ys = False
+
+compareLength :: [a] -> [b] -> Ordering
+compareLength [] [] = EQ
+compareLength (_:xs) (_:ys) = compareLength xs ys
+compareLength [] _ys = LT
+compareLength _xs [] = GT
+
thenCmp :: Ordering -> Ordering -> Ordering
{-# INLINE thenCmp #-}
thenCmp EQ any = any
projects / ghc-hetmet.git / commitdiff