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, notNull )
  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 ("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   = ASSERT( notNull stmts )
 342     tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
 343
 344 tcStmtsAndThen
 345         :: (TcStmt -> thing -> thing)   -- Combiner
 346         -> RenamedMatchContext
 347         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 348                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 349         -> [RenamedStmt]
 350         -> TcM (thing, LIE)
 351         -> TcM (thing, LIE)
 352
 353         -- Base case
 354 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 355   = do_next
 356
 357 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
 358   = tcStmtAndThen combine do_or_lc m_ty stmt
 359         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 360
 361         -- LetStmt
 362 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
 363   = tcBindsAndThen              -- No error context, but a binding group is
 364         (glue_binds combine)    -- rather a large thing for an error context anyway
 365         binds
 366         thing_inside
 367
 368 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
 369   = tcAddSrcLoc src_loc                                 $
 370     tcAddErrCtxt (stmtCtxt do_or_lc stmt)               $
 371     newTyVarTy liftedTypeKind                           `thenNF_Tc` \ pat_ty ->
 372     tcMonoExpr exp (m pat_ty)                           `thenTc` \ (exp', exp_lie) ->
 373     tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty))       (\ _ ->
 374         tcPopErrCtxt thing_inside
 375     )                                                   `thenTc` \ ([pat'], thing, lie, dict_binds) ->
 376     returnTc (combine (BindStmt pat' exp' src_loc)
 377                       (glue_binds combine Recursive dict_binds thing),
 378               lie `plusLIE` exp_lie)
 379
 380
 381         -- ParStmt
 382 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
 383   = loop bndr_stmts_s           `thenTc` \ ((pairs', thing), lie) ->
 384     returnTc (combine (ParStmtOut pairs') thing, lie)
 385   where
 386     loop []
 387       = thing_inside                            `thenTc` \ (thing, stmts_lie) ->
 388         returnTc (([], thing), stmts_lie)
 389
 390     loop ((bndrs,stmts) : pairs)
 391       = tcStmtsAndThen
 392                 combine_par (DoCtxt ListComp) m_ty stmts
 393                         -- Notice we pass on m_ty; the result type is used only
 394                         -- to get escaping type variables for checkExistentialPat
 395                 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
 396                  loop pairs             `thenTc` \ ((pairs', thing), lie) ->
 397                  returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
 398
 399         returnTc ( ((bndrs',stmts') : pairs', thing), lie)
 400
 401     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 402
 403         -- ExprStmt
 404 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
 405   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 406         if isDoExpr do_or_lc then
 407                 newTyVarTy openTypeKind         `thenNF_Tc` \ any_ty ->
 408                 tcMonoExpr exp (m any_ty)       `thenNF_Tc` \ (exp', lie) ->
 409                 returnTc (ExprStmt exp' any_ty locn, lie)
 410         else
 411                 tcMonoExpr exp boolTy           `thenNF_Tc` \ (exp', lie) ->
 412                 returnTc (ExprStmt exp' boolTy locn, lie)
 413     )                                           `thenTc` \ (stmt', stmt_lie) ->
 414
 415     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 416
 417     returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
 418
 419
 420         -- Result statements
 421 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
 422   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 423         if isDoExpr do_or_lc then
 424                 tcMonoExpr exp (m res_elt_ty)
 425         else
 426                 tcMonoExpr exp res_elt_ty
 427     )                                           `thenTc` \ (exp', stmt_lie) ->
 428
 429     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 430
 431     returnTc (combine (ResultStmt exp' locn) thing,
 432               stmt_lie `plusLIE` stmts_lie)
 433
 434
 435 ------------------------------
 436 glue_binds combine is_rec binds thing
 437   | nullMonoBinds binds = thing
 438   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 439 \end{code}
 440
 441
 442 %************************************************************************
 443 %*                                                                      *
 444 \subsection{Errors and contexts}
 445 %*                                                                      *
 446 %************************************************************************
 447
 448 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 449 number of args are used in each equation.
 450
 451 \begin{code}
 452 sameNoOfArgs :: [RenamedMatch] -> Bool
 453 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
 454   where
 455     args_in_match :: RenamedMatch -> Int
 456     args_in_match (Match pats _ _) = length pats
 457 \end{code}
 458
 459 \begin{code}
 460 varyingArgsErr name matches
 461   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 462
 463 matchCtxt ctxt  match  = hang (pprMatchContext ctxt     <> colon) 4 (pprMatch ctxt match)
 464 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 465
 466 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
 467   = zonkTcType match_ty         `thenNF_Tc` \ match_ty' ->
 468     let
 469         (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 470         (env2, tidy_mty) = tidyOpenType  env1     match_ty'
 471     in
 472     returnNF_Tc (env1,
 473                  sep [ptext SLIT("When checking an existential match that binds"),
 474                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 475                       ptext SLIT("and whose type is") <+> ppr tidy_mty])
 476   where
 477     show_ids = filter is_interesting bound_ids
 478     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 479
 480     ppr_id id ty     = ppr id <+> dcolon <+> ppr ty
 481         -- Don't zonk the types so we get the separate, un-unified versions
 482 \end{code}