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( tcMonoExpr )
  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, RenamedMatchContext )
  21 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
  22
  23 import TcMonad
  24 import TcMonoType       ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
  25 import Inst             ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
  26 import TcEnv            ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
  27 import TcPat            ( tcPat, tcMonoPatBndr )
  28 import TcMType          ( newTyVarTy, zonkTcType )
  29 import TcType           ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
  30                           mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind  )
  31 import TcBinds          ( tcBindsAndThen )
  32 import TcUnify          ( subFunTy, checkSigTyVarsWrt, tcSub, isIdCoercion, (<$>) )
  33 import TcSimplify       ( tcSimplifyCheck, bindInstsOfLocalFuns )
  34 import Name             ( Name )
  35 import TysWiredIn       ( boolTy )
  36 import Id               ( idType )
  37 import CoreFVs          ( idFreeTyVars )
  38 import BasicTypes       ( RecFlag(..) )
  39 import VarSet
  40 import Var              ( Id )
  41 import Bag
  42 import Util             ( isSingleton )
  43 import Outputable
  44
  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 subFunTy does that on the fly
  83     tcMatches xve (FunRhs fun_name) matches expected_ty
  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 [] CaseAlt matches (mkFunTy scrut_ty expr_ty)     `thenTc` \ (matches', lie) ->
  99     returnTc (scrut_ty, matches', lie)
 100
 101 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
 102 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
 103 \end{code}
 104
 105
 106 \begin{code}
 107 tcMatches :: [(Name,Id)]
 108           -> RenamedMatchContext
 109           -> [RenamedMatch]
 110           -> TcType
 111           -> TcM ([TcMatch], LIE)
 112
 113 tcMatches xve ctxt matches expected_ty
 114   = mapAndUnzipTc tc_match matches      `thenTc` \ (matches, lies) ->
 115     returnTc (matches, plusLIEs lies)
 116   where
 117     tc_match match = tcMatch xve ctxt match expected_ty
 118 \end{code}
 119
 120
 121 %************************************************************************
 122 %*                                                                      *
 123 \subsection{tcMatch}
 124 %*                                                                      *
 125 %************************************************************************
 126
 127 \begin{code}
 128 tcMatch :: [(Name,Id)]
 129         -> RenamedMatchContext
 130         -> RenamedMatch
 131         -> TcType       -- Expected result-type of the Match.
 132                         -- Early unification with this guy gives better error messages
 133                         -- We regard the Match as having type
 134                         --      (ty1 -> ... -> tyn -> result_ty)
 135                         -- where there are n patterns.
 136         -> TcM (TcMatch, LIE)
 137
 138 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
 139   = tcAddSrcLoc (getMatchLoc match)             $       -- At one stage I removed this;
 140     tcAddErrCtxt (matchCtxt ctxt match)         $       -- I'm not sure why, so I put it back
 141
 142     tcMatchPats pats expected_ty tc_grhss       `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
 143     returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
 144
 145   where
 146     tc_grhss pats' rhs_ty
 147         = tcExtendLocalValEnv2 xve1                     $
 148
 149                 -- Deal with the result signature
 150           case maybe_rhs_sig of
 151             Nothing ->  tcGRHSs ctxt grhss rhs_ty       `thenTc` \ (grhss', lie) ->
 152                         returnTc ((pats', grhss'), lie)
 153
 154             Just sig ->  tcAddScopedTyVars [sig]        $
 155                                 -- Bring into scope the type variables in the signature
 156                          tcHsSigType ResSigCtxt sig     `thenTc` \ sig_ty ->
 157                          tcGRHSs ctxt grhss sig_ty      `thenTc` \ (grhss', lie1) ->
 158                          tcSub rhs_ty sig_ty            `thenTc` \ (co_fn, lie2)  ->
 159                          returnTc ((pats', lift_grhss co_fn rhs_ty grhss'),
 160                                    lie1 `plusLIE` lie2)
 161
 162 -- lift_grhss pushes the coercion down to the right hand sides,
 163 -- because there is no convenient place to hang it otherwise.
 164 lift_grhss co_fn rhs_ty grhss
 165   | isIdCoercion co_fn = grhss
 166 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
 167   = GRHSs (map lift_grhs grhss) binds rhs_ty    -- Change the type, since we
 168   where
 169     lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
 170
 171     lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
 172     lift_stmt stmt             = stmt
 173
 174 -- glue_on just avoids stupid dross
 175 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 176 glue_on is_rec mbinds (GRHSs grhss binds ty)
 177   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 178
 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         tcExtendLocalValEnv2 xve (thing_inside pats' rhs_ty)            `thenTc` \ (result, lie_req2) ->
 227
 228         returnTc (lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2)
 229     ) `thenTc` \ (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 tcCheckExistentialPat :: [TcId]         -- Ids bound by this pattern
 248                       -> Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
 249                       -> LIE            --   and context
 250                       -> LIE            -- Required context
 251                       -> TcType         --   and type of the Match; vars in here must not escape
 252                       -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
 253 tcCheckExistentialPat ids ex_tvs lie_avail lie_req match_ty
 254   | isEmptyBag ex_tvs && all not_overloaded ids
 255         -- Short cut for case when there are no existentials
 256         -- and no polymorphic overloaded variables
 257         --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
 258         --       f op x = ....
 259         --  Here we must discharge op Methods
 260   = ASSERT( isEmptyLIE lie_avail )
 261     returnTc (lie_req, EmptyMonoBinds)
 262
 263   | otherwise
 264   = tcAddErrCtxtM (sigPatCtxt tv_list ids match_ty)             $
 265
 266         -- In case there are any polymorpic, overloaded binders in the pattern
 267         -- (which can happen in the case of rank-2 type signatures, or data constructors
 268         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 269     bindInstsOfLocalFuns lie_req ids                            `thenTc` \ (lie1, inst_binds) ->
 270
 271         -- Deal with overloaded functions bound by the pattern
 272     tcSimplifyCheck doc tv_list (lieToList lie_avail) lie1      `thenTc` \ (lie2, dict_binds) ->
 273     checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list           `thenTc_`
 274
 275     returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
 276   where
 277     doc     = text ("the existential context of a data constructor")
 278     tv_list = bagToList ex_tvs
 279     not_overloaded id = not (isOverloadedTy (idType id))
 280
 281 tc_match_pats [] expected_ty
 282   = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
 283
 284 tc_match_pats (pat:pats) expected_ty
 285   = subFunTy expected_ty                `thenTc` \ (arg_ty, rest_ty) ->
 286         -- This is the unique place we call subFunTy
 287         -- The point is that if expected_y is a "hole", we want
 288         -- to make arg_ty and rest_ty as "holes" too.
 289     tcPat tcMonoPatBndr pat arg_ty      `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
 290     tc_match_pats pats rest_ty          `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
 291     returnTc (  rhs_ty,
 292                 pat':pats',
 293                 lie_req `plusLIE` lie_reqs,
 294                 pat_tvs `unionBags` pats_tvs,
 295                 pat_ids `unionBags` pats_ids,
 296                 lie_avail `plusLIE` lie_avails
 297     )
 298 \end{code}
 299
 300
 301 %************************************************************************
 302 %*                                                                      *
 303 \subsection{tcStmts}
 304 %*                                                                      *
 305 %************************************************************************
 306
 307 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 308
 309         [ (g x, h x) | ... ; let g v = ...
 310                      | ... ; let h v = ... ]
 311
 312 It's possible that g,h are overloaded, so we need to feed the LIE from the
 313 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 314 Similarly if we had an existential pattern match:
 315
 316         data T = forall a. Show a => C a
 317
 318         [ (show x, show y) | ... ; C x <- ...
 319                            | ... ; C y <- ... ]
 320
 321 Then we need the LIE from (show x, show y) to be simplified against
 322 the bindings for x and y.
 323
 324 It's difficult to do this in parallel, so we rely on the renamer to
 325 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 326 So the binders of the first parallel group will be in scope in the second
 327 group.  But that's fine; there's no shadowing to worry about.
 328
 329 \begin{code}
 330 tcStmts do_or_lc m_ty stmts
 331   = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
 332
 333 tcStmtsAndThen
 334         :: (TcStmt -> thing -> thing)   -- Combiner
 335         -> RenamedMatchContext
 336         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 337                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 338         -> [RenamedStmt]
 339         -> TcM (thing, LIE)
 340         -> TcM (thing, LIE)
 341
 342         -- Base case
 343 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 344   = do_next
 345
 346 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
 347   = tcStmtAndThen combine do_or_lc m_ty stmt
 348         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 349
 350         -- LetStmt
 351 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
 352   = tcBindsAndThen              -- No error context, but a binding group is
 353         (glue_binds combine)    -- rather a large thing for an error context anyway
 354         binds
 355         thing_inside
 356
 357 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
 358   = tcAddSrcLoc src_loc                                 $
 359     tcAddErrCtxt (stmtCtxt do_or_lc stmt)               $
 360     newTyVarTy liftedTypeKind                           `thenNF_Tc` \ pat_ty ->
 361     tcMonoExpr exp (m pat_ty)                           `thenTc` \ (exp', exp_lie) ->
 362     tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty))       (\ [pat'] _ ->
 363         tcPopErrCtxt                            $
 364         thing_inside                            `thenTc` \ (thing, lie) ->
 365         returnTc ((BindStmt pat' exp' src_loc, thing), lie)
 366     )                                                   `thenTc` \ ((stmt', thing), lie, dict_binds) ->
 367     returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
 368               lie `plusLIE` exp_lie)
 369
 370
 371         -- ParStmt
 372 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
 373   = loop bndr_stmts_s           `thenTc` \ ((pairs', thing), lie) ->
 374     returnTc (combine (ParStmtOut pairs') thing, lie)
 375   where
 376     loop []
 377       = thing_inside                            `thenTc` \ (thing, stmts_lie) ->
 378         returnTc (([], thing), stmts_lie)
 379
 380     loop ((bndrs,stmts) : pairs)
 381       = tcStmtsAndThen
 382                 combine_par (DoCtxt ListComp) m_ty stmts
 383                         -- Notice we pass on m_ty; the result type is used only
 384                         -- to get escaping type variables for checkExistentialPat
 385                 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
 386                  loop pairs             `thenTc` \ ((pairs', thing), lie) ->
 387                  returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
 388
 389         returnTc ( ((bndrs',stmts') : pairs', thing), lie)
 390
 391     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 392
 393         -- ExprStmt
 394 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
 395   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 396         if isDoExpr do_or_lc then
 397                 newTyVarTy openTypeKind         `thenNF_Tc` \ any_ty ->
 398                 tcMonoExpr exp (m any_ty)       `thenNF_Tc` \ (exp', lie) ->
 399                 returnTc (ExprStmt exp' any_ty locn, lie)
 400         else
 401                 tcMonoExpr exp boolTy           `thenNF_Tc` \ (exp', lie) ->
 402                 returnTc (ExprStmt exp' boolTy locn, lie)
 403     )                                           `thenTc` \ (stmt', stmt_lie) ->
 404
 405     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 406
 407     returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
 408
 409
 410         -- Result statements
 411 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
 412   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 413         if isDoExpr do_or_lc then
 414                 tcMonoExpr exp (m res_elt_ty)
 415         else
 416                 tcMonoExpr exp res_elt_ty
 417     )                                           `thenTc` \ (exp', stmt_lie) ->
 418
 419     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 420
 421     returnTc (combine (ResultStmt exp' locn) thing,
 422               stmt_lie `plusLIE` stmts_lie)
 423
 424
 425 ------------------------------
 426 glue_binds combine is_rec binds thing
 427   | nullMonoBinds binds = thing
 428   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 429 \end{code}
 430
 431
 432 %************************************************************************
 433 %*                                                                      *
 434 \subsection{Errors and contexts}
 435 %*                                                                      *
 436 %************************************************************************
 437
 438 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 439 number of args are used in each equation.
 440
 441 \begin{code}
 442 sameNoOfArgs :: [RenamedMatch] -> Bool
 443 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
 444   where
 445     args_in_match :: RenamedMatch -> Int
 446     args_in_match (Match pats _ _) = length pats
 447 \end{code}
 448
 449 \begin{code}
 450 varyingArgsErr name matches
 451   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 452
 453 matchCtxt ctxt  match  = hang (pprMatchContext ctxt     <> colon) 4 (pprMatch ctxt match)
 454 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
 455
 456 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
 457   = zonkTcType match_ty         `thenNF_Tc` \ match_ty' ->
 458     let
 459         (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
 460         (env2, tidy_mty) = tidyOpenType  env1     match_ty'
 461     in
 462     returnNF_Tc (env1,
 463                  sep [ptext SLIT("When checking an existential match that binds"),
 464                       nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 465                       ptext SLIT("and whose type is") <+> ppr tidy_mty])
 466   where
 467     show_ids = filter is_interesting bound_ids
 468     is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
 469
 470     ppr_id id ty     = ppr id <+> dcolon <+> ppr ty
 471         -- Don't zonk the types so we get the separate, un-unified versions
 472 \end{code}