[ghc-hetmet.git] / ghc / compiler / typecheck / TcMatches.lhs

%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[TcMatches]{Typecheck some @Matches@}

\begin{code}
module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, 
                   tcDoStmts, tcStmtsAndThen, tcGRHSs, tcThingWithSig
       ) where

#include "HsVersions.h"

import {-# SOURCE #-}   TcExpr( tcCheckRho, tcMonoExpr )

import HsSyn            ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..),
                          MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..),
                          pprMatch, getMatchLoc, isDoExpr,
                          pprMatchContext, pprStmtContext, pprStmtResultContext,
                          mkMonoBind, collectSigTysFromPats, andMonoBindList
                        )
import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt, 
                          RenamedPat, RenamedMatchContext )
import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, 
                          TcMonoBinds, TcPat, TcStmt, ExprCoFn,
                          isIdCoercion, (<$>), (<.>) )

import TcRnMonad
import TcMonoType       ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
import Inst             ( tcSyntaxName, tcInstCall )
import TcEnv            ( TcId, tcLookupLocalIds, tcLookupId, tcExtendLocalValEnv, tcExtendLocalValEnv2 )
import TcPat            ( tcPat, tcMonoPatBndr )
import TcMType          ( newTyVarTy, newTyVarTys, zonkTcType ) 
import TcType           ( TcType, TcTyVar, TcSigmaType, TcRhoType,
                          tyVarsOfType, tidyOpenTypes, tidyOpenType, isSigmaTy,
                          mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind, 
                          mkArrowKind, mkAppTy )
import TcBinds          ( tcBindsAndThen )
import TcUnify          ( Expected(..), newHole, zapExpectedType, zapExpectedBranches, readExpectedType,
                          unifyTauTy, subFunTy, unifyPArrTy, unifyListTy, unifyFunTy,
                          checkSigTyVarsWrt, tcSubExp, tcGen )
import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
import Name             ( Name )
import PrelNames        ( monadNames, mfixName )
import TysWiredIn       ( boolTy, mkListTy, mkPArrTy )
import Id               ( idType, mkSysLocal, mkLocalId )
import CoreFVs          ( idFreeTyVars )
import BasicTypes       ( RecFlag(..) )
import VarSet
import Var              ( Id )
import Bag
import Util             ( isSingleton, notNull, zipEqual )
import Outputable

import List             ( nub )
\end{code}

%************************************************************************
%*                                                                      *
\subsection{tcMatchesFun, tcMatchesCase}
%*                                                                      *
%************************************************************************

@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
@FunMonoBind@.  The second argument is the name of the function, which
is used in error messages.  It checks that all the equations have the
same number of arguments before using @tcMatches@ to do the work.

\begin{code}
tcMatchesFun :: Name
             -> [RenamedMatch]
             -> Expected TcRhoType              -- Expected type
             -> TcM [TcMatch]

tcMatchesFun fun_name matches@(first_match:_) expected_ty
  =      -- Check that they all have the same no of arguments
         -- Set the location to that of the first equation, so that
         -- any inter-equation error messages get some vaguely
         -- sensible location.  Note: we have to do this odd
         -- ann-grabbing, because we don't always have annotations in
         -- hand when we call tcMatchesFun...
    addSrcLoc (getMatchLoc first_match)  (
            checkTc (sameNoOfArgs matches)
                    (varyingArgsErr fun_name matches)
    )                                            `thenM_`

        -- ToDo: Don't use "expected" stuff if there ain't a type signature
        -- because inconsistency between branches
        -- may show up as something wrong with the (non-existent) type signature

        -- No need to zonk expected_ty, because subFunTy does that on the fly
    tcMatches (FunRhs fun_name) matches expected_ty
\end{code}

@tcMatchesCase@ doesn't do the argument-count check because the
parser guarantees that each equation has exactly one argument.

