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