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, tcStmts, tcGRHSs ) where
   8
   9 #include "HsVersions.h"
  10
  11 import {-# SOURCE #-}   TcExpr( tcExpr )
  12
  13 import HsSyn            ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
  14                           MonoBinds(..), StmtCtxt(..), Stmt(..),
  15                           pprMatch, getMatchLoc, consLetStmt,
  16                           mkMonoBind, collectSigTysFromPats
  17                         )
  18 import RnHsSyn          ( RenamedMatch, RenamedGRHSs, RenamedStmt )
  19 import TcHsSyn          ( TcMatch, TcGRHSs, TcStmt )
  20
  21 import TcMonad
  22 import TcMonoType       ( kcHsSigType, tcTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
  23 import Inst             ( LIE, plusLIE, emptyLIE, plusLIEs )
  24 import TcEnv            ( TcId, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars )
  25 import TcPat            ( tcPat, tcPatBndr_NoSigs, polyPatSig )
  26 import TcType           ( TcType, newTyVarTy )
  27 import TcBinds          ( tcBindsAndThen )
  28 import TcSimplify       ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
  29 import TcUnify          ( unifyFunTy, unifyTauTy, unifyListTy )
  30 import Name             ( Name )
  31 import TysWiredIn       ( boolTy )
  32
  33 import BasicTypes       ( RecFlag(..) )
  34 import Type             ( tyVarsOfType, isTauTy, mkArrowKind, mkAppTy, mkFunTy,
  35                           boxedTypeKind, openTypeKind )
  36 import SrcLoc           ( SrcLoc )
  37 import VarSet
  38 import Var              ( Id )
  39 import Bag
  40 import Outputable
  41 import List             ( nub )
  42 \end{code}
  43
  44 %************************************************************************
  45 %*                                                                      *
  46 \subsection{tcMatchesFun, tcMatchesCase}
  47 %*                                                                      *
  48 %************************************************************************
  49
  50 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
  51 @FunMonoBind@.  The second argument is the name of the function, which
  52 is used in error messages.  It checks that all the equations have the
  53 same number of arguments before using @tcMatches@ to do the work.
  54
  55 \begin{code}
  56 tcMatchesFun :: [(Name,Id)]     -- Bindings for the variables bound in this group
  57              -> Name
  58              -> TcType          -- Expected type
  59              -> [RenamedMatch]
  60              -> TcM ([TcMatch], LIE)
  61
  62 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
  63   =      -- Check that they all have the same no of arguments
  64          -- Set the location to that of the first equation, so that
  65          -- any inter-equation error messages get some vaguely
  66          -- sensible location.  Note: we have to do this odd
  67          -- ann-grabbing, because we don't always have annotations in
  68          -- hand when we call tcMatchesFun...
  69     tcAddSrcLoc (getMatchLoc first_match)        (
  70             checkTc (sameNoOfArgs matches)
  71                     (varyingArgsErr fun_name matches)
  72     )                                            `thenTc_`
  73
  74         -- ToDo: Don't use "expected" stuff if there ain't a type signature
  75         -- because inconsistency between branches
  76         -- may show up as something wrong with the (non-existent) type signature
  77
  78         -- No need to zonk expected_ty, because unifyFunTy does that on the fly
  79     tcMatches xve matches expected_ty (FunRhs fun_name)
  80 \end{code}
  81
  82 @tcMatchesCase@ doesn't do the argument-count check because the
  83 parser guarantees that each equation has exactly one argument.
  84
  85 \begin{code}
  86 tcMatchesCase :: [RenamedMatch]         -- The case alternatives
  87               -> TcType                 -- Type of whole case expressions
  88               -> TcM (TcType,           -- Inferred type of the scrutinee
  89                         [TcMatch],      -- Translated alternatives
  90                         LIE)
  91
  92 tcMatchesCase matches expr_ty
  93   = newTyVarTy openTypeKind                                     `thenNF_Tc` \ scrut_ty ->
  94     tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt     `thenTc` \ (matches', lie) ->
  95     returnTc (scrut_ty, matches', lie)
  96
  97 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
  98 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
  99 \end{code}
 100
 101
 102 \begin{code}
 103 tcMatches :: [(Name,Id)]
 104           -> [RenamedMatch]
 105           -> TcType
 106           -> StmtCtxt
 107           -> TcM ([TcMatch], LIE)
 108
 109 tcMatches xve matches expected_ty fun_or_case
 110   = mapAndUnzipTc tc_match matches      `thenTc` \ (matches, lies) ->
 111     returnTc (matches, plusLIEs lies)
 112   where
 113     tc_match match = tcMatch xve match expected_ty fun_or_case
 114 \end{code}
 115
 116
 117 %************************************************************************
 118 %*                                                                      *
 119 \subsection{tcMatch}
 120 %*                                                                      *
 121 %************************************************************************
 122
 123 \begin{code}
 124 tcMatch :: [(Name,Id)]
 125         -> RenamedMatch
 126         -> TcType               -- Expected result-type of the Match.
 127                                 -- Early unification with this guy gives better error messages
 128         -> StmtCtxt
 129         -> TcM (TcMatch, LIE)
 130
 131 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
 132   = tcAddSrcLoc (getMatchLoc match)             $
 133     tcAddErrCtxt (matchCtxt ctxt match)         $
 134
 135     if null sig_tvs then        -- The common case
 136         tc_match expected_ty    `thenTc` \ (_, match_and_lie) ->
 137         returnTc match_and_lie
 138
 139     else
 140         -- If there are sig tvs we must be careful *not* to use
 141         -- expected_ty right away, else we'll unify with tyvars free
 142         -- in the envt.  So invent a fresh tyvar and use that instead
 143         newTyVarTy openTypeKind                                 `thenNF_Tc` \ tyvar_ty ->
 144
 145         -- Extend the tyvar env and check the match itself
 146         tcTyVars sig_tvs (mapTc_ kcHsSigType sig_tys)           `thenTc` \ sig_tyvars ->
 147         tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty)         `thenTc` \ (pat_ids, match_and_lie) ->
 148
 149         -- Check that the scoped type variables from the patterns
 150         -- have not been constrained
 151         tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids)           (
 152                 checkSigTyVars sig_tyvars emptyVarSet
 153         )                                                       `thenTc_`
 154
 155         -- *Now* we're free to unify with expected_ty
 156         unifyTauTy expected_ty tyvar_ty `thenTc_`
 157
 158         returnTc match_and_lie
 159
 160   where
 161     sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
 162               ++ collectSigTysFromPats pats
 163
 164     tc_match expected_ty        -- Any sig tyvars are in scope by now
 165       = -- STEP 1: Typecheck the patterns
 166         tcMatchPats pats expected_ty    `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
 167         let
 168           xve2       = bagToList pat_bndrs
 169           pat_ids    = map snd xve2
 170           ex_tv_list = bagToList ex_tvs
 171         in
 172
 173         -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
 174         -- If it is it'll mess up the unifier when checking the RHS
 175         checkTc (isTauTy rhs_ty) lurkingRank2SigErr             `thenTc_`
 176
 177         -- STEP 3: Unify with the rhs type signature if any
 178         (case maybe_rhs_sig of
 179             Nothing  -> returnTc ()
 180             Just sig -> tcHsSigType sig         `thenTc` \ sig_ty ->
 181
 182                         -- Check that the signature isn't a polymorphic one, which
 183                         -- we don't permit (at present, anyway)
 184                         checkTc (isTauTy sig_ty) (polyPatSig sig_ty)    `thenTc_`
 185                         unifyTauTy rhs_ty sig_ty
 186         )                                               `thenTc_`
 187
 188         -- STEP 4: Typecheck the guarded RHSs and the associated where clause
 189         tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
 190             tcGRHSs grhss rhs_ty ctxt
 191         ))                                      `thenTc` \ (grhss', lie_req2) ->
 192
 193         -- STEP 5: Check for existentially bound type variables
 194         tcExtendGlobalTyVars (tyVarsOfType rhs_ty)      (
 195             tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids)       $
 196             checkSigTyVars ex_tv_list emptyVarSet               `thenTc` \ zonked_ex_tvs ->
 197             tcSimplifyAndCheck
 198                 (text ("the existential context of a data constructor"))
 199                 (mkVarSet zonked_ex_tvs)
 200                 lie_avail (lie_req1 `plusLIE` lie_req2)
 201         )                                                       `thenTc` \ (lie_req', ex_binds) ->
 202
 203         -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
 204         -- (which can happen in the case of rank-2 type signatures, or data constructors
 205         -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
 206         bindInstsOfLocalFuns lie_req' pat_ids           `thenTc` \ (lie_req'', inst_binds) ->
 207
 208         -- Phew!  All done.
 209         let
 210             grhss'' = glue_on Recursive ex_binds $
 211                       glue_on Recursive inst_binds grhss'
 212         in
 213         returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
 214
 215         -- glue_on just avoids stupid dross
 216 glue_on _ EmptyMonoBinds grhss = grhss          -- The common case
 217 glue_on is_rec mbinds (GRHSs grhss binds ty)
 218   = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
 219
 220 tcGRHSs :: RenamedGRHSs
 221         -> TcType -> StmtCtxt
 222         -> TcM (TcGRHSs, LIE)
 223
 224 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
 225   = tcBindsAndThen glue_on binds (tc_grhss grhss)
 226   where
 227     tc_grhss grhss
 228         = mapAndUnzipTc tc_grhs grhss       `thenTc` \ (grhss', lies) ->
 229           returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
 230
 231     tc_grhs (GRHS guarded locn)
 232         = tcAddSrcLoc locn                              $
 233           tcStmts ctxt (\ty -> ty) expected_ty locn guarded
 234                                             `thenTc` \ ((guarded', _), lie) ->
 235           returnTc (GRHS guarded' locn, lie)
 236 \end{code}
 237
 238
 239 %************************************************************************
 240 %*                                                                      *
 241 \subsection{tcMatchPats}
 242 %*                                                                      *
 243 %************************************************************************
 244
 245 \begin{code}
 246 tcMatchPats [] expected_ty
 247   = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
 248
 249 tcMatchPats (pat:pats) expected_ty
 250   = unifyFunTy expected_ty              `thenTc` \ (arg_ty, rest_ty) ->
 251     tcPat tcPatBndr_NoSigs pat arg_ty   `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
 252     tcMatchPats pats rest_ty            `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
 253     returnTc (  rhs_ty,
 254                 pat':pats',
 255                 lie_req `plusLIE` lie_reqs,
 256                 pat_tvs `unionBags` pats_tvs,
 257                 pat_ids `unionBags` pats_ids,
 258                 lie_avail `plusLIE` lie_avails
 259     )
 260 \end{code}
 261
 262
 263 %************************************************************************
 264 %*                                                                      *
 265 \subsection{tcStmts}
 266 %*                                                                      *
 267 %************************************************************************
 268
 269
 270 \begin{code}
 271 tcParStep src_loc stmts
 272   = newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenTc` \ m ->
 273     newTyVarTy boxedTypeKind                             `thenTc` \ elt_ty ->
 274     unifyListTy (mkAppTy m elt_ty)                       `thenTc_`
 275
 276     tcStmts ListComp (mkAppTy m) elt_ty src_loc stmts    `thenTc` \ ((stmts', val_env), stmts_lie) ->
 277     returnTc (stmts', val_env, stmts_lie)
 278
 279 tcStmts :: StmtCtxt
 280         -> (TcType -> TcType)           -- m, the relationship type of pat and rhs in pat <- rhs
 281         -> TcType                       -- elt_ty, where type of the comprehension is (m elt_ty)
 282         -> SrcLoc
 283         -> [RenamedStmt]
 284         -> TcM (([TcStmt], [(Name, TcId)]), LIE)
 285
 286 tcStmts do_or_lc m elt_ty loc (ParStmtOut bndrstmtss : stmts)
 287   = let (bndrss, stmtss) = unzip bndrstmtss in
 288     mapAndUnzip3Tc (tcParStep loc) stmtss       `thenTc` \ (stmtss', val_envs, lies) ->
 289     let outstmts = zip (map (map snd) val_envs) stmtss'
 290         lie = plusLIEs lies
 291         new_val_env = concat val_envs
 292     in
 293     tcExtendLocalValEnv new_val_env (
 294         tcStmts do_or_lc m elt_ty loc stmts)    `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
 295     returnTc ((ParStmtOut outstmts : stmts', rest_val_env ++ new_val_env), lie `plusLIE` stmts_lie)
 296
 297 tcStmts do_or_lc m elt_ty loc (stmt@(ReturnStmt exp) : stmts)
 298   = ASSERT( null stmts )
 299     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 300     tcExpr exp elt_ty                           `thenTc`    \ (exp', exp_lie) ->
 301     returnTc (([ReturnStmt exp'], []), exp_lie)
 302
 303         -- ExprStmt at the end
 304 tcStmts do_or_lc m elt_ty loc [stmt@(ExprStmt exp src_loc)]
 305   = tcSetErrCtxt (stmtCtxt do_or_lc stmt)       $
 306     tcExpr exp (m elt_ty)                       `thenTc`    \ (exp', exp_lie) ->
 307     returnTc (([ExprStmt exp' src_loc], []), exp_lie)
 308
 309         -- ExprStmt not at the end
 310 tcStmts do_or_lc m elt_ty loc (stmt@(ExprStmt exp src_loc) : stmts)
 311   = ASSERT( isDoStmt do_or_lc )
 312     tcAddSrcLoc src_loc                 (
 313         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 314             -- exp has type (m tau) for some tau (doesn't matter what)
 315         newTyVarTy openTypeKind         `thenNF_Tc` \ any_ty ->
 316         tcExpr exp (m any_ty)
 317     )                                   `thenTc` \ (exp', exp_lie) ->
 318     tcStmts do_or_lc m elt_ty loc stmts `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
 319     returnTc ((ExprStmt exp' src_loc : stmts', rest_val_env),
 320               exp_lie `plusLIE` stmts_lie)
 321
 322 tcStmts do_or_lc m elt_ty loc (stmt@(GuardStmt exp src_loc) : stmts)
 323   = ASSERT( not (isDoStmt do_or_lc) )
 324     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 325         tcAddSrcLoc src_loc             $
 326         tcExpr exp boolTy
 327     )                                   `thenTc` \ (exp', exp_lie) ->
 328     tcStmts do_or_lc m elt_ty loc stmts `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
 329     -- ZZ is this right?
 330     returnTc ((GuardStmt exp' src_loc : stmts', rest_val_env),
 331               exp_lie `plusLIE` stmts_lie)
 332
 333 tcStmts do_or_lc m elt_ty loc (stmt@(BindStmt pat exp src_loc) : stmts)
 334   = tcAddSrcLoc src_loc         (
 335         tcSetErrCtxt (stmtCtxt do_or_lc stmt)   $
 336         newTyVarTy boxedTypeKind                `thenNF_Tc` \ pat_ty ->
 337         tcPat tcPatBndr_NoSigs pat pat_ty       `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
 338         tcExpr exp (m pat_ty)                   `thenTc` \ (exp', exp_lie) ->
 339         returnTc (pat', exp',
 340                   pat_lie `plusLIE` exp_lie,
 341                   pat_tvs, pat_ids, avail)
 342     )                                   `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
 343     let
 344         new_val_env = bagToList pat_bndrs
 345         pat_ids     = map snd new_val_env
 346         pat_tv_list = bagToList pat_tvs
 347     in
 348
 349         -- Do the rest; we don't need to add the pat_tvs to the envt
 350         -- because they all appear in the pat_ids's types
 351     tcExtendLocalValEnv new_val_env (
 352        tcStmts do_or_lc m elt_ty loc stmts
 353     )                                           `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
 354
 355
 356         -- Reinstate context for existential checks
 357     tcSetErrCtxt (stmtCtxt do_or_lc stmt)               $
 358     tcExtendGlobalTyVars (tyVarsOfType (m elt_ty))      $
 359     tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids)      $
 360
 361     checkSigTyVars pat_tv_list emptyVarSet              `thenTc` \ zonked_pat_tvs ->
 362
 363     tcSimplifyAndCheck
 364         (text ("the existential context of a data constructor"))
 365         (mkVarSet zonked_pat_tvs)
 366         lie_avail stmts_lie                     `thenTc` \ (final_lie, dict_binds) ->
 367
 368     -- ZZ we have to be sure that concating the val_env lists preserves
 369     -- shadowing properly...
 370     returnTc ((BindStmt pat' exp' src_loc :
 371                  consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
 372                rest_val_env ++ new_val_env),
 373               lie_req `plusLIE` final_lie)
 374
 375 tcStmts do_or_lc m elt_ty loc (LetStmt binds : stmts)
 376      = tcBindsAndThen           -- No error context, but a binding group is
 377         combine                 -- rather a large thing for an error context anyway
 378         binds
 379         (tcStmts do_or_lc m elt_ty loc stmts) `thenTc` \ ((stmts', rest_val_env), lie) ->
 380        -- ZZ fix val_env
 381        returnTc ((stmts', rest_val_env), lie)
 382      where
 383         combine is_rec binds' (stmts', val_env) = (consLetStmt (mkMonoBind binds' [] is_rec) stmts', undefined)
 384
 385 tcStmts do_or_lc m elt_ty loc [] = returnTc (([], []), emptyLIE)
 386
 387 isDoStmt DoStmt = True
 388 isDoStmt other  = False
 389 \end{code}
 390
 391
 392 %************************************************************************
 393 %*                                                                      *
 394 \subsection{Errors and contexts}
 395 %*                                                                      *
 396 %************************************************************************
 397
 398 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 399 number of args are used in each equation.
 400
 401 \begin{code}
 402 sameNoOfArgs :: [RenamedMatch] -> Bool
 403 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
 404   where
 405     args_in_match :: RenamedMatch -> Int
 406     args_in_match (Match _ pats _ _) = length pats
 407 \end{code}
 408
 409 \begin{code}
 410 matchCtxt CaseAlt match
 411   = hang (ptext SLIT("In a case alternative:"))
 412          4 (pprMatch (True,empty) {-is_case-} match)
 413
 414 matchCtxt (FunRhs fun) match
 415   = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
 416          4 (pprMatch (False, ppr_fun) {-not case-} match)
 417   where
 418     ppr_fun = ppr fun
 419
 420 matchCtxt LambdaBody match
 421   = hang (ptext SLIT("In the lambda expression"))
 422          4 (pprMatch (True, empty) match)
 423
 424 varyingArgsErr name matches
 425   = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
 426
 427 lurkingRank2SigErr
 428   = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
 429
 430 stmtCtxt do_or_lc stmt
 431   = hang (ptext SLIT("In") <+> what <> colon)
 432          4 (ppr stmt)
 433   where
 434     what = case do_or_lc of
 435                 ListComp -> ptext SLIT("a list-comprehension qualifier")
 436                 DoStmt   -> ptext SLIT("a do statement")
 437                 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
 438                 FunRhs f   -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
 439                 CaseAlt    -> thing <+> ptext SLIT("a case alternative")
 440                 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
 441     thing = case stmt of
 442                 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
 443                 GuardStmt _ _  -> ptext SLIT("a guard for")
 444                 ExprStmt _ _   -> ptext SLIT("the right-hand side of")
 445 \end{code}