Commit 55a95e74 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Better debug panic messages in applyTys

parent df9195e3
......@@ -154,12 +154,16 @@ applyTypeToArgs e op_ty (Type ty : args)
go rev_tys (Type ty : args) = go (ty:rev_tys) args
go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args
where
op_ty' = applyTys op_ty (reverse rev_tys)
op_ty' = applyTysD msg op_ty (reverse rev_tys)
msg = panic_msg e op_ty
applyTypeToArgs e op_ty (_ : args)
= case (splitFunTy_maybe op_ty) of
Just (_, res_ty) -> applyTypeToArgs e res_ty args
Nothing -> pprPanic "applyTypeToArgs" (pprCoreExpr e $$ ppr op_ty)
Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty)
panic_msg :: CoreExpr -> Type -> SDoc
panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
\end{code}
%************************************************************************
......
......@@ -39,7 +39,7 @@ module Type (
splitNewTyConApp_maybe, splitNewTyConApp,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
applyTy, applyTys, isForAllTy, dropForAlls,
applyTy, applyTys, applyTysD, isForAllTy, dropForAlls,
-- (Newtypes)
newTyConInstRhs,
......@@ -742,15 +742,18 @@ applyTys :: Type -> [Type] -> Type
-- > foo = case undefined :: R of
-- > R f -> f ()
applyTys orig_fun_ty [] = orig_fun_ty
applyTys orig_fun_ty arg_tys
applyTys ty args = applyTysD empty ty args
applyTysD :: SDoc -> Type -> [Type] -> Type -- Debug version
applyTysD _ orig_fun_ty [] = orig_fun_ty
applyTysD doc orig_fun_ty arg_tys
| n_tvs == n_args -- The vastly common case
= substTyWith tvs arg_tys rho_ty
| n_tvs > n_args -- Too many for-alls
= substTyWith (take n_args tvs) arg_tys
(mkForAllTys (drop n_args tvs) rho_ty)
| otherwise -- Too many type args
= ASSERT2( n_tvs > 0, ppr orig_fun_ty ) -- Zero case gives infnite loop!
= ASSERT2( n_tvs > 0, doc $$ ppr orig_fun_ty ) -- Zero case gives infnite loop!
applyTys (substTyWith tvs (take n_tvs arg_tys) rho_ty)
(drop n_tvs arg_tys)
where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment