ghc/compiler/typecheck/TcGRHSs.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcGRHSs]{Typecheck guarded right-hand-sides}
   5
   6 \begin{code}
   7 module TcGRHSs ( tcGRHSsAndBinds, tcStmts ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-}   TcExpr( tcExpr )
  12
  13 import HsSyn            ( HsBinds(..), GRHSsAndBinds(..), GRHS(..), StmtCtxt(..),
  14                           Stmt(..)
  15                         )
  16 import RnHsSyn          ( RenamedGRHSsAndBinds, RenamedGRHS, RenamedStmt )
  17 import TcHsSyn          ( TcGRHSsAndBinds, TcGRHS, TcStmt )
  18
  19 import TcEnv            ( tcExtendGlobalTyVars, tcExtendEnvWithPat )
  20 import TcMonad
  21 import Inst             ( LIE, plusLIE )
  22 import TcBinds          ( tcBindsAndThen )
  23 import TcSimplify       ( tcSimplifyAndCheck )
  24 import TcPat            ( tcPat )
  25 import TcMonoType       ( checkSigTyVars, noSigs, existentialPatCtxt )
  26 import TcType           ( TcType, newTyVarTy )
  27 import TysWiredIn       ( boolTy )
  28 import Type             ( tyVarsOfType, openTypeKind, boxedTypeKind )
  29 import BasicTypes       ( RecFlag(..) )
  30 import VarSet
  31 import Bag
  32 import Outputable
  33 \end{code}
  34
  35
  36 %************************************************************************
  37 %*                                                                      *
  38 \subsection{GRHSs}
  39 %*                                                                      *
  40 %************************************************************************
  41
  42 \begin{code}
  43 tcGRHSs :: [RenamedGRHS] -> TcType s -> StmtCtxt -> TcM s ([TcGRHS s], LIE s)
  44
  45 tcGRHSs [grhs] expected_ty ctxt
  46   = tcGRHS grhs expected_ty ctxt        `thenTc` \ (grhs', lie) ->
  47     returnTc ([grhs'], lie)
  48
  49 tcGRHSs (grhs:grhss) expected_ty ctxt
  50   = tcGRHS  grhs  expected_ty ctxt      `thenTc` \ (grhs',  lie1) ->
  51     tcGRHSs grhss expected_ty ctxt      `thenTc` \ (grhss', lie2) ->
  52     returnTc (grhs' : grhss', lie1 `plusLIE` lie2)
  53
  54 tcGRHS (GRHS guarded locn) expected_ty ctxt
  55   = tcAddSrcLoc locn                                    $
  56     tcStmts ctxt (\ty -> ty) guarded expected_ty        `thenTc` \ (guarded', lie) ->
  57     returnTc (GRHS guarded' locn, lie)
  58 \end{code}
  59
  60
  61 %************************************************************************
  62 %*                                                                      *
  63 \subsection{GRHSsAndBinds}
  64 %*                                                                      *
  65 %************************************************************************
  66
  67 @tcGRHSsAndBinds@ typechecks (grhss where binds), returning suitable
  68 pieces.
  69
  70 \begin{code}
  71 tcGRHSsAndBinds :: RenamedGRHSsAndBinds
  72                 -> TcType s                     -- Expected type of RHSs
  73                 -> StmtCtxt
  74                 -> TcM s (TcGRHSsAndBinds s, LIE s)
  75
  76 tcGRHSsAndBinds (GRHSsAndBindsIn grhss binds) expected_ty ctxt
  77   = tcBindsAndThen
  78          combiner binds
  79          (tcGRHSs grhss expected_ty ctxt        `thenTc` \ (grhss, lie) ->
  80           returnTc (GRHSsAndBindsOut grhss EmptyBinds expected_ty, lie))
  81   where
  82     combiner is_rec mbinds (GRHSsAndBindsOut grhss binds expected_ty)
  83         = GRHSsAndBindsOut grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) expected_ty
  84 \end{code}
  85
  86
  87 %************************************************************************
  88 %*                                                                      *
  89 \subsection{Record bindings}
  90 %*                                                                      *
  91 %************************************************************************
  92
  93
  94 \begin{code}
  95 tcStmts :: StmtCtxt
  96         -> (TcType s -> TcType s)       -- m, the relationship type of pat and rhs in pat <- rhs
  97         -> [RenamedStmt]
  98         -> TcType s                     -- elt_ty, where type of the comprehension is (m elt_ty)
  99         -> TcM s ([TcStmt s], LIE s)
 100
 101 tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
 102   = ASSERT( null stmts )
 103     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 104     tcExpr exp elt_ty                           `thenTc`    \ (exp', exp_lie) ->
 105     returnTc ([ReturnStmt exp'], exp_lie)
 106
 107         -- ExprStmt at the end
 108 tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
 109   = tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 110     tcExpr exp (m elt_ty)                       `thenTc`    \ (exp', exp_lie) ->
 111     returnTc ([ExprStmt exp' src_loc], exp_lie)
 112
 113         -- ExprStmt not at the end
 114 tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
 115   = ASSERT( isDoStmt do_or_lc )
 116     tcAddSrcLoc src_loc                 (
 117         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 118             -- exp has type (m tau) for some tau (doesn't matter what)
 119         newTyVarTy openTypeKind                 `thenNF_Tc` \ any_ty ->
 120         tcExpr exp (m any_ty)
 121     )                                   `thenTc` \ (exp', exp_lie) ->
 122     tcStmts do_or_lc m stmts elt_ty     `thenTc` \ (stmts', stmts_lie) ->
 123     returnTc (ExprStmt exp' src_loc : stmts',
 124               exp_lie `plusLIE` stmts_lie)
 125
 126 tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
 127   = ASSERT( not (isDoStmt do_or_lc) )
 128     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 129         tcAddSrcLoc src_loc             $
 130         tcExpr exp boolTy
 131     )                                   `thenTc` \ (exp', exp_lie) ->
 132     tcStmts do_or_lc m stmts elt_ty     `thenTc` \ (stmts', stmts_lie) ->
 133     returnTc (GuardStmt exp' src_loc : stmts',
 134               exp_lie `plusLIE` stmts_lie)
 135
 136 tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
 137   = tcAddSrcLoc src_loc         (
 138         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 139         newTyVarTy boxedTypeKind                `thenNF_Tc` \ pat_ty ->
 140         tcPat noSigs pat pat_ty                 `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
 141         tcExpr exp (m pat_ty)                   `thenTc` \ (exp', exp_lie) ->
 142         returnTc (pat', exp',
 143                   pat_lie `plusLIE` exp_lie,
 144                   pat_tvs, pat_ids, avail)
 145     )                                   `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_ids, lie_avail) ->
 146
 147         -- Do the rest; we don't need to add the pat_tvs to the envt
 148         -- because they all appear in the pat_ids's types
 149     tcExtendEnvWithPat pat_ids (
 150        tcStmts do_or_lc m stmts elt_ty
 151     )                                           `thenTc` \ (stmts', stmts_lie) ->
 152
 153
 154         -- Reinstate context for existential checks
 155     tcSetErrCtxt (stmtCtxt do_or_lc stmt)               $
 156     tcExtendGlobalTyVars (tyVarsOfType (m elt_ty))      $
 157     tcAddErrCtxtM (existentialPatCtxt pat_tvs pat_ids)  $
 158
 159     checkSigTyVars (bagToList pat_tvs)                  `thenTc` \ zonked_pat_tvs ->
 160
 161     tcSimplifyAndCheck
 162         (text ("the existential context of a data constructor"))
 163         (mkVarSet zonked_pat_tvs)
 164         lie_avail stmts_lie                     `thenTc` \ (final_lie, dict_binds) ->
 165
 166     returnTc (BindStmt pat' exp' src_loc :
 167                 LetStmt (MonoBind dict_binds [] Recursive) :
 168                   stmts',
 169               lie_req `plusLIE` final_lie)
 170
 171 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
 172      = tcBindsAndThen           -- No error context, but a binding group is
 173         combine                 -- rather a large thing for an error context anyway
 174         binds
 175         (tcStmts do_or_lc m stmts elt_ty)
 176      where
 177         combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
 178
 179
 180 isDoStmt DoStmt = True
 181 isDoStmt other  = False
 182
 183 stmtCtxt do_or_lc stmt
 184   = hang (ptext SLIT("In") <+> what <> colon)
 185          4 (ppr stmt)
 186   where
 187     what = case do_or_lc of
 188                 ListComp -> ptext SLIT("a list-comprehension qualifier")
 189                 DoStmt   -> ptext SLIT("a do statement:")
 190                 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
 191                 FunRhs f   -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
 192                 CaseAlt    -> thing <+> ptext SLIT("a case alternative")
 193                 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
 194     thing = case stmt of
 195                 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
 196                 GuardStmt _ _  -> ptext SLIT("a guard for")
 197                 ExprStmt _ _   -> ptext SLIT("the right-hand side of")
 198 \end{code}