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, collectSigTysFromPats
  17                         )
  18 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt )
  19 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt )
  20
  21 import TcMonad
  22 import TcMonoType       ( kcHsSigType, kcTyVarScope, checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
  23 import Inst             ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
  24 import TcEnv            ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars, tcGetGlobalTyVars )
  25 import TcPat            ( tcPat, tcPatBndr_NoSigs, polyPatSig )
  26 import TcType           ( TcType, newTyVarTy )
  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, openTypeKind )
  35 import VarSet
  36 import Var              ( Id )
  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 openTypeKind                                     `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 tvs 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 openTypeKind         `thenNF_Tc` \ tyvar_ty ->
 142
 143         -- Extend the tyvar env and check the match itself
 144         kcTyVarScope sig_tvs (mapTc_ kcHsSigType sig_tys)       `thenTc` \ 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 emptyVarSet
 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     sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
 162               ++ collectSigTysFromPats pats
 163
 164     tc_match expected_ty        -- Any sig tyvars are in scope by now
 165       = -- STEP 1: Typecheck the patterns
 166         tcMatchPats pats expected_ty    `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
 167         let
 168           xve2       = bagToList pat_bndrs
 169           pat_ids    = map snd xve2
 170           ex_tv_list = bagToList ex_tvs
 171         in
 172
 173         -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
 174         -- If it is it'll mess up the unifier when checking the RHS
 175         checkTc (isTauTy rhs_ty) lurkingRank2SigErr             `thenTc_`
 176
 177         -- STEP 3: Unify with the rhs type signature if any
 178         (case maybe_rhs_sig of
 179             Nothing  -> returnTc ()
 180             Just sig -> tcHsSigType sig         `thenTc` \ sig_ty ->
 181
 182                         -- Check that the signature isn't a polymorphic one, which
 183                         -- we don't permit (at present, anyway)
 184                         checkTc (isTauTy sig_ty) (polyPatSig sig_ty)    `thenTc_`
 185                         unifyTauTy rhs_ty sig_ty
 186         )                                               `thenTc_`
 187
 188         -- STEP 4: Typecheck the guarded RHSs and the associated where clause
 189         tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
 190             tcGRHSs grhss rhs_ty ctxt
 191         ))                                      `thenTc` \ (grhss', lie_req2) ->
 192
 193         -- STEP 5: Check for existentially bound type variables
 194         tcExtendGlobalTyVars (tyVarsOfType rhs_ty)      (
 195             tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids)       $
 196             checkSigTyVars ex_tv_list emptyVarSet               `thenTc` \ zonked_ex_tvs ->
 197             tcSimplifyAndCheck
 198                 (text ("the existential context of a data constructor"))
 199                 (mkVarSet zonked_ex_tvs)
 200                 lie_avail (lie_req1 `plusLIE` lie_req2)
 201         )                                                       `thenTc` \ (lie_req', ex_binds) ->
 202
 203         -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
 204         -- (which can happen in the case of rank-2 type signatures, or data constructors
 205         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 206         bindInstsOfLocalFuns lie_req' pat_ids           `thenTc` \ (lie_req'', inst_binds) ->
 207
 208         -- Phew!  All done.
 209         let
 210             grhss'' = glue_on Recursive ex_binds $
 211                       glue_on Recursive inst_binds grhss'
 212         in
 213         returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
 214
 215         -- glue_on just avoids stupid dross
 216 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 217 glue_on is_rec mbinds (GRHSs grhss binds ty)
 218   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 219
 220 tcGRHSs :: RenamedGRHSs
 221         -> TcType -> StmtCtxt
 222         -> TcM s (TcGRHSs, LIE)
 223
 224 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
 225   = tcBindsAndThen glue_on binds (tc_grhss grhss)
 226   where
 227     tc_grhss grhss
 228         = mapAndUnzipTc tc_grhs grhss           `thenTc` \ (grhss', lies) ->
 229           returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
 230
 231     tc_grhs (GRHS guarded locn)
 232         = tcAddSrcLoc locn                              $
 233           tcStmts ctxt (\ty -> ty) guarded expected_ty  `thenTc` \ (guarded', lie) ->
 234           returnTc (GRHS guarded' locn, lie)
 235 \end{code}
 236
 237
 238 %************************************************************************
 239 %*                                                                      *
 240 \subsection{tcMatchPats}
 241 %*                                                                      *
 242 %************************************************************************
 243
 244 \begin{code}
 245 tcMatchPats [] expected_ty
 246   = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
 247
 248 tcMatchPats (pat:pats) expected_ty
 249   = unifyFunTy expected_ty              `thenTc` \ (arg_ty, rest_ty) ->
 250     tcPat tcPatBndr_NoSigs pat arg_ty   `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
 251     tcMatchPats pats rest_ty            `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
 252     returnTc (  rhs_ty,
 253                 pat':pats',
 254                 lie_req `plusLIE` lie_reqs,
 255                 pat_tvs `unionBags` pats_tvs,
 256                 pat_ids `unionBags` pats_ids,
 257                 lie_avail `plusLIE` lie_avails
 258     )
 259 \end{code}
 260
 261
 262 %************************************************************************
 263 %*                                                                      *
 264 \subsection{tcStmts}
 265 %*                                                                      *
 266 %************************************************************************
 267
 268
 269 \begin{code}
 270 tcStmts :: StmtCtxt
 271         -> (TcType -> TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 272         -> [RenamedStmt]
 273         -> TcType                       -- elt_ty, where type of the comprehension is (m elt_ty)
 274         -> TcM s ([TcStmt], LIE)
 275
 276 tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
 277   = ASSERT( null stmts )
 278     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 279     tcExpr exp elt_ty                           `thenTc`    \ (exp', exp_lie) ->
 280     returnTc ([ReturnStmt exp'], exp_lie)
 281
 282         -- ExprStmt at the end
 283 tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
 284   = tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 285     tcExpr exp (m elt_ty)                       `thenTc`    \ (exp', exp_lie) ->
 286     returnTc ([ExprStmt exp' src_loc], exp_lie)
 287
 288         -- ExprStmt not at the end
 289 tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
 290   = ASSERT( isDoStmt do_or_lc )
 291     tcAddSrcLoc src_loc                 (
 292         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 293             -- exp has type (m tau) for some tau (doesn't matter what)
 294         newTyVarTy openTypeKind         `thenNF_Tc` \ any_ty ->
 295         tcExpr exp (m any_ty)
 296     )                                   `thenTc` \ (exp', exp_lie) ->
 297     tcStmts do_or_lc m stmts elt_ty     `thenTc` \ (stmts', stmts_lie) ->
 298     returnTc (ExprStmt exp' src_loc : stmts',
 299               exp_lie `plusLIE` stmts_lie)
 300
 301 tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
 302   = ASSERT( not (isDoStmt do_or_lc) )
 303     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 304         tcAddSrcLoc src_loc             $
 305         tcExpr exp boolTy
 306     )                                   `thenTc` \ (exp', exp_lie) ->
 307     tcStmts do_or_lc m stmts elt_ty     `thenTc` \ (stmts', stmts_lie) ->
 308     returnTc (GuardStmt exp' src_loc : stmts',
 309               exp_lie `plusLIE` stmts_lie)
 310
 311 tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
 312   = tcAddSrcLoc src_loc         (
 313         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 314         newTyVarTy boxedTypeKind                `thenNF_Tc` \ pat_ty ->
 315         tcPat tcPatBndr_NoSigs pat pat_ty       `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
 316         tcExpr exp (m pat_ty)                   `thenTc` \ (exp', exp_lie) ->
 317         returnTc (pat', exp',
 318                   pat_lie `plusLIE` exp_lie,
 319                   pat_tvs, pat_ids, avail)
 320     )                                   `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
 321     let
 322         new_val_env = bagToList pat_bndrs
 323         pat_ids     = map snd new_val_env
 324         pat_tv_list = bagToList pat_tvs
 325     in
 326
 327         -- Do the rest; we don't need to add the pat_tvs to the envt
 328         -- because they all appear in the pat_ids's types
 329     tcExtendLocalValEnv new_val_env (
 330        tcStmts do_or_lc m stmts elt_ty
 331     )                                           `thenTc` \ (stmts', stmts_lie) ->
 332
 333
 334         -- Reinstate context for existential checks
 335     tcSetErrCtxt (stmtCtxt do_or_lc stmt)               $
 336     tcExtendGlobalTyVars (tyVarsOfType (m elt_ty))      $
 337     tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids)      $
 338
 339     checkSigTyVars pat_tv_list emptyVarSet              `thenTc` \ zonked_pat_tvs ->
 340
 341     tcSimplifyAndCheck
 342         (text ("the existential context of a data constructor"))
 343         (mkVarSet zonked_pat_tvs)
 344         lie_avail stmts_lie                     `thenTc` \ (final_lie, dict_binds) ->
 345
 346     returnTc (BindStmt pat' exp' src_loc :
 347                 consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
 348               lie_req `plusLIE` final_lie)
 349
 350 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
 351      = tcBindsAndThen           -- No error context, but a binding group is
 352         combine                 -- rather a large thing for an error context anyway
 353         binds
 354         (tcStmts do_or_lc m stmts elt_ty)
 355      where
 356         combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
 357
 358
 359 isDoStmt DoStmt = True
 360 isDoStmt other  = False
 361 \end{code}
 362
 363
 364 %************************************************************************
 365 %*                                                                      *
 366 \subsection{Errors and contexts}
 367 %*                                                                      *
 368 %************************************************************************
 369
 370 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 371 number of args are used in each equation.
 372
 373 \begin{code}
 374 sameNoOfArgs :: [RenamedMatch] -> Bool
 375 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
 376   where
 377     args_in_match :: RenamedMatch -> Int
 378     args_in_match (Match _ pats _ _) = length pats
 379 \end{code}
 380
 381 \begin{code}
 382 matchCtxt CaseAlt match
 383   = hang (ptext SLIT("In a case alternative:"))
 384          4 (pprMatch (True,empty) {-is_case-} match)
 385
 386 matchCtxt (FunRhs fun) match
 387   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
 388          4 (pprMatch (False, ppr_fun) {-not case-} match)
 389   where
 390     ppr_fun = ppr fun
 391
 392 matchCtxt LambdaBody match
 393   = hang (ptext SLIT("In the lambda expression"))
 394          4 (pprMatch (True, empty) match)
 395
 396 varyingArgsErr name matches
 397   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 398
 399 lurkingRank2SigErr
 400   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 401
 402 stmtCtxt do_or_lc stmt
 403   = hang (ptext SLIT("In") <+> what <> colon)
 404          4 (ppr stmt)
 405   where
 406     what = case do_or_lc of
 407                 ListComp -> ptext SLIT("a list-comprehension qualifier")
 408                 DoStmt   -> ptext SLIT("a do statement")
 409                 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
 410                 FunRhs f   -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
 411                 CaseAlt    -> thing <+> ptext SLIT("a case alternative")
 412                 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
 413     thing = case stmt of
 414                 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
 415                 GuardStmt _ _  -> ptext SLIT("a guard for")
 416                 ExprStmt _ _   -> ptext SLIT("the right-hand side of")
 417 \end{code}