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,
   8                    tcStmts, tcStmtsAndThen, tcGRHSs
   9        ) where
  10
  11 #include "HsVersions.h"
  12
  13 import {-# SOURCE #-}   TcExpr( tcMonoExpr )
  14
  15 import HsSyn            ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
  16                           MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
  17                           pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
  18                           mkMonoBind, nullMonoBinds, collectSigTysFromPats
  19                         )
  20 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedMatchContext )
  21 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
  22
  23 import TcMonad
  24 import TcMonoType       ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
  25 import Inst             ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
  26 import TcEnv            ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
  27 import TcPat            ( tcPat, tcMonoPatBndr )
  28 import TcMType          ( newTyVarTy, zonkTcType, zapToType )
  29 import TcType           ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
  30                           mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind  )
  31 import TcBinds          ( tcBindsAndThen )
  32 import TcUnify          ( subFunTy, checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
  33 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  34 import Name             ( Name )
  35 import TysWiredIn       ( boolTy )
  36 import Id               ( idType )
  37 import CoreFVs          ( idFreeTyVars )
  38 import BasicTypes       ( RecFlag(..) )
  39 import VarSet
  40 import Var              ( Id )
  41 import Bag
  42 import Util             ( isSingleton, lengthExceeds )
  43 import Outputable
  44
  45 import List             ( nub )
  46 \end{code}
  47
  48 %************************************************************************
  49 %*                                                                      *
  50 \subsection{tcMatchesFun, tcMatchesCase}
  51 %*                                                                      *
  52 %************************************************************************
  53
  54 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  55 @FunMonoBind@.  The second argument is the name of the function, which
  56 is used in error messages.  It checks that all the equations have the
  57 same number of arguments before using @tcMatches@ to do the work.
  58
  59 \begin{code}
  60 tcMatchesFun :: [(Name,Id)]     -- Bindings for the variables bound in this group
  61              -> Name
  62              -> TcType          -- Expected type
  63              -> [RenamedMatch]
  64              -> TcM ([TcMatch], LIE)
  65
  66 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
  67   =      -- Check that they all have the same no of arguments
  68          -- Set the location to that of the first equation, so that
  69          -- any inter-equation error messages get some vaguely
  70          -- sensible location.  Note: we have to do this odd
  71          -- ann-grabbing, because we don't always have annotations in
  72          -- hand when we call tcMatchesFun...
  73     tcAddSrcLoc (getMatchLoc first_match)        (
  74             checkTc (sameNoOfArgs matches)
  75                     (varyingArgsErr fun_name matches)
  76     )                                            `thenTc_`
  77
  78         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  79         -- because inconsistency between branches
  80         -- may show up as something wrong with the (non-existent) type signature
  81
  82         -- No need to zonk expected_ty, because subFunTy does that on the fly
  83     tcMatches xve (FunRhs fun_name) matches expected_ty
  84 \end{code}
  85
  86 @tcMatchesCase@ doesn't do the argument-count check because the
  87 parser guarantees that each equation has exactly one argument.
  88
  89 \begin{code}
  90 tcMatchesCase :: [RenamedMatch]         -- The case alternatives
  91               -> TcType                 -- Type of whole case expressions
  92               -> TcM (TcType,           -- Inferred type of the scrutinee
  93                         [TcMatch],      -- Translated alternatives
  94                         LIE)
  95
  96 tcMatchesCase matches expr_ty
  97   = newTyVarTy openTypeKind                                     `thenNF_Tc` \ scrut_ty ->
  98     tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty)     `thenTc` \ (matches', lie) ->
  99     returnTc (scrut_ty, matches', lie)
 100
 101 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
 102 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
 103 \end{code}
 104
 105
 106 \begin{code}
 107 tcMatches :: [(Name,Id)]
 108           -> RenamedMatchContext
 109           -> [RenamedMatch]
 110           -> TcType
 111           -> TcM ([TcMatch], LIE)
 112
 113 tcMatches xve ctxt matches expected_ty
 114   =     -- If there is more than one branch, and expected_ty is a 'hole',
 115         -- all branches must be types, not type schemes, otherwise the
 116         -- in which we check them would affect the result.
 117     (if lengthExceeds matches 1 then
 118         zapToType expected_ty
 119      else
 120         returnNF_Tc expected_ty)                        `thenNF_Tc` \ expected_ty' ->
 121
 122     mapAndUnzipTc (tc_match expected_ty') matches       `thenTc` \ (matches, lies) ->
 123     returnTc (matches, plusLIEs lies)
 124   where
 125     tc_match expected_ty match = tcMatch xve ctxt match expected_ty
 126 \end{code}
 127
 128
 129 %************************************************************************
 130 %*                                                                      *
 131 \subsection{tcMatch}
 132 %*                                                                      *
 133 %************************************************************************
 134
 135 \begin{code}
 136 tcMatch :: [(Name,Id)]
 137         -> RenamedMatchContext
 138         -> RenamedMatch
 139         -> TcType       -- Expected result-type of the Match.
 140                         -- Early unification with this guy gives better error messages
 141                         -- We regard the Match as having type
 142                         --      (ty1 -> ... -> tyn -> result_ty)
 143                         -- where there are n patterns.
 144         -> TcM (TcMatch, LIE)
 145
 146 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
 147   = tcAddSrcLoc (getMatchLoc match)             $       -- At one stage I removed this;
 148     tcAddErrCtxt (matchCtxt ctxt match)         $       -- I'm not sure why, so I put it back
 149     tcMatchPats pats expected_ty tc_grhss       `thenTc` \ (pats', grhss', lie, ex_binds) ->
 150     returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
 151
 152   where
 153     tc_grhss rhs_ty
 154         = tcExtendLocalValEnv2 xve1                     $
 155
 156                 -- Deal with the result signature
 157           case maybe_rhs_sig of
 158             Nothing ->  tcGRHSs ctxt grhss rhs_ty
 159
 160             Just sig ->  tcAddScopedTyVars [sig]        $
 161                                 -- Bring into scope the type variables in the signature
 162                          tcHsSigType ResSigCtxt sig     `thenTc` \ sig_ty ->
 163                          tcGRHSs ctxt grhss sig_ty      `thenTc` \ (grhss', lie1) ->
 164                          tcSubExp rhs_ty sig_ty         `thenTc` \ (co_fn, lie2)  ->
 165                          returnTc (lift_grhss co_fn rhs_ty grhss',
 166                                    lie1 `plusLIE` lie2)
 167
 168 -- lift_grhss pushes the coercion down to the right hand sides,
 169 -- because there is no convenient place to hang it otherwise.
 170 lift_grhss co_fn rhs_ty grhss
 171   | isIdCoercion co_fn = grhss
 172 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
 173   = GRHSs (map lift_grhs grhss) binds rhs_ty    -- Change the type, since we
 174   where
 175     lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
 176
 177     lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
 178     lift_stmt stmt             = stmt
 179
 180 -- glue_on just avoids stupid dross
 181 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 182 glue_on is_rec mbinds (GRHSs grhss binds ty)
 183   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 184
 185
 186 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
 187         -> TcType
 188         -> TcM (TcGRHSs, LIE)
 189
 190 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
 191   = tcBindsAndThen glue_on binds (tc_grhss grhss)
 192   where
 193     tc_grhss grhss
 194         = mapAndUnzipTc tc_grhs grhss       `thenTc` \ (grhss', lies) ->
 195           returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies)
 196
 197     tc_grhs (GRHS guarded locn)
 198         = tcAddSrcLoc locn                                      $
 199           tcStmts ctxt (\ty -> ty, expected_ty) guarded         `thenTc` \ (guarded', lie) ->
 200           returnTc (GRHS guarded' locn, lie)
 201 \end{code}
 202
 203
 204 %************************************************************************
 205 %*                                                                      *
 206 \subsection{tcMatchPats}
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 \begin{code}
 211 tcMatchPats
 212         :: [RenamedPat] -> TcType
 213         -> (TcType -> TcM (a, LIE))
 214         -> TcM ([TypecheckedPat], a, LIE, TcDictBinds)
 215 -- Typecheck the patterns, extend the environment to bind the variables,
 216 -- do the thing inside, use any existentially-bound dictionaries to
 217 -- discharge parts of the returning LIE, and deal with pattern type
 218 -- signatures
 219
 220 tcMatchPats pats expected_ty thing_inside
 221   =     -- STEP 1: Bring pattern-signature type variables into scope
 222     tcAddScopedTyVars (collectSigTysFromPats pats)      (
 223
 224         -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
 225         --         then do the thing inside
 226         tc_match_pats pats expected_ty thing_inside
 227
 228     ) `thenTc` \ (pats', lie_req, ex_tvs, ex_ids, ex_lie, result) ->
 229
 230         -- STEP 4: Check for existentially bound type variables
 231         -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
 232         -- complains that 'a' is captured by the inscope 'a'!  (Test (d) in checkSigTyVars.)
 233         --
 234         -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
 235         -- might need (via lie_req2) something made available from an 'outer'
 236         -- pattern.  But it's inconvenient to deal with, and I can't find an example
 237     tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty      `thenTc` \ (lie_req', ex_binds) ->
 238         -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
 239         -- For example, we must reject this program:
 240         --      data C = forall a. C (a -> Int)
 241         --      f (C g) x = g x
 242         -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
 243
 244     returnTc (pats', result, lie_req', ex_binds)
 245
 246 tc_match_pats [] expected_ty thing_inside
 247   = thing_inside expected_ty    `thenTc` \ (answer, lie) ->
 248     returnTc ([], lie, emptyBag, [], emptyLIE, answer)
 249
 250 tc_match_pats (pat:pats) expected_ty thing_inside
 251   = subFunTy expected_ty                $ \ arg_ty rest_ty ->
 252         -- This is the unique place we call subFunTy
 253         -- The point is that if expected_y is a "hole", we want
 254         -- to make arg_ty and rest_ty as "holes" too.
 255     tcPat tcMonoPatBndr pat arg_ty      `thenTc` \ (pat', lie_req, ex_tvs, pat_bndrs, ex_lie) ->
 256     let
 257         xve    = bagToList pat_bndrs
 258         ex_ids = [id | (_, id) <- xve]
 259                 -- ex_ids is all the pattern-bound Ids, a superset
 260                 -- of the existential Ids used in checkExistentialPat
 261     in
 262     tcExtendLocalValEnv2 xve                    $
 263     tc_match_pats pats rest_ty thing_inside     `thenTc` \ (pats', lie_reqs, exs_tvs, exs_ids, exs_lie, answer) ->
 264     returnTc (  pat':pats',
 265                 lie_req `plusLIE` lie_reqs,
 266                 ex_tvs `unionBags` exs_tvs,
 267                 ex_ids ++ exs_ids,
 268                 ex_lie `plusLIE` exs_lie,
 269                 answer
 270     )
 271
 272
 273 tcCheckExistentialPat :: Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
 274                       -> [TcId]         -- Ids bound by this pattern; used
 275                                         --   (a) by bindsInstsOfLocalFuns
 276                                         --   (b) to generate helpful error messages
 277                       -> LIE            --   and context
 278                       -> LIE            -- Required context
 279                       -> TcType         --   and type of the Match; vars in here must not escape
 280                       -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
 281 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
 282   | isEmptyBag ex_tvs && all not_overloaded ex_ids
 283         -- Short cut for case when there are no existentials
 284         -- and no polymorphic overloaded variables
 285         --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
 286         --       f op x = ....
 287         --  Here we must discharge op Methods
 288   = ASSERT( isEmptyLIE ex_lie )
 289     returnTc (lie_req, EmptyMonoBinds)
 290
 291   | otherwise
 292   = tcAddErrCtxtM (sigPatCtxt tv_list ex_ids match_ty)          $
 293
 294         -- In case there are any polymorpic, overloaded binders in the pattern
 295         -- (which can happen in the case of rank-2 type signatures, or data constructors
 296         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 297     bindInstsOfLocalFuns lie_req ex_ids                         `thenTc` \ (lie1, inst_binds) ->
 298
 299         -- Deal with overloaded functions bound by the pattern
 300     tcSimplifyCheck doc tv_list (lieToList ex_lie) lie1 `thenTc` \ (lie2, dict_binds) ->
 301     checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list   `thenTc_`
 302
 303     returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
 304   where
 305     doc     = text ("the existential context of a data constructor")
 306     tv_list = bagToList ex_tvs
 307     not_overloaded id = not (isOverloadedTy (idType id))
 308 \end{code}
 309
 310
 311 %************************************************************************
 312 %*                                                                      *
 313 \subsection{tcStmts}
 314 %*                                                                      *
 315 %************************************************************************
 316
 317 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 318
 319         [ (g x, h x) | ... ; let g v = ...
 320                      | ... ; let h v = ... ]
 321
 322 It's possible that g,h are overloaded, so we need to feed the LIE from the
 323 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 324 Similarly if we had an existential pattern match:
 325
 326         data T = forall a. Show a => C a
 327
 328         [ (show x, show y) | ... ; C x <- ...
 329                            | ... ; C y <- ... ]
 330
 331 Then we need the LIE from (show x, show y) to be simplified against
 332 the bindings for x and y.
 333
 334 It's difficult to do this in parallel, so we rely on the renamer to
 335 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 336 So the binders of the first parallel group will be in scope in the second
 337 group.  But that's fine; there's no shadowing to worry about.
 338
 339 \begin{code}
 340 tcStmts do_or_lc m_ty stmts
 341   = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
 342
 343 tcStmtsAndThen
 344         :: (TcStmt -> thing -> thing)   -- Combiner
 345         -> RenamedMatchContext
 346         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 347                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 348         -> [RenamedStmt]
 349         -> TcM (thing, LIE)
 350         -> TcM (thing, LIE)
 351
 352         -- Base case
 353 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 354   = do_next
 355
 356 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
 357   = tcStmtAndThen combine do_or_lc m_ty stmt
 358         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 359
 360         -- LetStmt
 361 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
 362   = tcBindsAndThen              -- No error context, but a binding group is
 363         (glue_binds combine)    -- rather a large thing for an error context anyway
 364         binds
 365         thing_inside
 366
 367 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
 368   = tcAddSrcLoc src_loc                                 $
 369     tcAddErrCtxt (stmtCtxt do_or_lc stmt)               $
 370     newTyVarTy liftedTypeKind                           `thenNF_Tc` \ pat_ty ->
 371     tcMonoExpr exp (m pat_ty)                           `thenTc` \ (exp', exp_lie) ->
 372     tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty))       (\ _ ->
 373         tcPopErrCtxt thing_inside
 374     )                                                   `thenTc` \ ([pat'], thing, lie, dict_binds) ->
 375     returnTc (combine (BindStmt pat' exp' src_loc)
 376                       (glue_binds combine Recursive dict_binds thing),
 377               lie `plusLIE` exp_lie)
 378
 379
 380         -- ParStmt
 381 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
 382   = loop bndr_stmts_s           `thenTc` \ ((pairs', thing), lie) ->
 383     returnTc (combine (ParStmtOut pairs') thing, lie)
 384   where
 385     loop []
 386       = thing_inside                            `thenTc` \ (thing, stmts_lie) ->
 387         returnTc (([], thing), stmts_lie)
 388
 389     loop ((bndrs,stmts) : pairs)
 390       = tcStmtsAndThen
 391                 combine_par (DoCtxt ListComp) m_ty stmts
 392                         -- Notice we pass on m_ty; the result type is used only
 393                         -- to get escaping type variables for checkExistentialPat
 394                 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
 395                  loop pairs             `thenTc` \ ((pairs', thing), lie) ->
 396                  returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
 397
 398         returnTc ( ((bndrs',stmts') : pairs', thing), lie)
 399
 400     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 401
 402         -- ExprStmt
 403 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
 404   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 405         if isDoExpr do_or_lc then
 406                 newTyVarTy openTypeKind         `thenNF_Tc` \ any_ty ->
 407                 tcMonoExpr exp (m any_ty)       `thenNF_Tc` \ (exp', lie) ->
 408                 returnTc (ExprStmt exp' any_ty locn, lie)
 409         else
 410                 tcMonoExpr exp boolTy           `thenNF_Tc` \ (exp', lie) ->
 411                 returnTc (ExprStmt exp' boolTy locn, lie)
 412     )                                           `thenTc` \ (stmt', stmt_lie) ->
 413
 414     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 415
 416     returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
 417
 418
 419         -- Result statements
 420 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
 421   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 422         if isDoExpr do_or_lc then
 423                 tcMonoExpr exp (m res_elt_ty)
 424         else
 425                 tcMonoExpr exp res_elt_ty
 426     )                                           `thenTc` \ (exp', stmt_lie) ->
 427
 428     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 429
 430     returnTc (combine (ResultStmt exp' locn) thing,
 431               stmt_lie `plusLIE` stmts_lie)
 432
 433
 434 ------------------------------
 435 glue_binds combine is_rec binds thing
 436   | nullMonoBinds binds = thing
 437   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 438 \end{code}
 439
 440
 441 %************************************************************************
 442 %*                                                                      *
 443 \subsection{Errors and contexts}
 444 %*                                                                      *
 445 %************************************************************************
 446
 447 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 448 number of args are used in each equation.
 449
 450 \begin{code}
 451 sameNoOfArgs :: [RenamedMatch] -> Bool
 452 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
 453   where
 454     args_in_match :: RenamedMatch -> Int
 455     args_in_match (Match pats _ _) = length pats
 456 \end{code}
 457
 458 \begin{code}
 459 varyingArgsErr name matches
 460   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 461
 462 matchCtxt ctxt  match  = hang (pprMatchContext ctxt     <> colon) 4 (pprMatch ctxt match)
 463 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 464
 465 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
 466   = zonkTcType match_ty         `thenNF_Tc` \ match_ty' ->
 467     let
 468         (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 469         (env2, tidy_mty) = tidyOpenType  env1     match_ty'
 470     in
 471     returnNF_Tc (env1,
 472                  sep [ptext SLIT("When checking an existential match that binds"),
 473                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 474                       ptext SLIT("and whose type is") <+> ppr tidy_mty])
 475   where
 476     show_ids = filter is_interesting bound_ids
 477     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 478
 479     ppr_id id ty     = ppr id <+> dcolon <+> ppr ty
 480         -- Don't zonk the types so we get the separate, un-unified versions
 481 \end{code}