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( tcExpr )
  14
  15 import HsSyn            ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
  16                           MonoBinds(..), Stmt(..), HsMatchContext(..),
  17                           pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
  18                           mkMonoBind, nullMonoBinds, collectSigTysFromPats
  19                         )
  20 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt )
  21 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt, TcDictBinds )
  22
  23 import TcMonad
  24 import TcMonoType       ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
  25 import Inst             ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
  26 import TcEnv            ( TcId, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars )
  27 import TcPat            ( tcPat, tcMonoPatBndr, polyPatSig )
  28 import TcType           ( TcType, newTyVarTy )
  29 import TcBinds          ( tcBindsAndThen )
  30 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  31 import TcUnify          ( unifyFunTy, unifyTauTy )
  32 import Name             ( Name )
  33 import TysWiredIn       ( boolTy, mkListTy )
  34 import Id               ( idType )
  35 import BasicTypes       ( RecFlag(..) )
  36 import Type             ( tyVarsOfType, isTauTy,  mkFunTy,
  37                           liftedTypeKind, openTypeKind, splitSigmaTy )
  38 import VarSet
  39 import Var              ( Id )
  40 import Bag
  41 import Outputable
  42 import List             ( nub )
  43 \end{code}
  44
  45 %************************************************************************
  46 %*                                                                      *
  47 \subsection{tcMatchesFun, tcMatchesCase}
  48 %*                                                                      *
  49 %************************************************************************
  50
  51 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  52 @FunMonoBind@.  The second argument is the name of the function, which
  53 is used in error messages.  It checks that all the equations have the
  54 same number of arguments before using @tcMatches@ to do the work.
  55
  56 \begin{code}
  57 tcMatchesFun :: [(Name,Id)]     -- Bindings for the variables bound in this group
  58              -> Name
  59              -> TcType          -- Expected type
  60              -> [RenamedMatch]
  61              -> TcM ([TcMatch], LIE)
  62
  63 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
  64   =      -- Check that they all have the same no of arguments
  65          -- Set the location to that of the first equation, so that
  66          -- any inter-equation error messages get some vaguely
  67          -- sensible location.  Note: we have to do this odd
  68          -- ann-grabbing, because we don't always have annotations in
  69          -- hand when we call tcMatchesFun...
  70     tcAddSrcLoc (getMatchLoc first_match)        (
  71             checkTc (sameNoOfArgs matches)
  72                     (varyingArgsErr fun_name matches)
  73     )                                            `thenTc_`
  74
  75         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  76         -- because inconsistency between branches
  77         -- may show up as something wrong with the (non-existent) type signature
  78
  79         -- No need to zonk expected_ty, because unifyFunTy does that on the fly
  80     tcMatches xve matches expected_ty (FunRhs fun_name)
  81 \end{code}
  82
  83 @tcMatchesCase@ doesn't do the argument-count check because the
  84 parser guarantees that each equation has exactly one argument.
  85
  86 \begin{code}
  87 tcMatchesCase :: [RenamedMatch]         -- The case alternatives
  88               -> TcType                 -- Type of whole case expressions
  89               -> TcM (TcType,           -- Inferred type of the scrutinee
  90                         [TcMatch],      -- Translated alternatives
  91                         LIE)
  92
  93 tcMatchesCase matches expr_ty
  94   = newTyVarTy openTypeKind                                     `thenNF_Tc` \ scrut_ty ->
  95     tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt     `thenTc` \ (matches', lie) ->
  96     returnTc (scrut_ty, matches', lie)
  97
  98 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
  99 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr
 100 \end{code}
 101
 102
 103 \begin{code}
 104 tcMatches :: [(Name,Id)]
 105           -> [RenamedMatch]
 106           -> TcType
 107           -> HsMatchContext
 108           -> TcM ([TcMatch], LIE)
 109
 110 tcMatches xve matches expected_ty fun_or_case
 111   = mapAndUnzipTc tc_match matches      `thenTc` \ (matches, lies) ->
 112     returnTc (matches, plusLIEs lies)
 113   where
 114     tc_match match = tcMatch xve match expected_ty fun_or_case
 115 \end{code}
 116
 117
 118 %************************************************************************
 119 %*                                                                      *
 120 \subsection{tcMatch}
 121 %*                                                                      *
 122 %************************************************************************
 123
 124 \begin{code}
 125 tcMatch :: [(Name,Id)]
 126         -> RenamedMatch
 127         -> TcType               -- Expected result-type of the Match.
 128                                 -- Early unification with this guy gives better error messages
 129         -> HsMatchContext
 130         -> TcM (TcMatch, LIE)
 131
 132 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
 133   = tcAddSrcLoc (getMatchLoc match)             $
 134     tcAddErrCtxt (matchCtxt ctxt match)         $
 135
 136     if null sig_tvs then        -- The common case
 137         tc_match expected_ty    `thenTc` \ (_, match_and_lie) ->
 138         returnTc match_and_lie
 139
 140     else
 141         -- If there are sig tvs we must be careful *not* to use
 142         -- expected_ty right away, else we'll unify with tyvars free
 143         -- in the envt.  So invent a fresh tyvar and use that instead
 144         newTyVarTy openTypeKind                                 `thenNF_Tc` \ tyvar_ty ->
 145
 146         -- Extend the tyvar env and check the match itself
 147         tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys)           `thenTc` \ sig_tyvars ->
 148         tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty)         `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 emptyVarSet
 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     sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
 163               ++ collectSigTysFromPats pats
 164
 165     tc_match expected_ty        -- Any sig tyvars are in scope by now
 166       = -- STEP 1: Typecheck the patterns
 167         tcMatchPats pats expected_ty    `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
 168         let
 169           xve2       = bagToList pat_bndrs
 170           pat_ids    = map snd xve2
 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         tcCheckExistentialPat pat_ids ex_tvs lie_avail
 195                               (lie_req1 `plusLIE` lie_req2)
 196                               rhs_ty            `thenTc` \ (lie_req', ex_binds) ->
 197
 198         -- Phew!  All done.
 199         let
 200             match' = Match [] pats' Nothing (glue_on Recursive ex_binds grhss')
 201         in
 202         returnTc (pat_ids, (match', lie_req'))
 203
 204         -- glue_on just avoids stupid dross
 205 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 206 glue_on is_rec mbinds (GRHSs grhss binds ty)
 207   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 208
 209 tcGRHSs :: RenamedGRHSs
 210         -> TcType -> HsMatchContext
 211         -> TcM (TcGRHSs, LIE)
 212
 213 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
 214   = tcBindsAndThen glue_on binds (tc_grhss grhss)
 215   where
 216     tc_grhss grhss
 217         = mapAndUnzipTc tc_grhs grhss       `thenTc` \ (grhss', lies) ->
 218           returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
 219
 220     tc_grhs (GRHS guarded locn)
 221         = tcAddSrcLoc locn                                      $
 222           tcStmts ctxt (\ty -> ty, expected_ty) guarded         `thenTc` \ (guarded', lie) ->
 223           returnTc (GRHS guarded' locn, lie)
 224
 225
 226 tcCheckExistentialPat :: [TcId]         -- Ids bound by this pattern
 227                       -> Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
 228                       -> LIE            --   and context
 229                       -> LIE            -- Required context
 230                       -> TcType         --   and result type; vars in here must not escape
 231                       -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
 232 tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
 233   | isEmptyBag ex_tvs && all not_overloaded ids
 234         -- Short cut for case when there are no existentials
 235         -- and no polymorphic overloaded variables
 236         --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
 237         --       f op x = ....
 238         --  Here we must discharge op Methods
 239   = ASSERT( isEmptyLIE lie_avail )
 240     returnTc (lie_req, EmptyMonoBinds)
 241
 242   | otherwise
 243   = tcExtendGlobalTyVars (tyVarsOfType result_ty)               $
 244     tcAddErrCtxtM (sigPatCtxt tv_list ids)                      $
 245
 246         -- In case there are any polymorpic, overloaded binders in the pattern
 247         -- (which can happen in the case of rank-2 type signatures, or data constructors
 248         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 249     bindInstsOfLocalFuns lie_req ids                            `thenTc` \ (lie1, inst_binds) ->
 250
 251         -- Deal with overloaded functions bound by the pattern
 252     tcSimplifyCheck doc tv_list
 253                     (lieToList lie_avail) lie1          `thenTc` \ (lie2, dict_binds) ->
 254     checkSigTyVars tv_list emptyVarSet                          `thenTc_`
 255
 256     returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
 257   where
 258     doc     = text ("the existential context of a data constructor")
 259     tv_list = bagToList ex_tvs
 260     not_overloaded id = case splitSigmaTy (idType id) of
 261                           (_, theta, _) -> null theta
 262 \end{code}
 263
 264
 265 %************************************************************************
 266 %*                                                                      *
 267 \subsection{tcMatchPats}
 268 %*                                                                      *
 269 %************************************************************************
 270
 271 \begin{code}
 272 tcMatchPats [] expected_ty
 273   = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
 274
 275 tcMatchPats (pat:pats) expected_ty
 276   = unifyFunTy expected_ty              `thenTc` \ (arg_ty, rest_ty) ->
 277     tcPat tcMonoPatBndr pat arg_ty      `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
 278     tcMatchPats pats rest_ty            `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
 279     returnTc (  rhs_ty,
 280                 pat':pats',
 281                 lie_req `plusLIE` lie_reqs,
 282                 pat_tvs `unionBags` pats_tvs,
 283                 pat_ids `unionBags` pats_ids,
 284                 lie_avail `plusLIE` lie_avails
 285     )
 286 \end{code}
 287
 288
 289 %************************************************************************
 290 %*                                                                      *
 291 \subsection{tcStmts}
 292 %*                                                                      *
 293 %************************************************************************
 294
 295 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 296
 297         [ (g x, h x) | ... ; let g v = ...
 298                      | ... ; let h v = ... ]
 299
 300 It's possible that g,h are overloaded, so we need to feed the LIE from the
 301 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 302 Similarly if we had an existential pattern match:
 303
 304         data T = forall a. Show a => C a
 305
 306         [ (show x, show y) | ... ; C x <- ...
 307                            | ... ; C y <- ... ]
 308
 309 Then we need the LIE from (show x, show y) to be simplified against
 310 the bindings for x and y.
 311
 312 It's difficult to do this in parallel, so we rely on the renamer to
 313 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 314 So the binders of the first parallel group will be in scope in the second
 315 group.  But that's fine; there's no shadowing to worry about.
 316
 317 \begin{code}
 318 tcStmts do_or_lc m_ty stmts
 319   = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
 320
 321 tcStmtsAndThen
 322         :: (TcStmt -> thing -> thing)   -- Combiner
 323         -> HsMatchContext
 324         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 325                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 326         -> [RenamedStmt]
 327         -> TcM (thing, LIE)
 328         -> TcM (thing, LIE)
 329
 330         -- Base case
 331 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 332   = do_next
 333
 334         -- LetStmt
 335 tcStmtsAndThen combine do_or_lc m_ty (LetStmt binds : stmts) do_next
 336   = tcBindsAndThen              -- No error context, but a binding group is
 337         (glue_binds combine)    -- rather a large thing for an error context anyway
 338         binds
 339         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 340
 341         -- BindStmt
 342 tcStmtsAndThen combine do_or_lc m_ty@(m,elt_ty) (stmt@(BindStmt pat exp src_loc) : stmts) do_next
 343   = tcAddSrcLoc src_loc         (
 344         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 345         newTyVarTy liftedTypeKind       `thenNF_Tc` \ pat_ty ->
 346         tcPat tcMonoPatBndr pat pat_ty  `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
 347         tcExpr exp (m pat_ty)           `thenTc` \ (exp', exp_lie) ->
 348         returnTc (pat', exp',
 349                   pat_lie `plusLIE` exp_lie,
 350                   pat_tvs, pat_ids, avail)
 351     )                                   `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
 352     let
 353         new_val_env = bagToList pat_bndrs
 354         pat_ids     = map snd new_val_env
 355     in
 356
 357         -- Do the rest; we don't need to add the pat_tvs to the envt
 358         -- because they all appear in the pat_ids's types
 359     tcExtendLocalValEnv new_val_env (
 360        tcStmtsAndThen combine do_or_lc m_ty stmts do_next
 361     )                                           `thenTc` \ (thing, stmts_lie) ->
 362
 363         -- Reinstate context for existential checks
 364     tcSetErrCtxt (stmtCtxt do_or_lc stmt)               $
 365     tcCheckExistentialPat pat_ids pat_tvs lie_avail
 366                           stmts_lie (m elt_ty)          `thenTc` \ (final_lie, dict_binds) ->
 367
 368     returnTc (combine (BindStmt pat' exp' src_loc)
 369                       (glue_binds combine Recursive dict_binds thing),
 370               lie_req `plusLIE` final_lie)
 371
 372
 373         -- ParStmt
 374 tcStmtsAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s : stmts) do_next
 375   = loop bndr_stmts_s           `thenTc` \ ((pairs', thing), lie) ->
 376     returnTc (combine (ParStmtOut pairs') thing, lie)
 377   where
 378     loop []
 379       = tcStmtsAndThen combine do_or_lc m_ty stmts do_next      `thenTc` \ (thing, stmts_lie) ->
 380         returnTc (([], thing), stmts_lie)
 381
 382     loop ((bndrs,stmts) : pairs)
 383       = tcStmtsAndThen
 384                 combine_par ListComp (mkListTy, not_required) stmts
 385                 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
 386                  loop pairs             `thenTc` \ ((pairs', thing), lie) ->
 387                  returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
 388
 389         returnTc ( ((bndrs',stmts') : pairs', thing), lie)
 390
 391     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 392     not_required = panic "tcStmtsAndThen: elt_ty"
 393
 394         -- The simple-statment case
 395 tcStmtsAndThen combine do_or_lc m_ty (stmt@(ExprStmt exp locn):stmts) do_next
 396   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 397         tcExprStmt do_or_lc m_ty exp (null stmts)
 398     )                                                   `thenTc` \ (exp', stmt_lie) ->
 399
 400     tcStmtsAndThen combine do_or_lc m_ty stmts do_next  `thenTc` \ (thing, stmts_lie) ->
 401
 402     returnTc (combine (ExprStmt exp' locn) thing,
 403               stmt_lie `plusLIE` stmts_lie)
 404
 405
 406 ------------------------------
 407         -- ExprStmt; see comments with HsExpr.HsStmt
 408         --           for meaning of ExprStmt
 409 tcExprStmt do_or_lc (m, res_elt_ty) exp is_last_stmt
 410   = compute_expr_ty             `thenNF_Tc` \ expr_ty ->
 411     tcExpr exp expr_ty
 412   where
 413     compute_expr_ty
 414         | is_last_stmt = if isDoExpr do_or_lc then
 415                                 returnNF_Tc (m res_elt_ty)
 416                          else
 417                                 returnNF_Tc res_elt_ty
 418
 419         | otherwise    = if isDoExpr do_or_lc then
 420                                 newTyVarTy openTypeKind         `thenNF_Tc` \ any_ty ->
 421                                 returnNF_Tc (m any_ty)
 422                          else
 423                                 returnNF_Tc boolTy
 424
 425 ------------------------------
 426 glue_binds combine is_rec binds thing
 427   | nullMonoBinds binds = thing
 428   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 429 \end{code}
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsection{Errors and contexts}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 439 number of args are used in each equation.
 440
 441 \begin{code}
 442 sameNoOfArgs :: [RenamedMatch] -> Bool
 443 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
 444   where
 445     args_in_match :: RenamedMatch -> Int
 446     args_in_match (Match _ pats _ _) = length pats
 447 \end{code}
 448
 449 \begin{code}
 450 matchCtxt CaseAlt match
 451   = hang (ptext SLIT("In a case alternative:"))
 452          4 (pprMatch (True,empty) {-is_case-} match)
 453
 454 matchCtxt (FunRhs fun) match
 455   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
 456          4 (pprMatch (False, ppr_fun) {-not case-} match)
 457   where
 458     ppr_fun = ppr fun
 459
 460 matchCtxt LambdaExpr match
 461   = hang (ptext SLIT("In the lambda expression"))
 462          4 (pprMatch (True, empty) match)
 463
 464 varyingArgsErr name matches
 465   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 466
 467 lurkingRank2SigErr
 468   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 469
 470 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 471 \end{code}