+%************************************************************************
+%* *
+\subsection{tcStmts}
+%* *
+%************************************************************************
+
+Typechecking statements is rendered a bit tricky by parallel list comprehensions:
+
+ [ (g x, h x) | ... ; let g v = ...
+ | ... ; let h v = ... ]
+
+It's possible that g,h are overloaded, so we need to feed the LIE from the
+(g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
+Similarly if we had an existential pattern match:
+
+ data T = forall a. Show a => C a
+
+ [ (show x, show y) | ... ; C x <- ...
+ | ... ; C y <- ... ]
+
+Then we need the LIE from (show x, show y) to be simplified against
+the bindings for x and y.
+
+It's difficult to do this in parallel, so we rely on the renamer to
+ensure that g,h and x,y don't duplicate, and simply grow the environment.
+So the binders of the first parallel group will be in scope in the second
+group. But that's fine; there's no shadowing to worry about.
+
+\begin{code}
+tcStmts do_or_lc m_ty stmts
+ = ASSERT( notNull stmts )
+ tcStmtsAndThen (:) do_or_lc m_ty stmts (returnM [])
+
+tcStmtsAndThen
+ :: (TcStmt -> thing -> thing) -- Combiner
+ -> HsStmtContext Name
+ -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
+ -- res_ty, the type of the entire comprehension
+ -- used at the end for the type of (return x)
+ -- or the final expression in do-notation
+ -> [RenamedStmt]
+ -> TcM thing
+ -> TcM thing
+
+ -- Base case
+tcStmtsAndThen combine do_or_lc m_ty [] do_next
+ = do_next
+
+tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
+ = tcStmtAndThen combine do_or_lc m_ty stmt
+ (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
+
+ -- LetStmt
+tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
+ = tcBindsAndThen -- No error context, but a binding group is
+ (glue_binds combine) -- rather a large thing for an error context anyway
+ binds
+ thing_inside
+
+tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
+ = addSrcLoc src_loc $
+ addErrCtxt (stmtCtxt do_or_lc stmt) $
+ newTyVarTy liftedTypeKind `thenM` \ pat_ty ->
+ tcCheckRho exp (m pat_ty) `thenM` \ exp' ->
+ tcMatchPats [pat] (Check (mkFunTy pat_ty (m elt_ty))) (\ _ ->
+ popErrCtxt thing_inside
+ ) `thenM` \ ([pat'], thing, dict_binds) ->
+ returnM (combine (BindStmt pat' exp' src_loc)
+ (glue_binds combine dict_binds thing))
+
+ -- ParStmt
+tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
+ = loop bndr_stmts_s `thenM` \ (pairs', thing) ->
+ returnM (combine (ParStmtOut pairs') thing)
+ where
+ loop []
+ = thing_inside `thenM` \ thing ->
+ returnM ([], thing)
+
+ loop ((bndrs,stmts) : pairs)
+ = tcStmtsAndThen
+ combine_par ListComp m_ty stmts
+ -- Notice we pass on m_ty; the result type is used only
+ -- to get escaping type variables for checkExistentialPat
+ (tcLookupLocalIds bndrs `thenM` \ bndrs' ->
+ loop pairs `thenM` \ (pairs', thing) ->
+ returnM ([], (bndrs', pairs', thing))) `thenM` \ (stmts', (bndrs', pairs', thing)) ->
+
+ returnM ((bndrs',stmts') : pairs', thing)
+
+ combine_par stmt (stmts, thing) = (stmt:stmts, thing)
+
+ -- RecStmt
+tcStmtAndThen combine do_or_lc m_ty (RecStmt recNames stmts _) thing_inside
+ = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
+ let
+ mono_ids = zipWith mkLocalId recNames recTys
+ in
+ tcExtendLocalValEnv mono_ids $
+ tcStmtsAndThen combine_rec do_or_lc m_ty stmts (
+ mappM tc_ret (recNames `zip` recTys) `thenM` \ rets ->
+ returnM ([], rets)
+ ) `thenM` \ (stmts', rets) ->
+
+ -- NB: it's the mono_ids that scope over this part
+ thing_inside `thenM` \ thing ->
+
+ returnM (combine (RecStmt mono_ids stmts' rets) thing)
+ where
+ combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
+
+ -- Unify the types of the "final" Ids with those of "knot-tied" Ids
+ tc_ret (rec_name, mono_ty)
+ = tcLookupId rec_name `thenM` \ poly_id ->
+ -- poly_id may have a polymorphic type
+ -- but mono_ty is just a monomorphic type variable
+ tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn ->
+ returnM (co_fn <$> HsVar poly_id)
+
+ -- ExprStmt
+tcStmtAndThen combine do_or_lc m_ty@(m, _) stmt@(ExprStmt exp _ locn) thing_inside
+ = addErrCtxt (stmtCtxt do_or_lc stmt) (
+ if isDoExpr do_or_lc then
+ newTyVarTy openTypeKind `thenM` \ any_ty ->
+ tcCheckRho exp (m any_ty) `thenM` \ exp' ->
+ returnM (ExprStmt exp' any_ty locn)
+ else
+ tcCheckRho exp boolTy `thenM` \ exp' ->
+ returnM (ExprStmt exp' boolTy locn)
+ ) `thenM` \ stmt' ->
+
+ thing_inside `thenM` \ thing ->
+ returnM (combine stmt' thing)
+
+
+ -- Result statements
+tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
+ = addErrCtxt (resCtxt do_or_lc stmt) (
+ if isDoExpr do_or_lc then
+ tcCheckRho exp (m res_elt_ty)
+ else
+ tcCheckRho exp res_elt_ty
+ ) `thenM` \ exp' ->
+
+ thing_inside `thenM` \ thing ->
+
+ returnM (combine (ResultStmt exp' locn) thing)
+
+
+------------------------------
+glue_binds combine EmptyBinds thing = thing
+glue_binds combine other_binds thing = combine (LetStmt other_binds) thing