2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda,
8 tcStmts, tcStmtsAndThen, tcGRHSs
11 #include "HsVersions.h"
13 import {-# SOURCE #-} TcExpr( tcMonoExpr )
15 import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
16 MonoBinds(..), Stmt(..), HsMatchContext(..), HsDoContext(..),
17 pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
18 mkMonoBind, nullMonoBinds, collectSigTysFromPats
20 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedMatchContext )
21 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
24 import TcMonoType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) )
25 import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
26 import TcEnv ( TcId, tcLookupLocalIds, tcExtendLocalValEnv2 )
27 import TcPat ( tcPat, tcMonoPatBndr )
28 import TcMType ( newTyVarTy, zonkTcType, zapToType )
29 import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
30 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
31 import TcBinds ( tcBindsAndThen )
32 import TcUnify ( subFunTy, checkSigTyVarsWrt, tcSubExp, isIdCoercion, (<$>) )
33 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
35 import TysWiredIn ( boolTy )
37 import CoreFVs ( idFreeTyVars )
38 import BasicTypes ( RecFlag(..) )
42 import Util ( isSingleton, lengthExceeds )
48 %************************************************************************
50 \subsection{tcMatchesFun, tcMatchesCase}
52 %************************************************************************
54 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
55 @FunMonoBind@. The second argument is the name of the function, which
56 is used in error messages. It checks that all the equations have the
57 same number of arguments before using @tcMatches@ to do the work.
60 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
62 -> TcType -- Expected type
64 -> TcM ([TcMatch], LIE)
66 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
67 = -- Check that they all have the same no of arguments
68 -- Set the location to that of the first equation, so that
69 -- any inter-equation error messages get some vaguely
70 -- sensible location. Note: we have to do this odd
71 -- ann-grabbing, because we don't always have annotations in
72 -- hand when we call tcMatchesFun...
73 tcAddSrcLoc (getMatchLoc first_match) (
74 checkTc (sameNoOfArgs matches)
75 (varyingArgsErr fun_name matches)
78 -- ToDo: Don't use "expected" stuff if there ain't a type signature
79 -- because inconsistency between branches
80 -- may show up as something wrong with the (non-existent) type signature
82 -- No need to zonk expected_ty, because subFunTy does that on the fly
83 tcMatches xve (FunRhs fun_name) matches expected_ty
86 @tcMatchesCase@ doesn't do the argument-count check because the
87 parser guarantees that each equation has exactly one argument.
90 tcMatchesCase :: [RenamedMatch] -- The case alternatives
91 -> TcType -- Type of whole case expressions
92 -> TcM (TcType, -- Inferred type of the scrutinee
93 [TcMatch], -- Translated alternatives
96 tcMatchesCase matches expr_ty
97 = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
98 tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) ->
99 returnTc (scrut_ty, matches', lie)
101 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
102 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
107 tcMatches :: [(Name,Id)]
108 -> RenamedMatchContext
111 -> TcM ([TcMatch], LIE)
113 tcMatches xve ctxt matches expected_ty
114 = -- If there is more than one branch, and expected_ty is a 'hole',
115 -- all branches must be types, not type schemes, otherwise the
116 -- in which we check them would affect the result.
117 (if lengthExceeds matches 1 then
118 zapToType expected_ty
120 returnNF_Tc expected_ty) `thenNF_Tc` \ expected_ty' ->
122 mapAndUnzipTc (tc_match expected_ty') matches `thenTc` \ (matches, lies) ->
123 returnTc (matches, plusLIEs lies)
125 tc_match expected_ty match = tcMatch xve ctxt match expected_ty
129 %************************************************************************
133 %************************************************************************
136 tcMatch :: [(Name,Id)]
137 -> RenamedMatchContext
139 -> TcType -- Expected result-type of the Match.
140 -- Early unification with this guy gives better error messages
141 -- We regard the Match as having type
142 -- (ty1 -> ... -> tyn -> result_ty)
143 -- where there are n patterns.
144 -> TcM (TcMatch, LIE)
146 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
147 = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
148 tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
149 tcMatchPats pats expected_ty tc_grhss `thenTc` \ (pats', grhss', lie, ex_binds) ->
150 returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
154 = tcExtendLocalValEnv2 xve1 $
156 -- Deal with the result signature
157 case maybe_rhs_sig of
158 Nothing -> tcGRHSs ctxt grhss rhs_ty
160 Just sig -> tcAddScopedTyVars [sig] $
161 -- Bring into scope the type variables in the signature
162 tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
163 tcGRHSs ctxt grhss sig_ty `thenTc` \ (grhss', lie1) ->
164 tcSubExp rhs_ty sig_ty `thenTc` \ (co_fn, lie2) ->
165 returnTc (lift_grhss co_fn rhs_ty grhss',
168 -- lift_grhss pushes the coercion down to the right hand sides,
169 -- because there is no convenient place to hang it otherwise.
170 lift_grhss co_fn rhs_ty grhss
171 | isIdCoercion co_fn = grhss
172 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
173 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since we
175 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
177 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
178 lift_stmt stmt = stmt
180 -- glue_on just avoids stupid dross
181 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
182 glue_on is_rec mbinds (GRHSs grhss binds ty)
183 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
186 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
188 -> TcM (TcGRHSs, LIE)
190 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
191 = tcBindsAndThen glue_on binds (tc_grhss grhss)
194 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
195 returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies)
197 tc_grhs (GRHS guarded locn)
199 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
200 returnTc (GRHS guarded' locn, lie)
204 %************************************************************************
206 \subsection{tcMatchPats}
208 %************************************************************************
212 :: [RenamedPat] -> TcType
213 -> (TcType -> TcM (a, LIE))
214 -> TcM ([TypecheckedPat], a, LIE, TcDictBinds)
215 -- Typecheck the patterns, extend the environment to bind the variables,
216 -- do the thing inside, use any existentially-bound dictionaries to
217 -- discharge parts of the returning LIE, and deal with pattern type
220 tcMatchPats pats expected_ty thing_inside
221 = -- STEP 1: Bring pattern-signature type variables into scope
222 tcAddScopedTyVars (collectSigTysFromPats pats) (
224 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
225 -- then do the thing inside
226 tc_match_pats pats expected_ty thing_inside
228 ) `thenTc` \ (pats', lie_req, ex_tvs, ex_ids, ex_lie, result) ->
230 -- STEP 4: Check for existentially bound type variables
231 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
232 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
234 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
235 -- might need (via lie_req2) something made available from an 'outer'
236 -- pattern. But it's inconvenient to deal with, and I can't find an example
237 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req expected_ty `thenTc` \ (lie_req', ex_binds) ->
238 -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
239 -- For example, we must reject this program:
240 -- data C = forall a. C (a -> Int)
242 -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
244 returnTc (pats', result, lie_req', ex_binds)
246 tc_match_pats [] expected_ty thing_inside
247 = thing_inside expected_ty `thenTc` \ (answer, lie) ->
248 returnTc ([], lie, emptyBag, [], emptyLIE, answer)
250 tc_match_pats (pat:pats) expected_ty thing_inside
251 = subFunTy expected_ty $ \ arg_ty rest_ty ->
252 -- This is the unique place we call subFunTy
253 -- The point is that if expected_y is a "hole", we want
254 -- to make arg_ty and rest_ty as "holes" too.
255 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, ex_tvs, pat_bndrs, ex_lie) ->
257 xve = bagToList pat_bndrs
258 ex_ids = [id | (_, id) <- xve]
259 -- ex_ids is all the pattern-bound Ids, a superset
260 -- of the existential Ids used in checkExistentialPat
262 tcExtendLocalValEnv2 xve $
263 tc_match_pats pats rest_ty thing_inside `thenTc` \ (pats', lie_reqs, exs_tvs, exs_ids, exs_lie, answer) ->
264 returnTc ( pat':pats',
265 lie_req `plusLIE` lie_reqs,
266 ex_tvs `unionBags` exs_tvs,
268 ex_lie `plusLIE` exs_lie,
273 tcCheckExistentialPat :: Bag TcTyVar -- Existentially quantified tyvars bound by pattern
274 -> [TcId] -- Ids bound by this pattern; used
275 -- (a) by bindsInstsOfLocalFuns
276 -- (b) to generate helpful error messages
277 -> LIE -- and context
278 -> LIE -- Required context
279 -> TcType -- and type of the Match; vars in here must not escape
280 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
281 tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req match_ty
282 | isEmptyBag ex_tvs && all not_overloaded ex_ids
283 -- Short cut for case when there are no existentials
284 -- and no polymorphic overloaded variables
285 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
287 -- Here we must discharge op Methods
288 = ASSERT( isEmptyLIE ex_lie )
289 returnTc (lie_req, EmptyMonoBinds)
292 = tcAddErrCtxtM (sigPatCtxt tv_list ex_ids match_ty) $
294 -- In case there are any polymorpic, overloaded binders in the pattern
295 -- (which can happen in the case of rank-2 type signatures, or data constructors
296 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
297 bindInstsOfLocalFuns lie_req ex_ids `thenTc` \ (lie1, inst_binds) ->
299 -- Deal with overloaded functions bound by the pattern
300 tcSimplifyCheck doc tv_list (lieToList ex_lie) lie1 `thenTc` \ (lie2, dict_binds) ->
301 checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenTc_`
303 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
305 doc = text ("the existential context of a data constructor")
306 tv_list = bagToList ex_tvs
307 not_overloaded id = not (isOverloadedTy (idType id))
311 %************************************************************************
315 %************************************************************************
317 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
319 [ (g x, h x) | ... ; let g v = ...
320 | ... ; let h v = ... ]
322 It's possible that g,h are overloaded, so we need to feed the LIE from the
323 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
324 Similarly if we had an existential pattern match:
326 data T = forall a. Show a => C a
328 [ (show x, show y) | ... ; C x <- ...
331 Then we need the LIE from (show x, show y) to be simplified against
332 the bindings for x and y.
334 It's difficult to do this in parallel, so we rely on the renamer to
335 ensure that g,h and x,y don't duplicate, and simply grow the environment.
336 So the binders of the first parallel group will be in scope in the second
337 group. But that's fine; there's no shadowing to worry about.
340 tcStmts do_or_lc m_ty stmts
341 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
344 :: (TcStmt -> thing -> thing) -- Combiner
345 -> RenamedMatchContext
346 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
347 -- elt_ty, where type of the comprehension is (m elt_ty)
353 tcStmtsAndThen combine do_or_lc m_ty [] do_next
356 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
357 = tcStmtAndThen combine do_or_lc m_ty stmt
358 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
361 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
362 = tcBindsAndThen -- No error context, but a binding group is
363 (glue_binds combine) -- rather a large thing for an error context anyway
367 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
368 = tcAddSrcLoc src_loc $
369 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
370 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
371 tcMonoExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
372 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ _ ->
373 tcPopErrCtxt thing_inside
374 ) `thenTc` \ ([pat'], thing, lie, dict_binds) ->
375 returnTc (combine (BindStmt pat' exp' src_loc)
376 (glue_binds combine Recursive dict_binds thing),
377 lie `plusLIE` exp_lie)
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)
386 = thing_inside `thenTc` \ (thing, stmts_lie) ->
387 returnTc (([], thing), stmts_lie)
389 loop ((bndrs,stmts) : pairs)
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) ->
398 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
400 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
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 tcMonoExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
408 returnTc (ExprStmt exp' any_ty locn, lie)
410 tcMonoExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
411 returnTc (ExprStmt exp' boolTy locn, lie)
412 ) `thenTc` \ (stmt', stmt_lie) ->
414 thing_inside `thenTc` \ (thing, stmts_lie) ->
416 returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
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 tcMonoExpr exp (m res_elt_ty)
425 tcMonoExpr exp res_elt_ty
426 ) `thenTc` \ (exp', stmt_lie) ->
428 thing_inside `thenTc` \ (thing, stmts_lie) ->
430 returnTc (combine (ResultStmt exp' locn) thing,
431 stmt_lie `plusLIE` stmts_lie)
434 ------------------------------
435 glue_binds combine is_rec binds thing
436 | nullMonoBinds binds = thing
437 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
441 %************************************************************************
443 \subsection{Errors and contexts}
445 %************************************************************************
447 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
448 number of args are used in each equation.
451 sameNoOfArgs :: [RenamedMatch] -> Bool
452 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
454 args_in_match :: RenamedMatch -> Int
455 args_in_match (Match pats _ _) = length pats
459 varyingArgsErr name matches
460 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
462 matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
463 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
465 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
466 = zonkTcType match_ty `thenNF_Tc` \ match_ty' ->
468 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
469 (env2, tidy_mty) = tidyOpenType env1 match_ty'
472 sep [ptext SLIT("When checking an existential match that binds"),
473 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
474 ptext SLIT("and whose type is") <+> ppr tidy_mty])
476 show_ids = filter is_interesting bound_ids
477 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
479 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
480 -- Don't zonk the types so we get the separate, un-unified versions