Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/b0c0cae7e1ed65ac8dd218a9018f82a4ceac6842 >--------------------------------------------------------------- commit b0c0cae7e1ed65ac8dd218a9018f82a4ceac6842 Author: Simon Peyton Jones <simo...@microsoft.com> Date: Wed Jan 2 16:38:46 2013 +0000 Define ListSetOps.getNth, and use it I was tracking down an error looking like Prelude.(!!): index too large which is very unhelpful. This patch replaces at least some uses of (!!) in GHC with getNth, which has a more helpful error message (with DEBUG anyway) >--------------------------------------------------------------- compiler/basicTypes/MkId.lhs | 4 ++-- compiler/coreSyn/CoreLint.lhs | 4 ++-- compiler/coreSyn/CoreSubst.lhs | 5 +++-- compiler/deSugar/DsBinds.lhs | 3 ++- compiler/deSugar/DsListComp.lhs | 5 +++-- compiler/typecheck/TcDeriv.lhs | 2 +- compiler/utils/ListSetOps.lhs | 18 ++++++++++++++++++ 7 files changed, 31 insertions(+), 10 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 516e25a..337c0dd 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -330,7 +330,7 @@ mkDictSelId dflags no_unf name clas val_index = assoc "MkId.mkDictSelId" sel_index_prs name sel_index_prs = map idName (classAllSelIds clas) `zip` [0..] - the_arg_id = arg_ids !! val_index + the_arg_id = getNth arg_ids val_index pred = mkClassPred clas (mkTyVarTys tyvars) dict_id = mkTemplateLocal 1 pred arg_ids = mkTemplateLocalsNum 2 arg_tys @@ -352,7 +352,7 @@ dictSelRule :: Int -> Arity dictSelRule val_index n_ty_args _ _ id_unf args | (dict_arg : _) <- drop n_ty_args args , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - = Just (con_args !! val_index) + = Just (getNth con_args val_index) | otherwise = Nothing \end{code} diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs index c3f456b..c0414ad 100644 --- a/compiler/coreSyn/CoreLint.lhs +++ b/compiler/coreSyn/CoreLint.lhs @@ -877,8 +877,8 @@ lintCoercion the_co@(NthCo n co) , n < length tys_s -> return (ks, ts, tt) where - ts = tys_s !! n - tt = tys_t !! n + ts = getNth tys_s n + tt = getNth tys_t n ks = typeKind ts _ -> failWithL (hang (ptext (sLit "Bad getNth:")) diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index 89d1c6f..87e64fb 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -78,6 +78,7 @@ import Maybes import ErrUtils import DynFlags import BasicTypes ( isAlwaysActive ) +import ListSetOps import Util import Pair import Outputable @@ -1195,7 +1196,7 @@ exprIsConApp_maybe id_unf expr , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) mk_arg (DFunPolyArg e) = mkApps e args - mk_arg (DFunLamArg i) = args !! i + mk_arg (DFunLamArg i) = getNth args i = dealWithCoercion co (con, substTys subst dfun_res_tys, map mk_arg ops) -- Look through unfoldings, but only arity-zero one; @@ -1266,7 +1267,7 @@ dealWithCoercion co stuff@(dc, _dc_univ_args, dc_args) dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, ppr arg_tys, ppr dc_args, ppr _dc_univ_args, - ppr ex_args, ppr val_args] + ppr ex_args, ppr val_args, ppr co, ppr _from_ty, ppr to_ty, ppr to_tc ] in ASSERT2( eqType _from_ty (mkTyConApp to_tc _dc_univ_args), dump_doc ) ASSERT2( all isTypeArg ex_args, dump_doc ) diff --git a/compiler/deSugar/DsBinds.lhs b/compiler/deSugar/DsBinds.lhs index 4b7f8c0..82968f8 100644 --- a/compiler/deSugar/DsBinds.lhs +++ b/compiler/deSugar/DsBinds.lhs @@ -68,6 +68,7 @@ import BasicTypes hiding ( TopLevel ) import DynFlags import FastString import ErrUtils( MsgDoc ) +import ListSetOps( getNth ) import Util import Control.Monad( when ) import MonadUtils @@ -754,7 +755,7 @@ dsEvTerm (EvTupleSel v n) (tc, tys) = splitTyConApp scrut_ty Just [dc] = tyConDataCons_maybe tc xs = mkTemplateLocals tys - the_x = xs !! n + the_x = getNth xs n ; ASSERT( isTupleTyCon tc ) return $ Case tm' (mkWildValBinder scrut_ty) (idType the_x) [(DataAlt dc, xs, Var the_x)] } diff --git a/compiler/deSugar/DsListComp.lhs b/compiler/deSugar/DsListComp.lhs index 1b81e1a..55cd837 100644 --- a/compiler/deSugar/DsListComp.lhs +++ b/compiler/deSugar/DsListComp.lhs @@ -33,6 +33,7 @@ import SrcLoc import Outputable import FastString import TcType +import ListSetOps( getNth ) import Util \end{code} @@ -869,11 +870,11 @@ mkMcUnzipM _ fmap_op ys elt_tys ; tup_xs <- newSysLocalDs tup_ty ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b - [ Type tup_ty, Type (elt_tys !! i) + [ Type tup_ty, Type (getNth elt_tys i) , mk_sel i, Var ys] mk_sel n = Lam tup_xs $ - mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs) + mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs) ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } \end{code} diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 916c777..3f53b4f 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -754,7 +754,7 @@ mk_typeable_eqn orig tvs cls tycon tc_args mtheta | isNothing mtheta -- deriving on a data type decl = do { checkTc (cls `hasKey` typeableClassKey) (ptext (sLit "Use deriving( Typeable ) on a data type declaration")) - ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon) + ; real_cls <- tcLookupClass (typeableClassNames `getNth` tyConArity tycon) -- See Note [Getting base classes] ; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) } diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs index 077eae2..5ad402d 100644 --- a/compiler/utils/ListSetOps.lhs +++ b/compiler/utils/ListSetOps.lhs @@ -15,6 +15,9 @@ module ListSetOps ( -- Duplicate handling hasNoDups, runs, removeDups, findDupsEq, equivClasses, equivClassesByUniq, + + -- Indexing + getNth ) where #include "HsVersions.h" @@ -27,6 +30,21 @@ import Util import Data.List \end{code} +--------- +#ifndef DEBUG +getNth :: [a] -> Int -> a +getNth xs n = xs !! n +#else +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = ASSERT2( xs `lengthAtLeast` n, ppr n $$ ppr xs ) + xs !! n +#endif +---------- +\begin{code} +getNth :: Outputable a => [a] -> Int -> a +getNth xs n = ASSERT2( xs `lengthExceeds` n, ppr n $$ ppr xs ) + xs !! n +\end{code} %************************************************************************ %* * _______________________________________________ Cvs-ghc mailing list Cvs-ghc@haskell.org http://www.haskell.org/mailman/listinfo/cvs-ghc
