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,
  16                           mkMonoBind, nullMonoBinds, collectSigTysFromPats
  17                         )
  18 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt )
  19 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt, TcDictBinds )
  20
  21 import TcMonad
  22 import TcMonoType       ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
  23 import Inst             ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
  24 import TcEnv            ( TcId, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars )
  25 import TcPat            ( tcPat, tcMonoPatBndr, polyPatSig )
  26 import TcType           ( TcType, newTyVarTy )
  27 import TcBinds          ( tcBindsAndThen )
  28 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  29 import TcUnify          ( unifyFunTy, unifyTauTy )
  30 import Name             ( Name )
  31 import TysWiredIn       ( boolTy, mkListTy )
  32 import Id               ( idType )
  33 import BasicTypes       ( RecFlag(..) )
  34 import Type             ( tyVarsOfType, isTauTy,  mkFunTy,
  35                           liftedTypeKind, openTypeKind, splitSigmaTy )
  36 import VarSet
  37 import Var              ( Id )
  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 ([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 (TcType,           -- Inferred type of the scrutinee
  88                         [TcMatch],      -- Translated alternatives
  89                         LIE)
  90
  91 tcMatchesCase matches expr_ty
  92   = newTyVarTy openTypeKind                                     `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 (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 ([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 (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 openTypeKind                                 `thenNF_Tc` \ tyvar_ty ->
 143
 144         -- Extend the tyvar env and check the match itself
 145         tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys)           `thenTc` \ sig_tyvars ->
 146         tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty)         `thenTc` \ (pat_ids, match_and_lie) ->
 147
 148         -- Check that the scoped type variables from the patterns
 149         -- have not been constrained
 150         tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids)           (
 151                 checkSigTyVars sig_tyvars emptyVarSet
 152         )                                                       `thenTc_`
 153
 154         -- *Now* we're free to unify with expected_ty
 155         unifyTauTy expected_ty tyvar_ty `thenTc_`
 156
 157         returnTc match_and_lie
 158
 159   where
 160     sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
 161               ++ collectSigTysFromPats pats
 162
 163     tc_match expected_ty        -- Any sig tyvars are in scope by now
 164       = -- STEP 1: Typecheck the patterns
 165         tcMatchPats pats expected_ty    `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
 166         let
 167           xve2       = bagToList pat_bndrs
 168           pat_ids    = map snd xve2
 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         tcCheckExistentialPat pat_ids ex_tvs lie_avail
 193                               (lie_req1 `plusLIE` lie_req2)
 194                               rhs_ty            `thenTc` \ (lie_req', ex_binds) ->
 195
 196         -- Phew!  All done.
 197         let
 198             match' = Match [] pats' Nothing (glue_on Recursive ex_binds grhss')
 199         in
 200         returnTc (pat_ids, (match', lie_req'))
 201
 202         -- glue_on just avoids stupid dross
 203 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 204 glue_on is_rec mbinds (GRHSs grhss binds ty)
 205   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 206
 207 tcGRHSs :: RenamedGRHSs
 208         -> TcType -> StmtCtxt
 209         -> TcM (TcGRHSs, LIE)
 210
 211 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
 212   = tcBindsAndThen glue_on binds (tc_grhss grhss)
 213   where
 214     tc_grhss grhss
 215         = mapAndUnzipTc tc_grhs grhss       `thenTc` \ (grhss', lies) ->
 216           returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
 217
 218     tc_grhs (GRHS guarded locn)
 219         = tcAddSrcLoc locn                                      $
 220           tcStmts ctxt (\ty -> ty, expected_ty) guarded         `thenTc` \ (guarded', lie) ->
 221           returnTc (GRHS guarded' locn, lie)
 222
 223
 224 tcCheckExistentialPat :: [TcId]         -- Ids bound by this pattern
 225                       -> Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
 226                       -> LIE            --   and context
 227                       -> LIE            -- Required context
 228                       -> TcType         --   and result type; vars in here must not escape
 229                       -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
 230 tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
 231   | isEmptyBag ex_tvs && all not_overloaded ids
 232         -- Short cut for case when there are no existentials
 233         -- and no polymorphic overloaded variables
 234         --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
 235         --       f op x = ....
 236         --  Here we must discharge op Methods
 237   = ASSERT( isEmptyLIE lie_avail )
 238     returnTc (lie_req, EmptyMonoBinds)
 239
 240   | otherwise
 241   = tcExtendGlobalTyVars (tyVarsOfType result_ty)               $
 242     tcAddErrCtxtM (sigPatCtxt tv_list ids)                      $
 243
 244         -- In case there are any polymorpic, overloaded binders in the pattern
 245         -- (which can happen in the case of rank-2 type signatures, or data constructors
 246         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 247     bindInstsOfLocalFuns lie_req ids                            `thenTc` \ (lie1, inst_binds) ->
 248
 249         -- Deal with overloaded functions bound by the pattern
 250     tcSimplifyCheck doc tv_list
 251                     (lieToList lie_avail) lie1          `thenTc` \ (lie2, dict_binds) ->
 252     checkSigTyVars tv_list emptyVarSet                          `thenTc_`
 253
 254     returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
 255   where
 256     doc     = text ("the existential context of a data constructor")
 257     tv_list = bagToList ex_tvs
 258     not_overloaded id = case splitSigmaTy (idType id) of
 259                           (_, theta, _) -> null theta
 260 \end{code}
 261
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 \subsection{tcMatchPats}
 266 %*                                                                      *
 267 %************************************************************************
 268
 269 \begin{code}
 270 tcMatchPats [] expected_ty
 271   = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
 272
 273 tcMatchPats (pat:pats) expected_ty
 274   = unifyFunTy expected_ty              `thenTc` \ (arg_ty, rest_ty) ->
 275     tcPat tcMonoPatBndr pat arg_ty      `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
 276     tcMatchPats pats rest_ty            `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
 277     returnTc (  rhs_ty,
 278                 pat':pats',
 279                 lie_req `plusLIE` lie_reqs,
 280                 pat_tvs `unionBags` pats_tvs,
 281                 pat_ids `unionBags` pats_ids,
 282                 lie_avail `plusLIE` lie_avails
 283     )
 284 \end{code}
 285
 286
 287 %************************************************************************
 288 %*                                                                      *
 289 \subsection{tcStmts}
 290 %*                                                                      *
 291 %************************************************************************
 292
 293 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 294
 295         [ (g x, h x) | ... ; let g v = ...
 296                      | ... ; let h v = ... ]
 297
 298 It's possible that g,h are overloaded, so we need to feed the LIE from the
 299 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 300 Similarly if we had an existential pattern match:
 301
 302         data T = forall a. Show a => C a
 303
 304         [ (show x, show y) | ... ; C x <- ...
 305                            | ... ; C y <- ... ]
 306
 307 Then we need the LIE from (show x, show y) to be simplified against
 308 the bindings for x and y.
 309
 310 It's difficult to do this in parallel, so we rely on the renamer to
 311 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 312 So the binders of the first parallel group will be in scope in the second
 313 group.  But that's fine; there's no shadowing to worry about.
 314
 315 \begin{code}
 316 tcStmts do_or_lc m_ty stmts
 317   = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
 318
 319 tcStmtsAndThen
 320         :: (TcStmt -> thing -> thing)   -- Combiner
 321         -> StmtCtxt
 322         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 323                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 324         -> [RenamedStmt]
 325         -> TcM (thing, LIE)
 326         -> TcM (thing, LIE)
 327
 328         -- Base case
 329 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 330   = do_next
 331
 332         -- LetStmt
 333 tcStmtsAndThen combine do_or_lc m_ty (LetStmt binds : stmts) do_next
 334   = tcBindsAndThen              -- No error context, but a binding group is
 335         (glue_binds combine)    -- rather a large thing for an error context anyway
 336         binds
 337         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 338
 339         -- BindStmt
 340 tcStmtsAndThen combine do_or_lc m_ty@(m,elt_ty) (stmt@(BindStmt pat exp src_loc) : stmts) do_next
 341   = tcAddSrcLoc src_loc         (
 342         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 343         newTyVarTy liftedTypeKind       `thenNF_Tc` \ pat_ty ->
 344         tcPat tcMonoPatBndr pat pat_ty  `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
 345         tcExpr exp (m pat_ty)           `thenTc` \ (exp', exp_lie) ->
 346         returnTc (pat', exp',
 347                   pat_lie `plusLIE` exp_lie,
 348                   pat_tvs, pat_ids, avail)
 349     )                                   `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
 350     let
 351         new_val_env = bagToList pat_bndrs
 352         pat_ids     = map snd new_val_env
 353     in
 354
 355         -- Do the rest; we don't need to add the pat_tvs to the envt
 356         -- because they all appear in the pat_ids's types
 357     tcExtendLocalValEnv new_val_env (
 358        tcStmtsAndThen combine do_or_lc m_ty stmts do_next
 359     )                                           `thenTc` \ (thing, stmts_lie) ->
 360
 361         -- Reinstate context for existential checks
 362     tcSetErrCtxt (stmtCtxt do_or_lc stmt)               $
 363     tcCheckExistentialPat pat_ids pat_tvs lie_avail
 364                           stmts_lie (m elt_ty)          `thenTc` \ (final_lie, dict_binds) ->
 365
 366     returnTc (combine (BindStmt pat' exp' src_loc)
 367                       (glue_binds combine Recursive dict_binds thing),
 368               lie_req `plusLIE` final_lie)
 369
 370
 371         -- ParStmt
 372 tcStmtsAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s : stmts) do_next
 373   = loop bndr_stmts_s           `thenTc` \ ((pairs', thing), lie) ->
 374     returnTc (combine (ParStmtOut pairs') thing, lie)
 375   where
 376     loop []
 377       = tcStmtsAndThen combine do_or_lc m_ty stmts do_next      `thenTc` \ (thing, stmts_lie) ->
 378         returnTc (([], thing), stmts_lie)
 379
 380     loop ((bndrs,stmts) : pairs)
 381       = tcStmtsAndThen
 382                 combine_par ListComp (mkListTy, not_required) stmts
 383                 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
 384                  loop pairs             `thenTc` \ ((pairs', thing), lie) ->
 385                  returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
 386
 387         returnTc ( ((bndrs',stmts') : pairs', thing), lie)
 388
 389     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 390     not_required = panic "tcStmtsAndThen: elt_ty"
 391
 392         -- The simple-statment case
 393 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
 394   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 395         tcSimpleStmt do_or_lc m_ty stmt (null stmts)
 396     )                                                   `thenTc` \ (stmt', stmt_lie) ->
 397
 398     tcStmtsAndThen combine do_or_lc m_ty stmts do_next  `thenTc` \ (thing, stmts_lie) ->
 399
 400     returnTc (combine stmt' thing,
 401               stmt_lie `plusLIE` stmts_lie)
 402
 403
 404 ------------------------------
 405         -- ReturnStmt
 406 tcSimpleStmt do_or_lc (_,elt_ty) (ReturnStmt exp) is_last_stmt
 407   = ASSERT( is_last_stmt )
 408     tcExpr exp elt_ty                           `thenTc`    \ (exp', exp_lie) ->
 409     returnTc (ReturnStmt exp', exp_lie)
 410
 411         -- ExprStmt
 412 tcSimpleStmt do_or_lc (m, elt_ty) (ExprStmt exp src_loc) is_last_stmt
 413   = tcAddSrcLoc src_loc                 $
 414     (if is_last_stmt then       -- do { ... ; wuggle }          wuggle : m elt_ty
 415         returnNF_Tc elt_ty
 416      else                       -- do { ... ; wuggle ; .... }   wuggle : m any_ty
 417         ASSERT( isDoStmt do_or_lc )
 418         newTyVarTy openTypeKind
 419     )                           `thenNF_Tc` \ arg_ty ->
 420     tcExpr exp (m arg_ty)       `thenTc`    \ (exp', exp_lie) ->
 421     returnTc (ExprStmt exp' src_loc, exp_lie)
 422
 423         -- GuardStmt
 424 tcSimpleStmt do_or_lc m_ty (GuardStmt exp src_loc) is_last_stmt
 425   = ASSERT( not (isDoStmt do_or_lc) )
 426     tcAddSrcLoc src_loc                 $
 427     tcExpr exp boolTy                   `thenTc` \ (exp', exp_lie) ->
 428     returnTc (GuardStmt exp' src_loc, exp_lie)
 429
 430 ------------------------------
 431 glue_binds combine is_rec binds thing
 432   | nullMonoBinds binds = thing
 433   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 434
 435 isDoStmt DoStmt = True
 436 isDoStmt other  = False
 437 \end{code}
 438
 439
 440 %************************************************************************
 441 %*                                                                      *
 442 \subsection{Errors and contexts}
 443 %*                                                                      *
 444 %************************************************************************
 445
 446 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 447 number of args are used in each equation.
 448
 449 \begin{code}
 450 sameNoOfArgs :: [RenamedMatch] -> Bool
 451 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
 452   where
 453     args_in_match :: RenamedMatch -> Int
 454     args_in_match (Match _ pats _ _) = length pats
 455 \end{code}
 456
 457 \begin{code}
 458 matchCtxt CaseAlt match
 459   = hang (ptext SLIT("In a case alternative:"))
 460          4 (pprMatch (True,empty) {-is_case-} match)
 461
 462 matchCtxt (FunRhs fun) match
 463   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
 464          4 (pprMatch (False, ppr_fun) {-not case-} match)
 465   where
 466     ppr_fun = ppr fun
 467
 468 matchCtxt LambdaBody match
 469   = hang (ptext SLIT("In the lambda expression"))
 470          4 (pprMatch (True, empty) match)
 471
 472 varyingArgsErr name matches
 473   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 474
 475 lurkingRank2SigErr
 476   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 477
 478 stmtCtxt do_or_lc stmt
 479   = hang (ptext SLIT("In") <+> what <> colon)
 480          4 (ppr stmt)
 481   where
 482     what = case do_or_lc of
 483                 ListComp -> ptext SLIT("a list-comprehension qualifier")
 484                 DoStmt   -> ptext SLIT("a do statement")
 485                 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
 486                 FunRhs f   -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
 487                 CaseAlt    -> thing <+> ptext SLIT("a case alternative")
 488                 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
 489     thing = case stmt of
 490                 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
 491                 GuardStmt _ _  -> ptext SLIT("a guard for")
 492                 ExprStmt _ _   -> ptext SLIT("the right-hand side of")
 493 \end{code}