Commit f5d148cf authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Improve debug error message for applyTypeToArgs

parent a1efe57e
...@@ -139,33 +139,33 @@ Various possibilities suggest themselves: ...@@ -139,33 +139,33 @@ Various possibilities suggest themselves:
\begin{code} \begin{code}
applyTypeToArg :: Type -> CoreExpr -> Type applyTypeToArg :: Type -> CoreExpr -> Type
-- ^ Determines the type resulting from applying an expression to a function with the given type -- ^ Determines the type resulting from applying an expression with given type
-- to a given argument expression
applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty applyTypeToArg fun_ty (Type arg_ty) = applyTy fun_ty arg_ty
applyTypeToArg fun_ty _ = funResultTy fun_ty applyTypeToArg fun_ty _ = funResultTy fun_ty
applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type applyTypeToArgs :: CoreExpr -> Type -> [CoreExpr] -> Type
-- ^ A more efficient version of 'applyTypeToArg' when we have several arguments. -- ^ A more efficient version of 'applyTypeToArg' when we have several arguments.
-- The first argument is just for debugging, and gives some context -- The first argument is just for debugging, and gives some context
applyTypeToArgs _ op_ty [] = op_ty applyTypeToArgs e op_ty args
= go op_ty args
applyTypeToArgs e op_ty (Type ty : args)
= -- Accumulate type arguments so we can instantiate all at once
go [ty] args
where where
go rev_tys (Type ty : args) = go (ty:rev_tys) args go op_ty [] = op_ty
go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args go op_ty (Type ty : args) = go_ty_args op_ty [ty] args
where go op_ty (_ : args) | Just (_, res_ty) <- splitFunTy_maybe op_ty
op_ty' = applyTysD msg op_ty (reverse rev_tys) = go res_ty args
msg = ptext (sLit "applyTypeToArgs") <+> go _ _ = pprPanic "applyTypeToArgs" panic_msg
panic_msg e op_ty
-- go_ty_args: accumulate type arguments so we can instantiate all at once
applyTypeToArgs e op_ty (_ : args) go_ty_args op_ty rev_tys (Type ty : args)
= case (splitFunTy_maybe op_ty) of = go_ty_args op_ty (ty:rev_tys) args
Just (_, res_ty) -> applyTypeToArgs e res_ty args go_ty_args op_ty rev_tys args
Nothing -> pprPanic "applyTypeToArgs" (panic_msg e op_ty) = go (applyTysD panic_msg_w_hdr op_ty (reverse rev_tys)) args
panic_msg :: CoreExpr -> Type -> SDoc panic_msg_w_hdr = hang (ptext (sLit "applyTypeToArgs")) 2 panic_msg
panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty panic_msg = vcat [ ptext (sLit "Expression:") <+> pprCoreExpr e
, ptext (sLit "Type:") <+> ppr op_ty
, ptext (sLit "Args:") <+> ppr args ]
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
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