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