ghc/compiler/typecheck/TcMatches.lhs

   1 \%
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcMatches]{Typecheck some @Matches@}
   5
   6 \begin{code}
   7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, tcStmts, tcGRHSs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-}   TcExpr( tcExpr )
  12
  13 import HsSyn            ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
  14                           MonoBinds(..), StmtCtxt(..), Stmt(..),
  15                           pprMatch, getMatchLoc
  16                         )
  17 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt )
  18 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt )
  19
  20 import TcMonad
  21 import TcMonoType       ( checkSigTyVars, tcHsTyVar, tcHsType, noSigs, sigPatCtxt )
  22 import Inst             ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
  23 import TcEnv            ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
  24 import TcPat            ( tcPat, polyPatSig )
  25 import TcType           ( TcType, newTyVarTy, newTyVarTy_OpenKind )
  26 import TcBinds          ( tcBindsAndThen )
  27 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  28 import TcUnify          ( unifyFunTy, unifyTauTy )
  29 import Name             ( Name )
  30 import TysWiredIn       ( boolTy )
  31
  32 import BasicTypes       ( RecFlag(..) )
  33 import Type             ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind )
  34 import VarSet
  35 import Var              ( Id )
  36 import Util
  37 import Bag
  38 import Outputable
  39 import List             ( nub )
  40 \end{code}
  41
  42 %************************************************************************
  43 %*                                                                      *
  44 \subsection{tcMatchesFun, tcMatchesCase}
  45 %*                                                                      *
  46 %************************************************************************
  47
  48 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  49 @FunMonoBind@.  The second argument is the name of the function, which
  50 is used in error messages.  It checks that all the equations have the
  51 same number of arguments before using @tcMatches@ to do the work.
  52
  53 \begin{code}
  54 tcMatchesFun :: [(Name,Id)]     -- Bindings for the variables bound in this group
  55              -> Name
  56              -> TcType          -- Expected type
  57              -> [RenamedMatch]
  58              -> TcM s ([TcMatch], LIE)
  59
  60 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
  61   =      -- Check that they all have the same no of arguments
  62          -- Set the location to that of the first equation, so that
  63          -- any inter-equation error messages get some vaguely
  64          -- sensible location.  Note: we have to do this odd
  65          -- ann-grabbing, because we don't always have annotations in
  66          -- hand when we call tcMatchesFun...
  67     tcAddSrcLoc (getMatchLoc first_match)        (
  68             checkTc (sameNoOfArgs matches)
  69                     (varyingArgsErr fun_name matches)
  70     )                                            `thenTc_`
  71
  72         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  73         -- because inconsistency between branches
  74         -- may show up as something wrong with the (non-existent) type signature
  75
  76         -- No need to zonk expected_ty, because unifyFunTy does that on the fly
  77     tcMatches xve matches expected_ty (FunRhs fun_name)
  78 \end{code}
  79
  80 @tcMatchesCase@ doesn't do the argument-count check because the
  81 parser guarantees that each equation has exactly one argument.
  82
  83 \begin{code}
  84 tcMatchesCase :: [RenamedMatch]         -- The case alternatives
  85               -> TcType                 -- Type of whole case expressions
  86               -> TcM s (TcType,         -- Inferred type of the scrutinee
  87                         [TcMatch],      -- Translated alternatives
  88                         LIE)
  89
  90 tcMatchesCase matches expr_ty
  91   = newTyVarTy_OpenKind                                         `thenNF_Tc` \ scrut_ty ->
  92     tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt     `thenTc` \ (matches', lie) ->
  93     returnTc (scrut_ty, matches', lie)
  94
  95 tcMatchLambda :: RenamedMatch -> TcType -> TcM s (TcMatch, LIE)
  96 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
  97 \end{code}
  98
  99
 100 \begin{code}
 101 tcMatches :: [(Name,Id)]
 102           -> [RenamedMatch]
 103           -> TcType
 104           -> StmtCtxt
 105           -> TcM s ([TcMatch], LIE)
 106
 107 tcMatches xve matches expected_ty fun_or_case
 108   = mapAndUnzipTc tc_match matches      `thenTc` \ (matches, lies) ->
 109     returnTc (matches, plusLIEs lies)
 110   where
 111     tc_match match = tcMatch xve match expected_ty fun_or_case
 112 \end{code}
 113
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{tcMatch}
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 tcMatch :: [(Name,Id)]
 123         -> RenamedMatch
 124         -> TcType               -- Expected result-type of the Match.
 125                                 -- Early unification with this guy gives better error messages
 126         -> StmtCtxt
 127         -> TcM s (TcMatch, LIE)
 128
 129 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
 130   = tcAddSrcLoc (getMatchLoc match)             $
 131     tcAddErrCtxt (matchCtxt ctxt match)         $
 132
 133     if null sig_tvs then        -- The common case
 134         tc_match expected_ty    `thenTc` \ (_, match_and_lie) ->
 135         returnTc match_and_lie
 136
 137     else
 138         -- If there are sig tve we must be careful *not* to use
 139         -- expected_ty right away, else we'll unify with tyvars free
 140         -- in the envt.  So invent a fresh tyvar and use that instead
 141         newTyVarTy_OpenKind             `thenNF_Tc` \ tyvar_ty ->
 142
 143         -- Extend the tyvar env and check the match itself
 144         mapNF_Tc tcHsTyVar sig_tvs      `thenNF_Tc` \ sig_tyvars ->
 145         tcExtendTyVarEnv sig_tyvars (
 146                 tc_match tyvar_ty
 147         )                               `thenTc` \ (pat_ids, match_and_lie) ->
 148
 149         -- Check that the scoped type variables from the patterns
 150         -- have not been constrained
 151         tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids)           (
 152                 checkSigTyVars sig_tyvars
 153         )                                                       `thenTc_`
 154
 155         -- *Now* we're free to unify with expected_ty
 156         unifyTauTy expected_ty tyvar_ty `thenTc_`
 157
 158         returnTc match_and_lie
 159
 160   where
 161     tc_match expexted_ty        -- Any sig tyvars are in scope by now
 162       = -- STEP 1: Typecheck the patterns
 163         tcMatchPats pats expected_ty    `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
 164         let
 165           xve2       = bagToList pat_bndrs
 166           pat_ids    = map snd xve2
 167           ex_tv_list = bagToList ex_tvs
 168         in
 169
 170         -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
 171         -- If it is it'll mess up the unifier when checking the RHS
 172         checkTc (isTauTy rhs_ty) lurkingRank2SigErr             `thenTc_`
 173
 174         -- STEP 3: Unify with the rhs type signature if any
 175         (case maybe_rhs_sig of
 176             Nothing  -> returnTc ()
 177             Just sig -> tcHsType sig    `thenTc` \ sig_ty ->
 178
 179                         -- Check that the signature isn't a polymorphic one, which
 180                         -- we don't permit (at present, anyway)
 181                         checkTc (isTauTy sig_ty) (polyPatSig sig_ty)    `thenTc_`
 182                         unifyTauTy rhs_ty sig_ty
 183         )                                               `thenTc_`
 184
 185         -- STEP 4: Typecheck the guarded RHSs and the associated where clause
 186         tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
 187             tcGRHSs grhss rhs_ty ctxt
 188         ))                                      `thenTc` \ (grhss', lie_req2) ->
 189
 190         -- STEP 5: Check for existentially bound type variables
 191         tcExtendGlobalTyVars (tyVarsOfType rhs_ty)      (
 192             tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids)       $
 193             checkSigTyVars ex_tv_list                           `thenTc` \ zonked_ex_tvs ->
 194             tcSimplifyAndCheck
 195                 (text ("the existential context of a data constructor"))
 196                 (mkVarSet zonked_ex_tvs)
 197                 lie_avail (lie_req1 `plusLIE` lie_req2)
 198         )                                                       `thenTc` \ (lie_req', ex_binds) ->
 199
 200         -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
 201         -- (which can happen in the case of rank-2 type signatures, or data constructors
 202         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 203         bindInstsOfLocalFuns lie_req' pat_ids           `thenTc` \ (lie_req'', inst_binds) ->
 204
 205         -- Phew!  All done.
 206         let
 207             grhss'' = glue_on Recursive ex_binds $
 208                       glue_on Recursive inst_binds grhss'
 209         in
 210         returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
 211
 212         -- glue_on just avoids stupid dross
 213 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 214 glue_on is_rec mbinds (GRHSs grhss binds ty)
 215   = GRHSs grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) ty
 216
 217 tcGRHSs :: RenamedGRHSs
 218         -> TcType -> StmtCtxt
 219         -> TcM s (TcGRHSs, LIE)
 220
 221 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
 222   = tcBindsAndThen glue_on binds (tc_grhss grhss)
 223   where
 224     tc_grhss grhss
 225         = mapAndUnzipTc tc_grhs grhss           `thenTc` \ (grhss', lies) ->
 226           returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
 227
 228     tc_grhs (GRHS guarded locn)
 229         = tcAddSrcLoc locn                              $
 230           tcStmts ctxt (\ty -> ty) guarded expected_ty  `thenTc` \ (guarded', lie) ->
 231           returnTc (GRHS guarded' locn, lie)
 232 \end{code}
 233
 234
 235 %************************************************************************
 236 %*                                                                      *
 237 \subsection{tcMatchPats}
 238 %*                                                                      *
 239 %************************************************************************
 240
 241 \begin{code}
 242 tcMatchPats [] expected_ty
 243   = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
 244
 245 tcMatchPats (pat:pats) expected_ty
 246   = unifyFunTy expected_ty      `thenTc` \ (arg_ty, rest_ty) ->
 247     tcPat noSigs pat arg_ty     `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
 248     tcMatchPats pats rest_ty    `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
 249     returnTc (  rhs_ty,
 250                 pat':pats',
 251                 lie_req `plusLIE` lie_reqs,
 252                 pat_tvs `unionBags` pats_tvs,
 253                 pat_ids `unionBags` pats_ids,
 254                 lie_avail `plusLIE` lie_avails
 255     )
 256 \end{code}
 257
 258
 259 %************************************************************************
 260 %*                                                                      *
 261 \subsection{tcStmts}
 262 %*                                                                      *
 263 %************************************************************************
 264
 265
 266 \begin{code}
 267 tcStmts :: StmtCtxt
 268         -> (TcType -> TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 269         -> [RenamedStmt]
 270         -> TcType                       -- elt_ty, where type of the comprehension is (m elt_ty)
 271         -> TcM s ([TcStmt], LIE)
 272
 273 tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
 274   = ASSERT( null stmts )
 275     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 276     tcExpr exp elt_ty                           `thenTc`    \ (exp', exp_lie) ->
 277     returnTc ([ReturnStmt exp'], exp_lie)
 278
 279         -- ExprStmt at the end
 280 tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
 281   = tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 282     tcExpr exp (m elt_ty)                       `thenTc`    \ (exp', exp_lie) ->
 283     returnTc ([ExprStmt exp' src_loc], exp_lie)
 284
 285         -- ExprStmt not at the end
 286 tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
 287   = ASSERT( isDoStmt do_or_lc )
 288     tcAddSrcLoc src_loc                 (
 289         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 290             -- exp has type (m tau) for some tau (doesn't matter what)
 291         newTyVarTy_OpenKind                     `thenNF_Tc` \ any_ty ->
 292         tcExpr exp (m any_ty)
 293     )                                   `thenTc` \ (exp', exp_lie) ->
 294     tcStmts do_or_lc m stmts elt_ty     `thenTc` \ (stmts', stmts_lie) ->
 295     returnTc (ExprStmt exp' src_loc : stmts',
 296               exp_lie `plusLIE` stmts_lie)
 297
 298 tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
 299   = ASSERT( not (isDoStmt do_or_lc) )
 300     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 301         tcAddSrcLoc src_loc             $
 302         tcExpr exp boolTy
 303     )                                   `thenTc` \ (exp', exp_lie) ->
 304     tcStmts do_or_lc m stmts elt_ty     `thenTc` \ (stmts', stmts_lie) ->
 305     returnTc (GuardStmt exp' src_loc : stmts',
 306               exp_lie `plusLIE` stmts_lie)
 307
 308 tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
 309   = tcAddSrcLoc src_loc         (
 310         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 311         newTyVarTy boxedTypeKind                `thenNF_Tc` \ pat_ty ->
 312         tcPat noSigs pat pat_ty                 `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
 313         tcExpr exp (m pat_ty)                   `thenTc` \ (exp', exp_lie) ->
 314         returnTc (pat', exp',
 315                   pat_lie `plusLIE` exp_lie,
 316                   pat_tvs, pat_ids, avail)
 317     )                                   `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
 318     let
 319         new_val_env = bagToList pat_bndrs
 320         pat_ids     = map snd new_val_env
 321         pat_tv_list = bagToList pat_tvs
 322     in
 323
 324         -- Do the rest; we don't need to add the pat_tvs to the envt
 325         -- because they all appear in the pat_ids's types
 326     tcExtendLocalValEnv new_val_env (
 327        tcStmts do_or_lc m stmts elt_ty
 328     )                                           `thenTc` \ (stmts', stmts_lie) ->
 329
 330
 331         -- Reinstate context for existential checks
 332     tcSetErrCtxt (stmtCtxt do_or_lc stmt)               $
 333     tcExtendGlobalTyVars (tyVarsOfType (m elt_ty))      $
 334     tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids)      $
 335
 336     checkSigTyVars pat_tv_list                          `thenTc` \ zonked_pat_tvs ->
 337
 338     tcSimplifyAndCheck
 339         (text ("the existential context of a data constructor"))
 340         (mkVarSet zonked_pat_tvs)
 341         lie_avail stmts_lie                     `thenTc` \ (final_lie, dict_binds) ->
 342
 343     returnTc (BindStmt pat' exp' src_loc :
 344                 LetStmt (MonoBind dict_binds [] Recursive) :
 345                   stmts',
 346               lie_req `plusLIE` final_lie)
 347
 348 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
 349      = tcBindsAndThen           -- No error context, but a binding group is
 350         combine                 -- rather a large thing for an error context anyway
 351         binds
 352         (tcStmts do_or_lc m stmts elt_ty)
 353      where
 354         combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
 355
 356
 357 isDoStmt DoStmt = True
 358 isDoStmt other  = False
 359 \end{code}
 360
 361
 362 %************************************************************************
 363 %*                                                                      *
 364 \subsection{Errors and contexts}
 365 %*                                                                      *
 366 %************************************************************************
 367
 368 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 369 number of args are used in each equation.
 370
 371 \begin{code}
 372 sameNoOfArgs :: [RenamedMatch] -> Bool
 373 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
 374   where
 375     args_in_match :: RenamedMatch -> Int
 376     args_in_match (Match _ pats _ _) = length pats
 377 \end{code}
 378
 379 \begin{code}
 380 matchCtxt CaseAlt match
 381   = hang (ptext SLIT("In a \"case\" branch:"))
 382          4 (pprMatch (True,empty) {-is_case-} match)
 383
 384 matchCtxt (FunRhs fun) match
 385   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
 386          4 (pprMatch (False, ppr_fun) {-not case-} match)
 387   where
 388     ppr_fun = ppr fun
 389
 390 matchCtxt LambdaBody match
 391   = hang (ptext SLIT("In the lambda expression"))
 392          4 (pprMatch (True, empty) match)
 393
 394 varyingArgsErr name matches
 395   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 396
 397 lurkingRank2SigErr
 398   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 399
 400 stmtCtxt do_or_lc stmt
 401   = hang (ptext SLIT("In") <+> what <> colon)
 402          4 (ppr stmt)
 403   where
 404     what = case do_or_lc of
 405                 ListComp -> ptext SLIT("a list-comprehension qualifier")
 406                 DoStmt   -> ptext SLIT("a do statement:")
 407                 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
 408                 FunRhs f   -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
 409                 CaseAlt    -> thing <+> ptext SLIT("a case alternative")
 410                 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
 411     thing = case stmt of
 412                 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
 413                 GuardStmt _ _  -> ptext SLIT("a guard for")
 414                 ExprStmt _ _   -> ptext SLIT("the right-hand side of")
 415 \end{code}