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