2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, tcStmts, tcGRHSs ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} TcExpr( tcExpr )
13 import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
14 MonoBinds(..), StmtCtxt(..), Stmt(..),
15 pprMatch, getMatchLoc, consLetStmt,
16 mkMonoBind, collectSigTysFromPats
18 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
19 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
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 )
31 import TysWiredIn ( boolTy )
33 import BasicTypes ( RecFlag(..) )
34 import Type ( tyVarsOfType, isTauTy, mkArrowKind, mkAppTy, mkFunTy,
35 boxedTypeKind, openTypeKind )
36 import SrcLoc ( SrcLoc )
44 %************************************************************************
46 \subsection{tcMatchesFun, tcMatchesCase}
48 %************************************************************************
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.
56 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
58 -> TcType -- Expected type
60 -> TcM ([TcMatch], LIE)
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)
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
78 -- No need to zonk expected_ty, because unifyFunTy does that on the fly
79 tcMatches xve matches expected_ty (FunRhs fun_name)
82 @tcMatchesCase@ doesn't do the argument-count check because the
83 parser guarantees that each equation has exactly one argument.
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
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)
97 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
98 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
103 tcMatches :: [(Name,Id)]
107 -> TcM ([TcMatch], LIE)
109 tcMatches xve matches expected_ty fun_or_case
110 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
111 returnTc (matches, plusLIEs lies)
113 tc_match match = tcMatch xve match expected_ty fun_or_case
117 %************************************************************************
121 %************************************************************************
124 tcMatch :: [(Name,Id)]
126 -> TcType -- Expected result-type of the Match.
127 -- Early unification with this guy gives better error messages
129 -> TcM (TcMatch, LIE)
131 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
132 = tcAddSrcLoc (getMatchLoc match) $
133 tcAddErrCtxt (matchCtxt ctxt match) $
135 if null sig_tvs then -- The common case
136 tc_match expected_ty `thenTc` \ (_, match_and_lie) ->
137 returnTc match_and_lie
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 ->
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) ->
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
155 -- *Now* we're free to unify with expected_ty
156 unifyTauTy expected_ty tyvar_ty `thenTc_`
158 returnTc match_and_lie
161 sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
162 ++ collectSigTysFromPats pats
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) ->
168 xve2 = bagToList pat_bndrs
169 pat_ids = map snd xve2
170 ex_tv_list = bagToList ex_tvs
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_`
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 ->
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
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) ->
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 ->
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) ->
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) ->
210 grhss'' = glue_on Recursive ex_binds $
211 glue_on Recursive inst_binds grhss'
213 returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
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
220 tcGRHSs :: RenamedGRHSs
221 -> TcType -> StmtCtxt
222 -> TcM (TcGRHSs, LIE)
224 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
225 = tcBindsAndThen glue_on binds (tc_grhss grhss)
228 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
229 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
231 tc_grhs (GRHS guarded locn)
233 tcStmts ctxt (\ty -> ty) expected_ty locn guarded
234 `thenTc` \ ((guarded', _), lie) ->
235 returnTc (GRHS guarded' locn, lie)
239 %************************************************************************
241 \subsection{tcMatchPats}
243 %************************************************************************
246 tcMatchPats [] expected_ty
247 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
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) ->
255 lie_req `plusLIE` lie_reqs,
256 pat_tvs `unionBags` pats_tvs,
257 pat_ids `unionBags` pats_ids,
258 lie_avail `plusLIE` lie_avails
263 %************************************************************************
267 %************************************************************************
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_`
276 tcStmts ListComp (mkAppTy m) elt_ty src_loc stmts `thenTc` \ ((stmts', val_env), stmts_lie) ->
277 returnTc (stmts', val_env, stmts_lie)
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)
284 -> TcM (([TcStmt], [(Name, TcId)]), LIE)
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'
291 new_val_env = concat val_envs
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)
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)
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)
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)
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 $
327 ) `thenTc` \ (exp', exp_lie) ->
328 tcStmts do_or_lc m elt_ty loc stmts `thenTc` \ ((stmts', rest_val_env), stmts_lie) ->
330 returnTc ((GuardStmt exp' src_loc : stmts', rest_val_env),
331 exp_lie `plusLIE` stmts_lie)
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) ->
344 new_val_env = bagToList pat_bndrs
345 pat_ids = map snd new_val_env
346 pat_tv_list = bagToList pat_tvs
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) ->
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) $
361 checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs ->
364 (text ("the existential context of a data constructor"))
365 (mkVarSet zonked_pat_tvs)
366 lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
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)
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
379 (tcStmts do_or_lc m elt_ty loc stmts) `thenTc` \ ((stmts', rest_val_env), lie) ->
381 returnTc ((stmts', rest_val_env), lie)
383 combine is_rec binds' (stmts', val_env) = (consLetStmt (mkMonoBind binds' [] is_rec) stmts', undefined)
385 tcStmts do_or_lc m elt_ty loc [] = returnTc (([], []), emptyLIE)
387 isDoStmt DoStmt = True
388 isDoStmt other = False
392 %************************************************************************
394 \subsection{Errors and contexts}
396 %************************************************************************
398 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
399 number of args are used in each equation.
402 sameNoOfArgs :: [RenamedMatch] -> Bool
403 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
405 args_in_match :: RenamedMatch -> Int
406 args_in_match (Match _ pats _ _) = length pats
410 matchCtxt CaseAlt match
411 = hang (ptext SLIT("In a case alternative:"))
412 4 (pprMatch (True,empty) {-is_case-} match)
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)
420 matchCtxt LambdaBody match
421 = hang (ptext SLIT("In the lambda expression"))
422 4 (pprMatch (True, empty) match)
424 varyingArgsErr name matches
425 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
428 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
430 stmtCtxt do_or_lc stmt
431 = hang (ptext SLIT("In") <+> what <> colon)
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")
442 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
443 GuardStmt _ _ -> ptext SLIT("a guard for")
444 ExprStmt _ _ -> ptext SLIT("the right-hand side of")