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 )
29 import TcType ( TcType, TcTyVar, tyVarsOfType, tidyOpenTypes, tidyOpenType,
30 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
31 import TcBinds ( tcBindsAndThen )
32 import TcUnify ( subFunTy, checkSigTyVarsWrt, tcSub, isIdCoercion, (<$>) )
33 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
35 import TysWiredIn ( boolTy )
37 import CoreFVs ( idFreeTyVars )
38 import BasicTypes ( RecFlag(..) )
42 import Util ( isSingleton )
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 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
115 returnTc (matches, plusLIEs lies)
117 tc_match match = tcMatch xve ctxt match expected_ty
121 %************************************************************************
125 %************************************************************************
128 tcMatch :: [(Name,Id)]
129 -> RenamedMatchContext
131 -> TcType -- Expected result-type of the Match.
132 -- Early unification with this guy gives better error messages
133 -- We regard the Match as having type
134 -- (ty1 -> ... -> tyn -> result_ty)
135 -- where there are n patterns.
136 -> TcM (TcMatch, LIE)
138 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
139 = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
140 tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
142 tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
143 returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
146 tc_grhss pats' rhs_ty
147 = tcExtendLocalValEnv2 xve1 $
149 -- Deal with the result signature
150 case maybe_rhs_sig of
151 Nothing -> tcGRHSs ctxt grhss rhs_ty `thenTc` \ (grhss', lie) ->
152 returnTc ((pats', grhss'), lie)
154 Just sig -> tcAddScopedTyVars [sig] $
155 -- Bring into scope the type variables in the signature
156 tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
157 tcGRHSs ctxt grhss sig_ty `thenTc` \ (grhss', lie1) ->
158 tcSub rhs_ty sig_ty `thenTc` \ (co_fn, lie2) ->
159 returnTc ((pats', lift_grhss co_fn rhs_ty grhss'),
162 -- lift_grhss pushes the coercion down to the right hand sides,
163 -- because there is no convenient place to hang it otherwise.
164 lift_grhss co_fn rhs_ty grhss
165 | isIdCoercion co_fn = grhss
166 lift_grhss co_fn rhs_ty (GRHSs grhss binds ty)
167 = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since we
169 lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc
171 lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l
172 lift_stmt stmt = stmt
174 -- glue_on just avoids stupid dross
175 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
176 glue_on is_rec mbinds (GRHSs grhss binds ty)
177 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
180 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
182 -> TcM (TcGRHSs, LIE)
184 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
185 = tcBindsAndThen glue_on binds (tc_grhss grhss)
188 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
189 returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies)
191 tc_grhs (GRHS guarded locn)
193 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
194 returnTc (GRHS guarded' locn, lie)
198 %************************************************************************
200 \subsection{tcMatchPats}
202 %************************************************************************
206 :: [RenamedPat] -> TcType
207 -> ([TypecheckedPat] -> TcType -> TcM (a, LIE))
208 -> TcM (a, LIE, TcDictBinds)
209 -- Typecheck the patterns, extend the environment to bind the variables,
210 -- do the thing inside, use any existentially-bound dictionaries to
211 -- discharge parts of the returning LIE, and deal with pattern type
214 tcMatchPats pats expected_ty thing_inside
215 = -- STEP 1: Bring pattern-signature type variables into scope
216 tcAddScopedTyVars (collectSigTysFromPats pats) (
218 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
219 tc_match_pats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
221 -- STEP 3: Extend the environment, and do the thing inside
223 xve = bagToList pat_bndrs
224 pat_ids = map snd xve
226 tcExtendLocalValEnv2 xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
228 returnTc (lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2)
229 ) `thenTc` \ (lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2) ->
231 -- STEP 4: Check for existentially bound type variables
232 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
233 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
235 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
236 -- might need (via lie_req2) something made available from an 'outer'
237 -- pattern. But it's inconvenient to deal with, and I can't find an example
238 tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req2 expected_ty `thenTc` \ (lie_req2', ex_binds) ->
239 -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
240 -- For example, we must reject this program:
241 -- data C = forall a. C (a -> Int)
243 -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
245 returnTc (result, lie_req1 `plusLIE` lie_req2', ex_binds)
247 tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
248 -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
249 -> LIE -- and context
250 -> LIE -- Required context
251 -> TcType -- and type of the Match; vars in here must not escape
252 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
253 tcCheckExistentialPat ids ex_tvs lie_avail lie_req match_ty
254 | isEmptyBag ex_tvs && all not_overloaded ids
255 -- Short cut for case when there are no existentials
256 -- and no polymorphic overloaded variables
257 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
259 -- Here we must discharge op Methods
260 = ASSERT( isEmptyLIE lie_avail )
261 returnTc (lie_req, EmptyMonoBinds)
264 = tcAddErrCtxtM (sigPatCtxt tv_list ids match_ty) $
266 -- In case there are any polymorpic, overloaded binders in the pattern
267 -- (which can happen in the case of rank-2 type signatures, or data constructors
268 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
269 bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
271 -- Deal with overloaded functions bound by the pattern
272 tcSimplifyCheck doc tv_list (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
273 checkSigTyVarsWrt (tyVarsOfType match_ty) tv_list `thenTc_`
275 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
277 doc = text ("the existential context of a data constructor")
278 tv_list = bagToList ex_tvs
279 not_overloaded id = not (isOverloadedTy (idType id))
281 tc_match_pats [] expected_ty
282 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
284 tc_match_pats (pat:pats) expected_ty
285 = subFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
286 -- This is the unique place we call subFunTy
287 -- The point is that if expected_y is a "hole", we want
288 -- to make arg_ty and rest_ty as "holes" too.
289 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
290 tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
293 lie_req `plusLIE` lie_reqs,
294 pat_tvs `unionBags` pats_tvs,
295 pat_ids `unionBags` pats_ids,
296 lie_avail `plusLIE` lie_avails
301 %************************************************************************
305 %************************************************************************
307 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
309 [ (g x, h x) | ... ; let g v = ...
310 | ... ; let h v = ... ]
312 It's possible that g,h are overloaded, so we need to feed the LIE from the
313 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
314 Similarly if we had an existential pattern match:
316 data T = forall a. Show a => C a
318 [ (show x, show y) | ... ; C x <- ...
321 Then we need the LIE from (show x, show y) to be simplified against
322 the bindings for x and y.
324 It's difficult to do this in parallel, so we rely on the renamer to
325 ensure that g,h and x,y don't duplicate, and simply grow the environment.
326 So the binders of the first parallel group will be in scope in the second
327 group. But that's fine; there's no shadowing to worry about.
330 tcStmts do_or_lc m_ty stmts
331 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
334 :: (TcStmt -> thing -> thing) -- Combiner
335 -> RenamedMatchContext
336 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
337 -- elt_ty, where type of the comprehension is (m elt_ty)
343 tcStmtsAndThen combine do_or_lc m_ty [] do_next
346 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
347 = tcStmtAndThen combine do_or_lc m_ty stmt
348 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
351 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
352 = tcBindsAndThen -- No error context, but a binding group is
353 (glue_binds combine) -- rather a large thing for an error context anyway
357 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
358 = tcAddSrcLoc src_loc $
359 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
360 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
361 tcMonoExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
362 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
364 thing_inside `thenTc` \ (thing, lie) ->
365 returnTc ((BindStmt pat' exp' src_loc, thing), lie)
366 ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
367 returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
368 lie `plusLIE` exp_lie)
372 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
373 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
374 returnTc (combine (ParStmtOut pairs') thing, lie)
377 = thing_inside `thenTc` \ (thing, stmts_lie) ->
378 returnTc (([], thing), stmts_lie)
380 loop ((bndrs,stmts) : pairs)
382 combine_par (DoCtxt ListComp) m_ty stmts
383 -- Notice we pass on m_ty; the result type is used only
384 -- to get escaping type variables for checkExistentialPat
385 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
386 loop pairs `thenTc` \ ((pairs', thing), lie) ->
387 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
389 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
391 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
394 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
395 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
396 if isDoExpr do_or_lc then
397 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
398 tcMonoExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
399 returnTc (ExprStmt exp' any_ty locn, lie)
401 tcMonoExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
402 returnTc (ExprStmt exp' boolTy locn, lie)
403 ) `thenTc` \ (stmt', stmt_lie) ->
405 thing_inside `thenTc` \ (thing, stmts_lie) ->
407 returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
411 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
412 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
413 if isDoExpr do_or_lc then
414 tcMonoExpr exp (m res_elt_ty)
416 tcMonoExpr exp res_elt_ty
417 ) `thenTc` \ (exp', stmt_lie) ->
419 thing_inside `thenTc` \ (thing, stmts_lie) ->
421 returnTc (combine (ResultStmt exp' locn) thing,
422 stmt_lie `plusLIE` stmts_lie)
425 ------------------------------
426 glue_binds combine is_rec binds thing
427 | nullMonoBinds binds = thing
428 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
432 %************************************************************************
434 \subsection{Errors and contexts}
436 %************************************************************************
438 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
439 number of args are used in each equation.
442 sameNoOfArgs :: [RenamedMatch] -> Bool
443 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
445 args_in_match :: RenamedMatch -> Int
446 args_in_match (Match pats _ _) = length pats
450 varyingArgsErr name matches
451 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
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)
456 sigPatCtxt bound_tvs bound_ids match_ty tidy_env
457 = zonkTcType match_ty `thenNF_Tc` \ match_ty' ->
459 (env1, tidy_tys) = tidyOpenTypes tidy_env (map idType show_ids)
460 (env2, tidy_mty) = tidyOpenType env1 match_ty'
463 sep [ptext SLIT("When checking an existential match that binds"),
464 nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
465 ptext SLIT("and whose type is") <+> ppr tidy_mty])
467 show_ids = filter is_interesting bound_ids
468 is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
470 ppr_id id ty = ppr id <+> dcolon <+> ppr ty
471 -- Don't zonk the types so we get the separate, un-unified versions