summaryrefslogtreecommitdiff
path: root/ghc/compiler/typecheck
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/typecheck')
-rw-r--r--ghc/compiler/typecheck/Inst.lhs4
-rw-r--r--ghc/compiler/typecheck/TcBinds.lhs5
-rw-r--r--ghc/compiler/typecheck/TcClassDcl.lhs11
-rw-r--r--ghc/compiler/typecheck/TcExpr.lhs16
-rw-r--r--ghc/compiler/typecheck/TcGenDeriv.lhs8
-rw-r--r--ghc/compiler/typecheck/TcIfaceSig.lhs8
-rw-r--r--ghc/compiler/typecheck/TcInstDcls.lhs3
-rw-r--r--ghc/compiler/typecheck/TcMType.lhs8
-rw-r--r--ghc/compiler/typecheck/TcMatches.lhs4
-rw-r--r--ghc/compiler/typecheck/TcMonad.lhs7
-rw-r--r--ghc/compiler/typecheck/TcMonoType.lhs4
-rw-r--r--ghc/compiler/typecheck/TcType.lhs4
12 files changed, 40 insertions, 42 deletions
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!
View Lorry Controller Status