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