Commit 1f689fc2 authored by sof's avatar sof
Browse files

[project @ 1997-07-26 03:26:10 by sof]

tcGRHS + tcGRHSsAndBinds carry extra expected type arg
parent a54d6062
......@@ -16,48 +16,47 @@ IMPORT_DELOOPER(TcLoop) -- for paranoia checking
import HsSyn ( GRHSsAndBinds(..), GRHS(..), MonoBinds, Stmt, DoOrListComp(..),
HsExpr, HsBinds(..), InPat, OutPat, Sig, Fake )
import RnHsSyn ( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
import TcHsSyn ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) )
import TcHsSyn ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS) )
import TcMonad
import Inst ( Inst, SYN_IE(LIE), plusLIE )
import Kind ( mkTypeKind )
import TcBinds ( tcBindsAndThen )
import TcExpr ( tcExpr, tcStmt )
import TcType ( SYN_IE(TcType) )
import Unify ( unifyTauTy )
import TcType ( SYN_IE(TcType), TcIdOcc(..), newTyVarTy )
import TysWiredIn ( boolTy )
\end{code}
\begin{code}
tcGRHSs :: [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s, TcType s)
tcGRHSs :: TcType s -> [RenamedGRHS] -> TcM s ([TcGRHS s], LIE s)
tcGRHSs [grhs]
= tcGRHS grhs `thenTc` \ (grhs', lie, ty) ->
returnTc ([grhs'], lie, ty)
tcGRHSs expected_ty [grhs]
= tcGRHS expected_ty grhs `thenTc` \ (grhs', lie) ->
returnTc ([grhs'], lie)
tcGRHSs (grhs:grhss)
= tcGRHS grhs `thenTc` \ (grhs', lie1, ty1) ->
tcGRHSs grhss `thenTc` \ (grhss', lie2, ty2) ->
unifyTauTy ty1 ty2 `thenTc_`
returnTc (grhs' : grhss', lie1 `plusLIE` lie2, ty1)
tcGRHSs expected_ty (grhs:grhss)
= tcGRHS expected_ty grhs `thenTc` \ (grhs', lie1) ->
tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie2) ->
returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
tcGRHS (OtherwiseGRHS expr locn)
tcGRHS expected_ty (OtherwiseGRHS expr locn)
= tcAddSrcLoc locn $
tcExpr expr `thenTc` \ (expr, lie, ty) ->
returnTc (OtherwiseGRHS expr locn, lie, ty)
tcExpr expr expected_ty `thenTc` \ (expr, lie) ->
returnTc (OtherwiseGRHS expr locn, lie)
tcGRHS (GRHS guard expr locn)
tcGRHS expected_ty (GRHS guard expr locn)
= tcAddSrcLoc locn $
tc_stmts guard `thenTc` \ ((guard', expr', ty), lie) ->
returnTc (GRHS guard' expr' locn, lie, ty)
tc_stmts guard `thenTc` \ ((guard', expr'), lie) ->
returnTc (GRHS guard' expr' locn, lie)
where
tc_stmts [] = tcExpr expr `thenTc` \ (expr2, expr_lie, expr_ty) ->
returnTc (([], expr2, expr_ty), expr_lie)
tc_stmts [] = tcExpr expr expected_ty `thenTc` \ (expr2, expr_lie) ->
returnTc (([], expr2), expr_lie)
tc_stmts (stmt:stmts) = tcStmt tcExpr ListComp (\x->x) combine stmt $
tc_stmts stmts
combine stmt _ (stmts, expr, ty) = (stmt:stmts, expr, ty)
combine stmt _ (stmts, expr) = (stmt:stmts, expr)
\end{code}
......@@ -65,17 +64,17 @@ tcGRHS (GRHS guard expr locn)
pieces.
\begin{code}
tcGRHSsAndBinds :: RenamedGRHSsAndBinds
-> TcM s (TcGRHSsAndBinds s, LIE s, TcType s)
tcGRHSsAndBinds :: TcType s -- Expected type of RHSs
-> RenamedGRHSsAndBinds
-> TcM s (TcGRHSsAndBinds s, LIE s)
tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
tcGRHSsAndBinds expected_ty (GRHSsAndBindsIn grhss binds)
= tcBindsAndThen
combiner binds
(tcGRHSs grhss `thenTc` \ (grhss', lie, ty) ->
returnTc (GRHSsAndBindsOut grhss' EmptyBinds ty, lie)
) `thenTc` \ (grhss_and_binds'@(GRHSsAndBindsOut _ _ result_ty), lie) ->
returnTc (grhss_and_binds', lie, result_ty)
(tcGRHSs expected_ty grhss `thenTc` \ (grhss', lie) ->
returnTc (GRHSsAndBindsOut grhss' EmptyBinds expected_ty, lie)
)
where
combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty)
combiner is_rec binds1 (GRHSsAndBindsOut grhss binds2 ty)
= GRHSsAndBindsOut grhss ((MonoBind binds1 [] is_rec) `ThenBinds` binds2) ty
\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