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