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