diff options
| author | sof <unknown> | 2001-10-25 02:13:16 +0000 |
|---|---|---|
| committer | sof <unknown> | 2001-10-25 02:13:16 +0000 |
| commit | 9e93335020e64a811dbbb223e1727c76933a93ae (patch) | |
| tree | aa4607430cb048b7bf00cc9ab00620494b41f0e6 /ghc/compiler | |
| parent | dccacbf9dd82d82657f4885a91d3deb57ce22f53 (diff) | |
| download | haskell-9e93335020e64a811dbbb223e1727c76933a93ae.tar.gz | |
[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.
Diffstat (limited to 'ghc/compiler')
63 files changed, 313 insertions, 198 deletions
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 2793d0f758..4a0abfcb42 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -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") diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index a4e6260ada..ba6663bcf0 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -377,4 +377,4 @@ isNeverActive act = False isAlwaysActive AlwaysActive = True isAlwaysActive other = False -\end{code}
\ No newline at end of file +\end{code} diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 077e13867e..917f4746ee 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -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. diff --git a/ghc/compiler/basicTypes/Demand.lhs b/ghc/compiler/basicTypes/Demand.lhs index b39ad982c7..8e8f24ff3e 100644 --- a/ghc/compiler/basicTypes/Demand.lhs +++ b/ghc/compiler/basicTypes/Demand.lhs @@ -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 diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 1aecb5452f..017b3eb794 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -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 $ diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 6c53312589..5262fa5a64 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -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') diff --git a/ghc/compiler/basicTypes/NewDemand.lhs b/ghc/compiler/basicTypes/NewDemand.lhs index 554c08076e..532ad463a5 100644 --- a/ghc/compiler/basicTypes/NewDemand.lhs +++ b/ghc/compiler/basicTypes/NewDemand.lhs @@ -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 diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 28bc6c152d..48905e9e1d 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (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 diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 954dca8d2f..1e0fa9378b 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -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 diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 6297949779..a98a1bb848 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (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 diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index a5b0a20d8b..8562b678b0 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (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 diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index b7e6acedb7..dcd2176a81 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (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 diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 1642b26198..dbd26ce3b8 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index eb543a3679..906cd6da73 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -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") diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 2cd4249ca2..a1a4694718 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index f19c28c5fc..85fd027675 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -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) diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 0d8e76aeb0..b6797298dd 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -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 diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 008cebf6bf..b83b78429f 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -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 diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index e56a8abc1d..5113913d47 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -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)) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 12b6f29536..2bee279f46 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -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 diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index e7af9dc2b8..7843943210 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -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 ; diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 90a211f305..113a04883f 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -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, + 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} diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 49040bfc0e..98207b6700 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -46,7 +46,7 @@ import PrelNames ( mkTupConRdrName, listTyConKey, usOnceTyConKey, usManyTyConKey usOnceTyConName, usManyTyConName ) import FiniteMap -import Util ( eqListBy ) +import Util ( eqListBy, lengthIs ) import Outputable \end{code} @@ -341,7 +341,7 @@ toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of 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)) diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 4ff59454dd..9e7423d132 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -855,7 +855,7 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo = ([],[],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) @@ -897,7 +897,7 @@ ilxFunAppArgs env num_sofar funty args tail_call known_clo -- 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)), diff --git a/ghc/compiler/javaGen/JavaGen.lhs b/ghc/compiler/javaGen/JavaGen.lhs index 58d8808b3e..9b5bcba532 100644 --- a/ghc/compiler/javaGen/JavaGen.lhs +++ b/ghc/compiler/javaGen/JavaGen.lhs @@ -66,6 +66,7 @@ import Outputable import Maybe import PrimOp +import Util ( lengthIs ) #include "HsVersions.h" @@ -266,7 +267,7 @@ javaCase :: (Expr -> Statement) -> CoreExpr -> Id -> [CoreAlt] -> [Statement] -- 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))) ] ++ @@ -420,7 +421,7 @@ javaApp r (CoreSyn.App f a) as | 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 diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 5d3609cb76..dbd6bf13e9 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -27,6 +27,7 @@ import Util ( sortLt ) import Outputable import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) +import List ( replicate ) import System ( ExitCode(..), exitWith ) import IO ( hPutStr, hPutStrLn, stderr ) \end{code} @@ -161,5 +162,5 @@ dump hdr doc doc, text ""] where - line = text (take 20 (repeat '=')) + line = text (replicate 20 '=') \end{code} diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 773e6f524c..b5085cdbd1 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -191,7 +191,7 @@ hscNoRecomp ghci_mode dflags have_object }}} 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) diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index 61eb47e8a3..4f53d0adc1 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -11,6 +11,7 @@ module HscStats ( ppSourceStats ) where import HsSyn import Outputable import Char ( isSpace ) +import Util ( count ) \end{code} %************************************************************************ @@ -62,7 +63,7 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) 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 @@ -71,12 +72,13 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) 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 } diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 78bec0c421..9c8827b26e 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# 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 -- @@ -257,7 +257,7 @@ main = -- -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 @@ -267,7 +267,7 @@ main = -- -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 diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index d672241e6a..d01b25fac0 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -153,7 +153,7 @@ pcPrimTyCon name arg_vrcs rep = 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 diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index 310e36e5fd..4eb977d5bb 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -21,7 +21,7 @@ import CoreSyn import VarEnv import CoreLint ( showPass, endPass ) import Outputable -import Util ( mapAccumL ) +import Util ( mapAccumL, lengthExceeds ) import UniqFM \end{code} @@ -227,7 +227,7 @@ extendCSEnv (CS cs in_scope sub) id expr = 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 diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index f14a01189d..be854af217 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -25,7 +25,7 @@ import Id ( isOneShotLambda ) import Var ( Id, idType, isTyVar ) import Type ( isUnLiftedType ) import VarSet -import Util ( zipEqual, zipWithEqual ) +import Util ( zipEqual, zipWithEqual, count ) import Outputable \end{code} @@ -424,7 +424,7 @@ sepBindsByDropPoint is_case drop_pts floaters -- 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 diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index 7c3f243758..0df2551e3f 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -179,7 +179,7 @@ saTransform binder rhs 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))) ( @@ -240,10 +240,12 @@ saTransform binder rhs -- 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 diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index 46e8b4fc12..86fb305c7a 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -18,6 +18,7 @@ import BasicTypes ( TopLevelFlag(..), isTopLevel ) import Util ( mapAccumL ) #ifdef DEBUG +import Util ( lengthIs ) import Outputable #endif \end{code} @@ -202,7 +203,7 @@ constructSRT caf_refs sub_srt initial_offset current_offset 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} diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index f806be1ca0..9e27df4a4b 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -505,7 +505,7 @@ ruleCheckProgram phase rule_pat binds ] 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 diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index 32132c7690..824b1e55df 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -32,7 +32,7 @@ import BasicTypes ( Activation(..) ) import Outputable import Maybes ( orElse ) -import Util ( mapAccumL ) +import Util ( mapAccumL, lengthAtLeast ) import List ( nubBy, partition ) import UniqSupply import Outputable @@ -432,7 +432,7 @@ specialise env fn bndrs body (SCU {calls=calls, occs=occs}) 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 @@ -565,7 +565,7 @@ is_con_app_maybe env (Lit lit) 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) diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 0428772ca1..746814f968 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -40,7 +40,8 @@ import ErrUtils ( dumpIfSet_dyn ) import BasicTypes ( Activation( AlwaysActive ) ) import Bag import List ( partition ) -import Util ( zipEqual, zipWithEqual, cmpList ) +import Util ( zipEqual, zipWithEqual, cmpList, lengthIs, + equalLength, lengthAtLeast ) import Outputable @@ -785,8 +786,8 @@ specDefn :: Subst -- Subst to use for RHS 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 @@ -848,7 +849,7 @@ specDefn subst calls (fn, rhs) 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 @@ -910,8 +911,8 @@ specDefn subst calls (fn, 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) @@ -1004,8 +1005,8 @@ callDetailsToList calls = [ (id,tys,dicts) 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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index c99c76f60a..38c9c4ddc5 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -35,6 +35,7 @@ import OccName ( occNameUserString ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) import FastTypes hiding ( fastOr ) +import Util ( listLengthCmp ) import Outputable infixr 9 `thenLne` @@ -305,7 +306,7 @@ to do it before the SRT pass to save the SRT entries associated with 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} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 3692e06e42..b36c5b035d 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -23,7 +23,7 @@ import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, isUnLiftedType, isTyVarTy, splitForAllTys, Type ) import TyCon ( TyCon, isDataTyCon, tyConDataCons ) -import Util ( zipEqual ) +import Util ( zipEqual, equalLength ) import Outputable infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` @@ -261,7 +261,7 @@ lintAlgAlt scrut_ty (con, args, _, rhs) -- 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 () diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index d1ceb30bad..d0ac19e1de 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -31,7 +31,7 @@ import UniqFM ( plusUFM_C, addToUFM_Directly, lookupUFM_Directly, 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 @@ -667,7 +667,7 @@ dmdTransform sigs var dmd -- 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 @@ -831,13 +831,13 @@ bothRes r1 r2 = r1 -- 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} diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 14bb2df5d8..f5343716d7 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -35,7 +35,7 @@ import Type ( splitTyConApp_maybe, isUnLiftedType, Type ) import TyCon ( tyConUnique ) import PrelInfo ( numericTyKeys ) -import Util ( isIn, nOfThem, zipWithEqual ) +import Util ( isIn, nOfThem, zipWithEqual, equalLength ) import Outputable \end{code} @@ -294,7 +294,7 @@ evalStrictness (WwUnpack _ demand_info) val 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) @@ -323,7 +323,7 @@ evalAbsence (WwUnpack _ demand_info) val 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" @@ -464,7 +464,7 @@ absEval anal expr@(Case scrut case_bndr alts) env -- 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 diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 666d7ff2b2..fce4fbd72f 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -22,7 +22,7 @@ import ErrUtils ( dumpIfSet_dyn ) 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 @@ -233,7 +233,9 @@ saApp str_env abs_env (fun, args) 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 diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 159dd8f951..03f4e56cea 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -28,6 +28,7 @@ import BasicTypes ( RecFlag(..), isNonRec, Activation(..) ) import Maybes ( orElse ) import CmdLineOpts import WwLib +import Util ( lengthIs ) import Outputable \end{code} @@ -226,7 +227,7 @@ tryWW is_rec fn_id rhs --------------------- 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 -> diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index c16ba2c541..a264e9c992 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -71,7 +71,7 @@ import VarEnv ( TidyEnv, lookupSubstEnv, SubstResult(..) ) 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} @@ -415,7 +415,7 @@ newMethodAtLoc inst_loc real_id tys = -- 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 diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index e5a83ab3cb..6c0ec0305b 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -50,7 +50,7 @@ import NameSet 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 ) @@ -471,12 +471,11 @@ checkSigsCtxts sigs@(TySigInfo _ id1 sig_tvs theta1 _ _ _ src_loc : other_sigs) 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 diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 90b17fd58f..82d5ebbd3c 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -53,7 +53,7 @@ import Var ( TyVar ) import VarSet ( mkVarSet, emptyVarSet ) import CmdLineOpts import ErrUtils ( dumpIfSet ) -import Util ( count ) +import Util ( count, isSingleton, lengthIs, equalLength ) import Maybes ( seqMaybe, maybeToBool ) \end{code} @@ -122,7 +122,7 @@ tcClassDecl1 rec_env -- 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, @@ -193,7 +193,7 @@ checkDefaultBinds clas ops (Just mbs) 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} @@ -262,7 +262,7 @@ checkValidClass cls 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 @@ -278,8 +278,7 @@ checkValidClass cls 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) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index cb57efdc28..2e984fec3b 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -283,9 +283,8 @@ tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty 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) -> @@ -704,9 +703,12 @@ checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env (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) @@ -896,7 +898,7 @@ missingFields rbinds data_con 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 diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 273572b8fa..eafae42cc3 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -57,7 +57,7 @@ import TcType ( isUnLiftedType, tcEqType, Type ) 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 ) @@ -351,7 +351,7 @@ gen_Ord_binds tycon 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 @@ -363,7 +363,7 @@ gen_Ord_binds tycon 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)])) @@ -527,7 +527,7 @@ gen_Bounded_binds tycon = 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 diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index cc7d9b6bf0..b55968692b 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -37,7 +37,7 @@ import Var ( mkTyVar, tyVarKind ) import Name ( Name, nameIsLocalOrFrom ) import ErrUtils ( pprBagOfErrors ) import Outputable -import Util ( zipWithEqual ) +import Util ( zipWithEqual, dropList, equalLength ) import HscTypes ( TyThing(..) ) \end{code} @@ -337,10 +337,10 @@ tcCoreAlt scrut_ty alt@(con, names, rhs) 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) @@ -348,7 +348,7 @@ tcCoreAlt scrut_ty alt@(con, names, rhs) #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' -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index aef778a223..b992ce1458 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -66,6 +66,7 @@ import TysWiredIn ( genericTyCons ) 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, @@ -348,7 +349,7 @@ get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = Just def_methods, 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_` diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index d5d394ef32..9d27e678e9 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -88,7 +88,7 @@ import BasicTypes ( Boxity, Arity, isBoxed ) 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} @@ -937,11 +937,11 @@ check_inst_head dflags clas tys = 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 () @@ -1114,7 +1114,7 @@ uTys _ (FunTy fun1 arg1) _ (FunTy fun2 arg2) -- 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 diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 518c4ff9b7..4bbcc5a5ff 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -40,7 +40,9 @@ import NameSet import VarSet import Var ( Id ) import Bag +import Util ( isSingleton ) import Outputable + import List ( nub ) \end{code} @@ -457,7 +459,7 @@ number of args are used in each equation. \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 diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 41f0890182..588f87168b 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -642,12 +642,7 @@ type TcError = Message 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"), diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 867fa9dbb3..c02e7125d1 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -61,7 +61,7 @@ import Name ( Name ) import TysWiredIn ( mkListTy, mkTupleTy, genUnitTyCon ) import BasicTypes ( Boxity(..) ) import SrcLoc ( SrcLoc ) -import Util ( isSingleton ) +import Util ( isSingleton, lengthIs ) import Outputable \end{code} @@ -381,7 +381,7 @@ tc_type (HsListTy ty) 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) diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index c4cca7edab..7f4e0df433 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -134,7 +134,7 @@ import PrelNames -- Lots (e.g. in isFFIArgumentTy) 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} @@ -857,7 +857,7 @@ uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst -- 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! diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 1fe3575fae..e8d26d5184 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -34,8 +34,9 @@ import TysWiredIn ( genericTyCons, import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo ) import CoreUnfold ( mkTopUnfolding ) -import Unique ( mkBuiltinUnique ) import SrcLoc ( builtinSrcLoc ) +import Unique ( mkBuiltinUnique ) +import Util ( takeList ) import Outputable #include "HsVersions.h" @@ -517,7 +518,7 @@ bimapTuple eps = 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 diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index f191fda138..22b60bf281 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -37,6 +37,7 @@ import Maybes ( maybeToBool ) import Name ( getOccString, getOccName ) import Outputable import Unique ( Uniquable(..) ) +import Util ( lengthIs ) import BasicTypes ( tupleParens ) import PrelNames -- quite a few *Keys \end{code} @@ -136,7 +137,7 @@ ppr_ty ctxt_prec ty@(TyConApp tycon tys) -- 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))) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index eb773464e1..5ede243737 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -64,6 +64,7 @@ import BasicTypes ( Arity, RecFlag(..), Boxity(..), import Name ( Name, nameUnique, NamedThing(getName) ) import PrelNames ( Unique, Uniquable(..), anyBoxConKey ) import PrimRep ( PrimRep(..), isFollowableRep ) +import Util ( lengthIs ) import Outputable import FastString \end{code} @@ -439,7 +440,7 @@ isForeignTyCon other = False \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 diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index eb159f7d02..925357f51f 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -109,7 +109,7 @@ import Maybes ( maybeToBool ) 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} @@ -326,7 +326,7 @@ mkTyConApp tycon tys | 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 @@ -372,7 +372,7 @@ mkSynTy tycon tys | 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 @@ -426,7 +426,7 @@ repType (ForAllTy _ ty) = repType ty 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 @@ -650,7 +650,7 @@ splitNewType_maybe :: Type -> Maybe Type 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) @@ -880,7 +880,7 @@ isUnboxedTupleType ty = case splitTyConApp_maybe ty of -- 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} @@ -911,7 +911,7 @@ isPrimitiveType :: Type -> Bool -- 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} diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index 8be665400b..cce3ffeda8 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -32,6 +32,7 @@ import VarEnv import VarSet import UniqSupply ( UniqSupply, UniqSM, initUs, splitUniqSupply ) +import Util ( lengthExceeds ) import Outputable import Maybes ( expectJust ) import List ( unzip4 ) @@ -477,7 +478,7 @@ pessimise ty 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 diff --git a/ghc/compiler/usageSP/UsageSPUtils.lhs b/ghc/compiler/usageSP/UsageSPUtils.lhs index 0a18567666..03efe523b1 100644 --- a/ghc/compiler/usageSP/UsageSPUtils.lhs +++ b/ghc/compiler/usageSP/UsageSPUtils.lhs @@ -37,6 +37,7 @@ import TyCon ( isAlgTyCon, isPrimTyCon, isSynTyCon, isFunTyCon ) import VarEnv import PrimOp ( PrimOp, primOpUsg ) import UniqSupply ( UniqSupply, UniqSM, initUs, getUniqueUs, thenUs, returnUs ) +import Util ( lengthExceeds ) import Outputable @@ -431,7 +432,7 @@ pessimiseN co (NoteTy (SynNote sty) ty) = NoteTy (SynNote (pessimiseN c 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) diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index 1544c7b933..3fb9dd4c6f 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -211,7 +211,7 @@ drawTree = unlines . draw 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) diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index b1c93a8a6a..51f53f308e 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -17,7 +17,9 @@ module Util ( zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal, zipLazy, stretchZipWith, mapAndUnzip, mapAndUnzip3, - nOfThem, lengthExceeds, isSingleton, only, + nOfThem, + lengthExceeds, lengthIs, lengthAtLeast, listLengthCmp, atLength, + isSingleton, only, snocView, isIn, isn'tIn, @@ -39,9 +41,12 @@ module Util ( -- 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, @@ -228,10 +233,47 @@ mapAndUnzip3 f (x:xs) 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 @@ -631,6 +673,32 @@ count p (x:xs) | p x = 1 + count p xs | 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} + %************************************************************************ %* * @@ -644,6 +712,17 @@ eqListBy eq [] [] = True 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 |