\begin{code}
tcMatchesCase :: [RenamedMatch]         -- The case alternatives
              -> Expected TcRhoType     -- Type of whole case expressions
              -> TcM (TcRhoType,        -- Inferred type of the scrutinee
                      [TcMatch])        -- Translated alternatives

tcMatchesCase matches (Check expr_ty)
  =     -- This case is a bit yukky, because it prevents the
        -- scrutinee being higher-ranked, which might just possible
        -- matter if we were seq'ing on it.  But it's awkward to fix.
    newTyVarTy openTypeKind                                             `thenM` \ scrut_ty ->
    tcMatches CaseAlt matches (Check (mkFunTy scrut_ty expr_ty))        `thenM` \ matches' ->
    returnM (scrut_ty, matches')

tcMatchesCase matches (Infer hole)
  = newHole                                     `thenM` \ fun_hole ->
    tcMatches CaseAlt matches (Infer fun_hole)  `thenM` \ matches' ->
    readMutVar fun_hole                         `thenM` \ fun_ty ->
        -- The result of tcMatches is bound to be a function type
    unifyFunTy fun_ty                           `thenM` \ (scrut_ty, res_ty) ->
    writeMutVar hole res_ty                     `thenM_` 
    returnM (scrut_ty, matches')
    

tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch
tcMatchLambda match res_ty = tcMatch LambdaExpr match res_ty
\end{code}


\begin{code}
tcMatches :: RenamedMatchContext 
          -> [RenamedMatch]
          -> Expected TcRhoType
          -> TcM [TcMatch]

tcMatches ctxt matches exp_ty
  =     -- If there is more than one branch, and exp_ty is a 'hole',
        -- all branches must be types, not type schemes, otherwise the
        -- order in which we check them would affect the result.
    zapExpectedBranches matches exp_ty  `thenM` \ exp_ty' ->
    mappM (tc_match exp_ty') matches
  where
    tc_match exp_ty match = tcMatch ctxt match exp_ty
\end{code}


%************************************************************************
%*                                                                      *
\subsection{tcMatch}
%*                                                                      *
%************************************************************************

\begin{code}
tcMatch :: RenamedMatchContext
        -> RenamedMatch
        -> Expected TcRhoType   -- Expected result-type of the Match.
                        -- Early unification with this guy gives better error messages
                        -- We regard the Match as having type 
                        --      (ty1 -> ... -> tyn -> result_ty)
                        -- where there are n patterns.
        -> TcM TcMatch

tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
  = addSrcLoc (getMatchLoc match)               $       -- At one stage I removed this;
    addErrCtxt (matchCtxt ctxt match)           $       -- I'm not sure why, so I put it back
    tcMatchPats pats expected_ty tc_grhss       `thenM` \ (pats', grhss', ex_binds) ->
    returnM (Match pats' Nothing (glue_on ex_binds grhss'))

  where
    tc_grhss rhs_ty 
        =       -- Deal with the result signature
          case maybe_rhs_sig of
            Nothing ->  tcGRHSs ctxt grhss rhs_ty

            Just sig ->  tcAddScopedTyVars [sig]        $
                                -- Bring into scope the type variables in the signature
                         tcHsSigType ResSigCtxt sig                                     `thenM` \ sig_ty ->
                         tcThingWithSig sig_ty (tcGRHSs ctxt grhss . Check) rhs_ty      `thenM` \ (co_fn, grhss') ->

                        -- Pushes the coercion down to the right hand sides,
                        -- because there is no convenient place to hang it otherwise.
                         if isIdCoercion co_fn then
                                returnM grhss'
                         else
                         readExpectedType rhs_ty                `thenM` \ rhs_ty' ->
                         returnM (lift_grhss co_fn rhs_ty' grhss')

lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
  = GRHSs (map lift_grhs grhss) binds rhs_ty    -- Change the type, since the coercion does
  where
    lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
              
    lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
    lift_stmt stmt             = stmt
   
-- glue_on just avoids stupid dross
glue_on EmptyBinds grhss = grhss                -- The common case
glue_on binds1 (GRHSs grhss binds2 ty)
  = GRHSs grhss (binds1 `ThenBinds` binds2) ty


tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
        -> Expected TcRhoType
        -> TcM TcGRHSs

  -- Special case when there is just one equation with a degenerate 
  -- guard; then we pass in the full Expected type, so that we get
  -- good inference from simple things like
  --    f = \(x::forall a.a->a) -> <stuff>
  -- This is a consequence of the fact that tcStmts takes a TcType,
  -- not a Expected TcType, a decision we could revisit if necessary
tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty
  = tcBindsAndThen glue_on binds        $
    tcMonoExpr rhs exp_ty               `thenM` \ rhs' ->
    readExpectedType exp_ty             `thenM` \ exp_ty' ->
    returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty')

tcGRHSs ctxt (GRHSs grhss binds _) exp_ty
  = tcBindsAndThen glue_on binds        $
    zapExpectedType exp_ty              `thenM` \ exp_ty' ->
        -- Even if there is only one guard, we zap the RHS type to
        -- a monotype.  Reason: it makes tcStmts much easier,
        -- and even a one-armed guard has a notional second arm
    let
      tc_grhs (GRHS guarded locn)
        = addSrcLoc locn                        $
          tcStmts (PatGuard ctxt) m_ty guarded  `thenM` \ guarded' ->
          returnM (GRHS guarded' locn)

      m_ty =  (\ty -> ty, exp_ty') 
    in
    mappM tc_grhs grhss                 `thenM` \ grhss' ->
    returnM (GRHSs grhss' EmptyBinds exp_ty')
\end{code}


\begin{code}
tcThingWithSig :: TcSigmaType           -- Type signature
               -> (TcRhoType -> TcM r)  -- How to type check the thing inside
               -> Expected TcRhoType    -- Overall expected result type
               -> TcM (ExprCoFn, r)
-- Used for expressions with a type signature, and for result type signatures

tcThingWithSig sig_ty thing_inside res_ty
  | not (isSigmaTy sig_ty)
  = thing_inside sig_ty         `thenM` \ result ->
    tcSubExp res_ty sig_ty      `thenM` \ co_fn ->
    returnM (co_fn, result)

  | otherwise   -- The signature has some outer foralls
  =     -- Must instantiate the outer for-alls of sig_tc_ty
        -- else we risk instantiating a ? res_ty to a forall-type
        -- which breaks the invariant that tcMonoExpr only returns phi-types
    tcGen sig_ty emptyVarSet thing_inside       `thenM` \ (gen_fn, result) ->
    tcInstCall SignatureOrigin sig_ty           `thenM` \ (inst_fn, inst_sig_ty) ->
    tcSubExp res_ty inst_sig_ty                 `thenM` \ co_fn ->
    returnM (co_fn <.> inst_fn <.> gen_fn,  result)
        -- Note that we generalise, then instantiate. Ah well.
\end{code}


%************************************************************************
%*                                                                      *
\subsection{tcMatchPats}
%*                                                                      *
%************************************************************************

\begin{code}      
tcMatchPats
        :: [RenamedPat] -> Expected TcRhoType
        -> (Expected TcRhoType -> TcM a)
        -> TcM ([TcPat], a, TcHsBinds)
-- Typecheck the patterns, extend the environment to bind the variables,
-- do the thing inside, use any existentially-bound dictionaries to 
-- discharge parts of the returning LIE, and deal with pattern type
-- signatures

tcMatchPats pats expected_ty thing_inside
  =     -- STEP 1: Bring pattern-signature type variables into scope
    tcAddScopedTyVars (collectSigTysFromPats pats)      (

        -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
        --         then do the thing inside
        getLIE (tc_match_pats pats expected_ty thing_inside)

    ) `thenM` \ ((pats', ex_tvs, ex_ids, ex_lie, result), lie_req) -> 

        -- STEP 4: Check for existentially bound type variables
        -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
        -- complains that 'a' is captured by the inscope 'a'!  (Test (d) in checkSigTyVars.)
        --
        -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
        -- might need (via lie_req2) something made available from an 'outer' 
        -- pattern.  But it's inconvenient to deal with, and I can't find an example
    readExpectedType expected_ty                                `thenM` \ exp_ty ->
    tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req exp_ty   `thenM` \ ex_binds ->
        -- NB: we *must* pass "exp_ty" not "result_ty" to tcCheckExistentialPat
        -- For example, we must reject this program:
        --      data C = forall a. C (a -> Int) 
        --      f (C g) x = g x
        -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).

    returnM (pats', result, mkMonoBind Recursive ex_binds)

tc_match_pats [] expected_ty thing_inside
  = thing_inside expected_ty    `thenM` \ answer ->
    returnM ([], emptyBag, [], [], answer)

tc_match_pats (pat:pats) expected_ty thing_inside
  = subFunTy expected_ty                $ \ arg_ty rest_ty ->
        -- This is the unique place we call subFunTy
        -- The point is that if expected_y is a "hole", we want 
        -- to make arg_ty and rest_ty as "holes" too.
    tcPat tcMonoPatBndr pat arg_ty      `thenM` \ (pat', ex_tvs, pat_bndrs, ex_lie) ->
    let
        xve    = bagToList pat_bndrs
        ex_ids = [id | (_, id) <- xve]
                -- ex_ids is all the pattern-bound Ids, a superset
                -- of the existential Ids used in checkExistentialPat
    in
    tcExtendLocalValEnv2 xve                    $
    tc_match_pats pats rest_ty thing_inside     `thenM` \ (pats', exs_tvs, exs_ids, exs_lie, answer) ->
    returnM (   pat':pats',
                ex_tvs `unionBags` exs_tvs,
                ex_ids ++ exs_ids,
                ex_lie ++ exs_lie,
                answer
    )


tcCheckExistentialPat :: Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
                      -> [TcId]         -- Ids bound by this pattern; used 
                                        --   (a) by bindsInstsOfLocalFuns
                                        --   (b) to generate helpful error messages
                      -> [Inst]         --   and context
                      -> [Inst]         -- Required context
                      -> TcType         --   and type of the Match; vars in here must not escape
                      -> TcM TcDictBinds        -- LIE to float out and dict bindings
tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
  | isEmptyBag ex_tvs && all not_overloaded ex_ids
        -- Short cut for case when there are no existentials
        -- and no polymorphic overloaded variables
        --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
        --       f op x = ....
        --  Here we must discharge op Methods
  = ASSERT( null ex_lie )
    extendLIEs lie_req          `thenM_` 
    returnM EmptyMonoBinds

  | otherwise
  = addErrCtxtM (sigPatCtxt tv_list ex_ids match_ty)            $

        -- In case there are any polymorpic, overloaded binders in the pattern
        -- (which can happen in the case of rank-2 type signatures, or data constructors
        -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
    getLIE (bindInstsOfLocalFuns lie_req ex_ids)        `thenM` \ (inst_binds, lie) ->

        -- Deal with overloaded functions bound by the pattern
    tcSimplifyCheck doc tv_list ex_lie lie              `thenM` \ dict_binds ->
    checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list   `thenM_` 

    returnM (dict_binds `AndMonoBinds` inst_binds)
  where
    doc     = text ("existential context of a data constructor")
    tv_list = bagToList ex_tvs
    not_overloaded id = not (isOverloadedTy (idType id))
\end{code}


%************************************************************************
%*                                                                      *
\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
%*                                                                      *
%************************************************************************

\begin{code}
tcDoStmts :: HsStmtContext Name -> [RenamedStmt] -> [Name] 
          -> TcRhoType          -- To keep it simple, we don't have an "expected" type here
          -> TcM (TcMonoBinds, [TcStmt], [Id])
tcDoStmts PArrComp stmts method_names res_ty
  = unifyPArrTy res_ty                            `thenM` \elt_ty ->
    tcStmts PArrComp (mkPArrTy, elt_ty) stmts      `thenM` \ stmts' ->
    returnM (EmptyMonoBinds, stmts', [{- unused -}])

tcDoStmts ListComp stmts method_names res_ty
  = unifyListTy res_ty                          `thenM` \ elt_ty ->
    tcStmts ListComp (mkListTy, elt_ty) stmts   `thenM` \ stmts' ->
    returnM (EmptyMonoBinds, stmts', [{- unused -}])

tcDoStmts do_or_mdo_expr stmts method_names res_ty
  = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)      `thenM` \ m_ty ->
    newTyVarTy liftedTypeKind                                   `thenM` \ elt_ty ->
    unifyTauTy res_ty (mkAppTy m_ty elt_ty)                     `thenM_`

    tcStmts do_or_mdo_expr (mkAppTy m_ty, elt_ty) stmts         `thenM` \ stmts' ->

        -- Build the then and zero methods in case we need them
        -- It's important that "then" and "return" appear just once in the final LIE,
        -- not only for typechecker efficiency, but also because otherwise during
        -- simplification we end up with silly stuff like
        --      then = case d of (t,r) -> t
        --      then = then
        -- where the second "then" sees that it already exists in the "available" stuff.
        --
    mapAndUnzipM (tc_syn_name m_ty) 
                 (zipEqual "tcDoStmts" currentMonadNames method_names)  `thenM` \ (binds, ids) ->
    returnM (andMonoBindList binds, stmts', ids)
  where
    currentMonadNames = case do_or_mdo_expr of
                          DoExpr  -> monadNames
                          MDoExpr -> monadNames ++ [mfixName]
    tc_syn_name :: TcType -> (Name,Name) -> TcM (TcMonoBinds, Id)
    tc_syn_name m_ty (std_nm, usr_nm)
        = tcSyntaxName DoOrigin m_ty std_nm usr_nm      `thenM` \ (expr, expr_ty) ->
          case expr of
            HsVar v -> returnM (EmptyMonoBinds, v)
            other   -> newUnique                `thenM` \ uniq ->
                       let
                          id = mkSysLocal FSLIT("syn") uniq expr_ty
                       in
                       returnM (VarMonoBind id expr, id)
\end{code}


%************************************************************************
%*                                                                      *
\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
\end{code}


%************************************************************************
%*                                                                      *
\subsection{Errors and contexts}
%*                                                                      *
%************************************************************************

@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
number of args are used in each equation.

\begin{code}
sameNoOfArgs :: [RenamedMatch] -> Bool
sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
  where
    args_in_match :: RenamedMatch -> Int
    args_in_match (Match pats _ _) = length pats
\end{code}

\begin{code}
varyingArgsErr name matches
  = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]

matchCtxt ctxt  match  = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
stmtCtxt do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtContext do_or_lc <> colon) 4 (ppr stmt)
resCtxt  do_or_lc stmt = hang (ptext SLIT("In") <+> pprStmtResultContext do_or_lc <> colon) 4 (ppr stmt)

sigPatCtxt bound_tvs bound_ids match_ty tidy_env 
  = zonkTcType match_ty         `thenM` \ match_ty' ->
    let
        (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
        (env2, tidy_mty) = tidyOpenType  env1     match_ty'
    in
    returnM (env1,
                 sep [ptext SLIT("When checking an existential match that binds"),
                      nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
                      ptext SLIT("and whose type is") <+> ppr tidy_mty])
  where
    show_ids = filter is_interesting bound_ids
    is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs

    ppr_id id ty     = ppr id <+> dcolon <+> ppr ty
        -- Don't zonk the types so we get the separate, un-unified versions
\end{code}