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