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, 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 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         -- STEP 4: Check for existentially bound type variables
 223         -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
 224         -- might need (via lie_req2) something made available from an 'outer'
 225         -- pattern.  But it's inconvenient to deal with, and I can't find an example
 226     tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req2 rhs_ty      `thenTc` \ (lie_req2', ex_binds) ->
 227
 228     returnTc (result, lie_req1 `plusLIE` lie_req2', ex_binds)
 229
 230 tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
 231 -- Find the not-already-in-scope signature type variables,
 232 -- kind-check them, and bring them into scope
 233 --
 234 -- We no longer specify that these type variables must be univerally
 235 -- quantified (lots of email on the subject).  If you want to put that
 236 -- back in, you need to
 237 --      a) Do a checkSigTyVars after thing_inside
 238 --      b) More insidiously, don't pass in expected_ty, else
 239 --         we unify with it too early and checkSigTyVars barfs
 240 --         Instead you have to pass in a fresh ty var, and unify
 241 --         it with expected_ty afterwards
 242 tcAddScopedTyVars sig_tys thing_inside
 243   = tcGetEnv                                    `thenNF_Tc` \ env ->
 244     let
 245         all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
 246         sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
 247         not_in_scope tv = not (tcInLocalScope env tv)
 248     in
 249     tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) thing_inside
 250
 251 tcCheckExistentialPat :: [TcId]         -- Ids bound by this pattern
 252                       -> Bag TcTyVar    -- Existentially quantified tyvars bound by pattern
 253                       -> LIE            --   and context
 254                       -> LIE            -- Required context
 255                       -> TcType         --   and result type; vars in here must not escape
 256                       -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
 257 tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
 258   | isEmptyBag ex_tvs && all not_overloaded ids
 259         -- Short cut for case when there are no existentials
 260         -- and no polymorphic overloaded variables
 261         --  e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
 262         --       f op x = ....
 263         --  Here we must discharge op Methods
 264   = ASSERT( isEmptyLIE lie_avail )
 265     returnTc (lie_req, EmptyMonoBinds)
 266
 267   | otherwise
 268   = tcExtendGlobalTyVars (tyVarsOfType result_ty)               $
 269     tcAddErrCtxtM (sigPatCtxt tv_list ids)                      $
 270
 271         -- In case there are any polymorpic, overloaded binders in the pattern
 272         -- (which can happen in the case of rank-2 type signatures, or data constructors
 273         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 274     bindInstsOfLocalFuns lie_req ids                            `thenTc` \ (lie1, inst_binds) ->
 275
 276         -- Deal with overloaded functions bound by the pattern
 277     tcSimplifyCheck doc tv_list
 278                     (lieToList lie_avail) lie1          `thenTc` \ (lie2, dict_binds) ->
 279     checkSigTyVars tv_list emptyVarSet                          `thenTc_`
 280
 281     returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
 282   where
 283     doc     = text ("the existential context of a data constructor")
 284     tv_list = bagToList ex_tvs
 285     not_overloaded id = not (isOverloadedTy (idType id))
 286
 287 tc_match_pats [] expected_ty
 288   = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
 289
 290 tc_match_pats (pat:pats) expected_ty
 291   = unifyFunTy expected_ty              `thenTc` \ (arg_ty, rest_ty) ->
 292     tcPat tcMonoPatBndr pat arg_ty      `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
 293     tc_match_pats pats rest_ty          `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
 294     returnTc (  rhs_ty,
 295                 pat':pats',
 296                 lie_req `plusLIE` lie_reqs,
 297                 pat_tvs `unionBags` pats_tvs,
 298                 pat_ids `unionBags` pats_ids,
 299                 lie_avail `plusLIE` lie_avails
 300     )
 301 \end{code}
 302
 303
 304 %************************************************************************
 305 %*                                                                      *
 306 \subsection{tcStmts}
 307 %*                                                                      *
 308 %************************************************************************
 309
 310 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
 311
 312         [ (g x, h x) | ... ; let g v = ...
 313                      | ... ; let h v = ... ]
 314
 315 It's possible that g,h are overloaded, so we need to feed the LIE from the
 316 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
 317 Similarly if we had an existential pattern match:
 318
 319         data T = forall a. Show a => C a
 320
 321         [ (show x, show y) | ... ; C x <- ...
 322                            | ... ; C y <- ... ]
 323
 324 Then we need the LIE from (show x, show y) to be simplified against
 325 the bindings for x and y.
 326
 327 It's difficult to do this in parallel, so we rely on the renamer to
 328 ensure that g,h and x,y don't duplicate, and simply grow the environment.
 329 So the binders of the first parallel group will be in scope in the second
 330 group.  But that's fine; there's no shadowing to worry about.
 331
 332 \begin{code}
 333 tcStmts do_or_lc m_ty stmts
 334   = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
 335
 336 tcStmtsAndThen
 337         :: (TcStmt -> thing -> thing)   -- Combiner
 338         -> RenamedMatchContext
 339         -> (TcType -> TcType, TcType)   -- m, the relationship type of pat and rhs in pat <- rhs
 340                                         -- elt_ty, where type of the comprehension is (m elt_ty)
 341         -> [RenamedStmt]
 342         -> TcM (thing, LIE)
 343         -> TcM (thing, LIE)
 344
 345         -- Base case
 346 tcStmtsAndThen combine do_or_lc m_ty [] do_next
 347   = do_next
 348
 349 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
 350   = tcStmtAndThen combine do_or_lc m_ty stmt
 351         (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
 352
 353         -- LetStmt
 354 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
 355   = tcBindsAndThen              -- No error context, but a binding group is
 356         (glue_binds combine)    -- rather a large thing for an error context anyway
 357         binds
 358         thing_inside
 359
 360 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
 361   = tcAddSrcLoc src_loc                                 $
 362     tcAddErrCtxt (stmtCtxt do_or_lc stmt)               $
 363     newTyVarTy liftedTypeKind                           `thenNF_Tc` \ pat_ty ->
 364     tcExpr exp (m pat_ty)                               `thenTc` \ (exp', exp_lie) ->
 365     tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty))       (\ [pat'] _ ->
 366         tcPopErrCtxt                            $
 367         thing_inside                            `thenTc` \ (thing, lie) ->
 368         returnTc ((BindStmt pat' exp' src_loc, thing), lie)
 369     )                                                   `thenTc` \ ((stmt', thing), lie, dict_binds) ->
 370     returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
 371               lie `plusLIE` exp_lie)
 372
 373
 374         -- ParStmt
 375 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
 376   = loop bndr_stmts_s           `thenTc` \ ((pairs', thing), lie) ->
 377     returnTc (combine (ParStmtOut pairs') thing, lie)
 378   where
 379     loop []
 380       = thing_inside                            `thenTc` \ (thing, stmts_lie) ->
 381         returnTc (([], thing), stmts_lie)
 382
 383     loop ((bndrs,stmts) : pairs)
 384       = tcStmtsAndThen
 385                 combine_par (DoCtxt ListComp) m_ty stmts
 386                         -- Notice we pass on m_ty; the result type is used only
 387                         -- to get escaping type variables for checkExistentialPat
 388                 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
 389                  loop pairs             `thenTc` \ ((pairs', thing), lie) ->
 390                  returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
 391
 392         returnTc ( ((bndrs',stmts') : pairs', thing), lie)
 393
 394     combine_par stmt (stmts, thing) = (stmt:stmts, thing)
 395
 396         -- ExprStmt
 397 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
 398   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 399         if isDoExpr do_or_lc then
 400                 newTyVarTy openTypeKind         `thenNF_Tc` \ any_ty ->
 401                 tcExpr exp (m any_ty)           `thenNF_Tc` \ (exp', lie) ->
 402                 returnTc (ExprStmt exp' any_ty locn, lie)
 403         else
 404                 tcExpr exp boolTy               `thenNF_Tc` \ (exp', lie) ->
 405                 returnTc (ExprStmt exp' boolTy locn, lie)
 406     )                                           `thenTc` \ (stmt', stmt_lie) ->
 407
 408     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 409
 410     returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
 411
 412
 413         -- Result statements
 414 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
 415   = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 416         if isDoExpr do_or_lc then
 417                 tcExpr exp (m res_elt_ty)
 418         else
 419                 tcExpr exp res_elt_ty
 420     )                                           `thenTc` \ (exp', stmt_lie) ->
 421
 422     thing_inside                                `thenTc` \ (thing, stmts_lie) ->
 423
 424     returnTc (combine (ResultStmt exp' locn) thing,
 425               stmt_lie `plusLIE` stmts_lie)
 426
 427
 428 ------------------------------
 429 glue_binds combine is_rec binds thing
 430   | nullMonoBinds binds = thing
 431   | otherwise           = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
 432 \end{code}
 433
 434
 435 %************************************************************************
 436 %*                                                                      *
 437 \subsection{Errors and contexts}
 438 %*                                                                      *
 439 %************************************************************************
 440
 441 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 442 number of args are used in each equation.
 443
 444 \begin{code}
 445 sameNoOfArgs :: [RenamedMatch] -> Bool
 446 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
 447   where
 448     args_in_match :: RenamedMatch -> Int
 449     args_in_match (Match _ pats _ _) = length pats
 450 \end{code}
 451
 452 \begin{code}
 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 varyingArgsErr name matches
 457   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 458
 459 lurkingRank2SigErr
 460   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 461 \end{code}