Friday afternoon pet peeve removal: define (Util.notNull :: [a] -> Bool) and use it
import CmdLineOpts ( opt_UnboxStrictFields )
import Maybe
import ListSetOps ( assoc )
-import Util ( zipEqual, zipWithEqual, equalLength )
+import Util ( zipEqual, zipWithEqual, equalLength, notNull )
\end{code}
isUnboxedTupleCon (MkData {dcTyCon = tc}) = isUnboxedTupleTyCon tc
isExistentialDataCon :: DataCon -> Bool
-isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs)
+isExistentialDataCon (MkData {dcExTyVars = tvs}) = notNull tvs
\end{code}
bindArgsToRegs reg_args arg_regs `thenC`
mapCs bindNewToStack stk_offsets `thenC`
- returnFC (arg_regs,tags, not (null stk_offsets))
+ returnFC (arg_regs,tags, notNull stk_offsets)
\end{code}
%************************************************************************
done `elem` names_in_this_cycle])
chewed_rest = chew rest
in
- if not (null mods_in_this_cycle)
+ if notNull mods_in_this_cycle
&& length mods_in_this_cycle < length names_in_this_cycle
then mods_in_this_cycle ++ chewed_rest
else chewed_rest
addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg
-- errors or warnings, actually... they're the same type.
addErr errs_so_far msg locs
- = ASSERT( not (null locs) )
+ = ASSERT( notNull locs )
errs_so_far `snocBag` mk_msg msg
where
(loc, cxt1) = dumpLoc (head locs)
import Bag
import FastTypes
import Outputable
+import Util
#if __GLASGOW_HASKELL__ >= 404
import GlaExts ( Int# )
-- If (not in_lam) && one_br then PreInlineUnconditionally
-- should have caught it, shouldn't it? Unless it's a top
-- level thing.
- not (null arg_infos) || interesting_cont
+ notNull arg_infos || interesting_cont
| otherwise
= case guidance of
import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
import UniqSet
-import Util ( takeList, splitAtList )
+import Util ( takeList, splitAtList, notNull )
import Outputable
#include "HsVersions.h"
split_by_constructor :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
split_by_constructor qs
- | not (null unused_cons) = need_default_case used_cons unused_cons qs
- | otherwise = no_need_default_case used_cons qs
+ | notNull 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
lengthPName, indexPName )
import Outputable
import UnicodeUtil ( stringToUtf8 )
-import Util ( isSingleton )
+import Util ( isSingleton, notNull )
\end{code}
scrut
mkTupleSelector vars the_var scrut_var scrut
- = ASSERT( not (null vars) )
+ = ASSERT( notNull vars )
Case scrut scrut_var [(DataAlt (tupleCon Boxed (length vars)), vars, Var the_var)]
\end{code}
import BasicTypes ( Boxity(..) )
import UniqSet
import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc )
-import Util ( lengthExceeds )
+import Util ( lengthExceeds, notNull )
import Outputable
\end{code}
match vars qs
where (pats,indexs) = check qs
incomplete = dopt Opt_WarnIncompletePatterns dflags
- && (not (null pats))
+ && (notNull pats)
shadow = dopt Opt_WarnOverlappingPatterns dflags
&& sizeUniqSet indexs < no_eqns
no_eqns = length qs
import Class ( Class, classTyCon )
import Type ( Type, repType, splitFunTys, dropForAlls )
import Util ( zipEqual, zipWith4Equal, naturalMergeSortLe, nOfThem,
- isSingleton, lengthIs )
+ isSingleton, lengthIs, notNull )
import DataCon ( dataConRepArity )
import Var ( isTyVar )
import VarSet ( VarSet, varSetElems )
-- ^^
-- better be no free vars in these top-level bindings
- when (not (null mallocd))
+ when (notNull mallocd)
(panic "ByteCodeGen.byteCodeGen: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
<- runBc (BcM_State [] 0 [])
(schemeR True fvs (invented_id, annexpr))
- when (not (null mallocd))
+ when (notNull mallocd)
(panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")
dumpIfSet_dyn dflags Opt_D_dump_BCOs
-- as a consequence.
implement_tagToId :: [Name] -> BcM BCInstrList
implement_tagToId names
- = ASSERT(not (null names))
+ = ASSERT( notNull names )
getLabelsBc (length names) `thenBc` \ labels ->
getLabelBc `thenBc` \ label_fail ->
getLabelBc `thenBc` \ label_exit ->
newbcoBc :: BcM ()
newbcoBc st
- | not (null (malloced st))
+ | notNull (malloced st)
= panic "ByteCodeGen.newbcoBc: missed prior emitBc?"
| otherwise
= return (st, ())
import ByteCodeItbls ( ItblEnv, ItblPtr )
import FiniteMap
import Panic ( GhcException(..) )
+import Util ( notNull )
import Control.Monad ( when, foldM )
import Control.Monad.ST ( runST )
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
-- we figure out what to do.
- -- when (not (null malloced)) (addFinalizer ul_bco (mapM_ zonk malloced))
+ -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))
return ul_bco
where
{-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-}
-----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.117 2002/04/02 10:18:07 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.118 2002/04/05 23:24:28 sof Exp $
--
-- GHC Interactive User Interface
--
Right hdl -> fileLoop hdl False
-- perform a :load for files given on the GHCi command line
- when (not (null paths)) $
+ when (notNull paths) $
ghciHandle showException $
loadModule (unwords paths)
leftovers <- processArgs dynamic_flags leftovers []
saveDynFlags
- if (not (null leftovers))
+ if (notNull leftovers)
then throwDyn (CmdLineError ("unrecognised flags: " ++
unwords leftovers))
else return ()
(minus_opts, rest1) = partition isMinus opts
(plus_opts, rest2) = partition isPlus rest1
- if (not (null rest2))
+ if (notNull rest2)
then io (putStrLn ("unknown option: `" ++ head rest2 ++ "'"))
else do
mapM unsetOpt plus_opts
-- can't do GHC flags for now
- if (not (null minus_opts))
+ if (notNull minus_opts)
then throwDyn (CmdLineError "can't unset GHC command-line flags")
else return ()
import Maybe
import PrimOp
-import Util ( lengthIs )
+import Util ( lengthIs, notNull )
#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)] | not (null bs)
+javaCase r e x [(DataAlt d,bs,rhs)] | notNull bs
= java_expr PushExpr e ++
[ var [Final] (javaName x)
(whnf primRep (vmPOP (primRepToType primRep))) ] ++
{-# OPTIONS -#include "hschooks.h" #-}
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.90 2002/03/29 21:39:37 sof Exp $
+-- $Id: DriverFlags.hs,v 1.91 2002/04/05 23:24:29 sof Exp $
--
-- Driver flags
--
arg_ok (NoArg _) rest arg = null rest
arg_ok (HasArg _) rest arg = True
arg_ok (SepArg _) rest arg = null rest
-arg_ok (Prefix _) rest arg = not (null rest)
-arg_ok (PrefixPred p _) rest arg = not (null rest) && p rest
+arg_ok (Prefix _) rest arg = notNull rest
+arg_ok (PrefixPred p _) rest arg = notNull rest && p rest
arg_ok (OptPrefix _) rest arg = True
arg_ok (PassFlag _) rest arg = null rest
arg_ok (AnySuffix _) rest arg = True
-- Complain about non-dynamic flags in OPTIONS pragmas
checkProcessArgsResult flags basename suff
- = do when (not (null flags)) (throwDyn (ProgramError (
+ = do when (notNull flags) (throwDyn (ProgramError (
basename ++ "." ++ suff
++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t"
++ unwords flags)) (ExitFailure 1))
-----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.75 2002/04/05 16:43:56 sof Exp $
+-- $Id: DriverState.hs,v 1.76 2002/04/05 23:24:29 sof Exp $
--
-- Settings for the driver
--
setMode m flag = do
old_mode <- readIORef v_GhcMode
old_flag <- readIORef v_GhcModeFlag
- when (not (null (old_flag))) $
+ when (notNull (old_flag)) $
throwDyn (UsageError
("cannot use `" ++ old_flag ++ "' with `" ++ flag ++ "'"))
writeIORef v_GhcMode m
addToDirList ref path
= do paths <- readIORef ref
shiny_new_ones <- splitUp path
- writeIORef ref (paths ++ filter (not.null) shiny_new_ones)
+ writeIORef ref (paths ++ filter notNull shiny_new_ones)
-- empty paths are ignored: there might be a trailing
-- ':' in the initial list, for example. Empty paths can
-- cause confusion when they are translated into -I options
getPackageImportPath :: IO [String]
getPackageImportPath = do
ps <- getPackageInfo
- return (nub (filter (not.null) (concatMap import_dirs ps)))
+ return (nub (filter notNull (concatMap import_dirs ps)))
getPackageIncludePath :: IO [String]
getPackageIncludePath = do
ps <- getPackageInfo
- return (nub (filter (not.null) (concatMap include_dirs ps)))
+ return (nub (filter notNull (concatMap include_dirs ps)))
-- includes are in reverse dependency order (i.e. rts first)
getPackageCIncludes :: IO [String]
getPackageCIncludes = do
ps <- getPackageInfo
- return (reverse (nub (filter (not.null) (concatMap c_includes ps))))
+ return (reverse (nub (filter notNull (concatMap c_includes ps))))
getPackageLibraryPath :: IO [String]
getPackageLibraryPath = do
ps <- getPackageInfo
- return (nub (filter (not.null) (concatMap library_dirs ps)))
+ return (nub (filter notNull (concatMap library_dirs ps)))
getPackageLibraries :: IO [String]
getPackageLibraries = do
{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.103 2002/04/05 16:43:56 sof Exp $
+-- $Id: Main.hs,v 1.104 2002/04/05 23:24:29 sof Exp $
--
-- GHC Driver program
--
do putStr "warning: -O conflicts with --interactive; -O turned off.\n"
writeIORef v_OptLevel 0
orig_ways <- readIORef v_Ways
- when (not (null orig_ways) && mode == DoInteractive) $
+ when (notNull orig_ways && mode == DoInteractive) $
do throwDyn (UsageError
"--interactive can't be used with -prof, -ticky, -unreg or -smp.")
checkOptions srcs = do
-- complain about any unknown flags
let unknown_opts = [ f | f@('-':_) <- srcs ]
- when (not (null unknown_opts)) (unknownFlagsErr unknown_opts)
+ when (notNull unknown_opts) (unknownFlagsErr unknown_opts)
-- verify that output files point somewhere sensible.
verifyOutputFiles
-- and anything else that it might be worth checking for
import Config
import Outputable
import Panic ( progName, GhcException(..) )
-import Util ( global, dropList )
+import Util ( global, dropList, notNull )
import CmdLineOpts ( dynFlag, verbosity )
import Exception ( throwDyn )
}
where
-- get_proto returns a Unix-format path (relying on getExecDir to do so too)
- get_proto | not (null minusbs)
+ get_proto | notNull minusbs
= return (unDosifyPath (drop 2 (last minusbs))) -- 2 for "-B"
| otherwise
= do { maybe_exec_dir <- getExecDir -- Get directory of executable
import ForeignCall ( ForeignCall(..), CCallSpec(..), CCallTarget(..),
CCallConv(..), playSafe, playThreadSafe )
import Outputable
+import Util ( notNull )
import FastTypes
#include "NCG.h"
(cargs, stix_target)
= case ctarget of
StaticTarget nm -> (rhs, Left nm)
- DynamicTarget | not (null rhs) -- an assertion
+ DynamicTarget | notNull rhs -- an assertion
-> (tail rhs, Right (amodeToStix (head rhs)))
CasmTarget _
-> ncgPrimopMoan "Native code generator can't handle foreign call"
import Outputable
import Maybes ( maybeToBool, catMaybes )
import ListSetOps ( removeDups )
-import Util ( sortLt )
+import Util ( sortLt, notNull )
import List ( partition )
\end{code}
mod_loc]
explicit_prelude_import
- = not (null [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ])
+ = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ]
\end{code}
\begin{code}
import UniqSupply ( UniqSupply )
import List ( partition )
import Outputable
+import Util ( notNull )
\end{code}
-----------------
floatTopBind bind@(Rec _)
= case (floatBind bind) of { (fs, floats, Rec pairs') ->
- WARN( not (null floats), ppr bind $$ ppr floats )
+ WARN( notNull floats, ppr bind $$ ppr floats )
(fs, [Rec (floatsToBindPairs floats ++ pairs')]) }
\end{code}
import Var ( Id )
import VarEnv
import Outputable
+import Util ( notNull )
\end{code}
This module walks over @Core@, and looks for @case@ on free variables.
libCaseId :: LibCaseEnv -> Id -> CoreExpr
libCaseId env v
| Just the_bind <- lookupRecId env v -- It's a use of a recursive thing
- , not (null free_scruts) -- with free vars scrutinised in RHS
+ , notNull free_scruts -- with free vars scrutinised in RHS
= Let the_bind (Var v)
| otherwise
import OrdList
import Maybe ( Maybe )
import Outputable
+import Util ( notNull )
\end{code}
let
arg_infos = [ interestingArg arg | arg <- args, isValArg arg]
- interesting_cont = interestingCallContext (not (null args))
- (not (null arg_infos))
+ interesting_cont = interestingCallContext (notNull args)
+ (notNull arg_infos)
call_cont
active_inline = activeInline env var occ_info
import Outputable
import Maybes ( orElse )
-import Util ( mapAccumL, lengthAtLeast )
+import Util ( mapAccumL, lengthAtLeast, notNull )
import List ( nubBy, partition )
import UniqSupply
import Outputable
----------------------
scBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, ScUsage, CoreBind)
scBind env (Rec [(fn,rhs)])
- | not (null val_bndrs)
+ | notNull val_bndrs
= scExpr env_fn_body body `thenUs` \ (usg, body') ->
let
SCU { calls = calls, occs = occs } = usg
import Bag
import List ( partition )
import Util ( zipEqual, zipWithEqual, cmpList, lengthIs,
- equalLength, lengthAtLeast )
+ equalLength, lengthAtLeast, notNull )
import Outputable
-- The first case is the interesting one
| 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
+ && notNull 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
import Maybes ( orElse )
import CmdLineOpts
import WwLib
-import Util ( lengthIs )
+import Util ( lengthIs, notNull )
import Outputable
\end{code}
| otherwise = fn_id `setIdNewStrictness`
StrictSig (mkTopDmdType wrap_dmds res_info)
- is_fun = not (null wrap_dmds)
+ is_fun = notNull wrap_dmds
is_thunk = not is_fun && not (exprIsValue rhs)
---------------------
import BasicTypes ( Boxity(..) )
import Var ( Var, isId )
import UniqSupply ( returnUs, thenUs, getUniquesUs, UniqSM )
-import Util ( zipWithEqual )
+import Util ( zipWithEqual, notNull )
import Outputable
import List ( zipWith4 )
\end{code}
work_fn_args . Note (Coerce rep_ty fun_ty),
res_ty)
- | not (null demands)
+ | notNull demands
= getUniquesUs `thenUs` \ wrap_uniqs ->
let
(tyvars, tau) = splitForAllTys fun_ty
val_args = zipWith4 mk_wrap_arg wrap_uniqs arg_tys demands one_shots
wrap_args = tyvars ++ val_args
in
-{- ASSERT( not (null tyvars) || not (null arg_tys) ) -}
+{- ASSERT( notNull tyvars || notNull arg_tys ) -}
if (null tyvars) && (null arg_tys) then
pprTrace "mkWWargs" (ppr fun_ty $$ ppr demands)
returnUs ([], id, id, fun_ty)
import Var ( TyVar, tyVarKind )
import VarSet ( mkVarSet, subVarSet )
import PrelNames
-import Util ( zipWithEqual, sortLt )
+import Util ( zipWithEqual, sortLt, notNull )
import ListSetOps ( removeDups, assoc )
import Outputable
import Maybe ( isJust )
------------------------------------------------------------------
chk_out :: Class -> TyCon -> [TcType] -> Maybe FastString
chk_out clas tycon tys
- | not (null tys) = Just non_std_why
+ | notNull tys = Just non_std_why
| not (getUnique clas `elem` derivableClassKeys) = Just non_std_why
| clas `hasKey` enumClassKey && not is_enumeration = Just nullary_why
| clas `hasKey` boundedClassKey && not is_enumeration_or_single = Just single_nullary_why
let
bad_fields = badFields rbinds data_con
in
- if not (null bad_fields) then
+ if notNull bad_fields then
mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields `thenNF_Tc_`
failTc -- Fail now, because tcRecordBinds will crash on a bad field
else
(mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
returnNF_Tc ()) `thenNF_Tc_`
doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
- checkTcM (not (warn && not (null missing_fields)))
+ checkTcM (not (warn && notNull missing_fields))
(mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
returnNF_Tc ()) `thenNF_Tc_`
-- STEP 0
-- Check that the field names are really field names
- ASSERT( not (null rbinds) )
+ ASSERT( notNull rbinds )
let
field_names = [field_name | (field_name, _, _) <- rbinds]
in
--
tcDoStmts PArrComp stmts src_loc res_ty
=
- ASSERT( not (null stmts) )
+ ASSERT( notNull stmts )
tcAddSrcLoc src_loc $
unifyPArrTy res_ty `thenTc` \elt_ty ->
tcDoStmts do_or_lc stmts src_loc res_ty
= -- get the Monad and MonadZero classes
-- create type consisting of a fresh monad tyvar
- ASSERT( not (null stmts) )
+ ASSERT( notNull stmts )
tcAddSrcLoc src_loc $
-- If it's a comprehension we're dealing with,
import CmdLineOpts ( dopt, DynFlag(..) )
import Unique ( Uniquable(..) )
import SrcLoc ( noSrcLoc )
-import Util ( nOfThem, isSingleton, equalLength )
+import Util ( nOfThem, isSingleton, equalLength, notNull )
import ListSetOps ( equivClasses, removeDups )
import Outputable
\end{code}
-- This shows up in the complaint about
-- case C a where
-- op :: Eq a => a -> a
-ppr_ty ty | null forall_tvs && not (null theta) = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
+ppr_ty ty | null forall_tvs && notNull theta = pprTheta theta <+> ptext SLIT("=>") <+> ppr tau
| otherwise = ppr ty
where
(forall_tvs, theta, tau) = tcSplitSigmaTy ty
= returnTc ()
check_valid_theta ctxt theta
= getDOptsTc `thenNF_Tc` \ dflags ->
- warnTc (not (null dups)) (dupPredWarn dups) `thenNF_Tc_`
+ warnTc (notNull dups) (dupPredWarn dups) `thenNF_Tc_`
mapTc_ (check_source_ty dflags ctxt) theta
where
(_,dups) = removeDups tcCmpPred theta
doptsTc Opt_GlasgowExts `thenTc` \ gla_exts ->
-- Check that the class is unary, unless GlaExs
- checkTc (not (null tyvars)) (nullaryClassErr cls) `thenTc_`
+ checkTc (notNull tyvars) (nullaryClassErr cls) `thenTc_`
checkTc (gla_exts || unary) (classArityErr cls) `thenTc_`
-- Check the super-classes
import Name ( isSystemName, getSrcLoc )
import ErrUtils ( Message )
import BasicTypes ( Boxity, Arity, isBoxed )
-import Util ( equalLength )
+import Util ( equalLength, notNull )
import Maybe ( isNothing )
import Outputable
\end{code}
-----------------------
escape_msg sig_tv tv globs
= mk_msg sig_tv <+> ptext SLIT("escapes") $$
- if not (null globs) then
+ if notNull globs then
vcat [pp_it <+> ptext SLIT("is mentioned in the environment:"),
nest 2 (vcat globs)]
else
import BasicTypes ( Arity )
import Unique ( Unique, Uniquable(..) )
import Outputable
+import Util ( notNull )
\end{code}
%************************************************************************
= (tyvars, fundeps, sc_theta, sc_sels, op_stuff)
classHasFDs :: Class -> Bool
-classHasFDs (Class {classFunDeps = fundeps}) = not (null fundeps)
+classHasFDs (Class {classFunDeps = fundeps}) = notNull fundeps
\end{code}
import Id ( idType )
import ErrUtils ( Message )
import CmdLineOpts
+import Util ( notNull )
\end{code}
addToInstEnv dflags (inst_env, errs) dfun_id
-- Check first that the new instance doesn't
-- conflict with another. See notes below about fundeps.
- | not (null bad_fundeps)
+ | notNull bad_fundeps
= (inst_env, fundep_err : errs) -- Bad fundeps; report the first only
| otherwise
badFunDeps cls_inst_env clas ins_tv_set ins_tys
= [ dfun_id | fd <- fds,
(tvs, tys, dfun_id) <- cls_inst_env,
- not (null (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys))
+ notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys)
]
where
(clas_tvs, fds) = classTvsFds clas
nOfThem,
lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength,
isSingleton, only,
+ notNull,
+
snocView,
isIn, isn'tIn,
-- special cases.
lengthExceeds :: [a] -> Int -> Bool
-- (lengthExceeds xs n) = (length xs > n)
-lengthExceeds = atLength (not.null) (const False)
+lengthExceeds = atLength notNull (const False)
lengthAtLeast :: [a] -> Int -> Bool
-lengthAtLeast = atLength (not.null) (== 0)
+lengthAtLeast = atLength notNull (== 0)
lengthIs :: [a] -> Int -> Bool
lengthIs = atLength null (==0)
isSingleton [x] = True
isSingleton _ = False
+notNull :: [a] -> Bool
+notNull [] = False
+notNull _ = True
+
only :: [a] -> a
#ifdef DEBUG
only [a] = a
projects / ghc-hetmet.git / commitdiff