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( tcExpr )
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, RenamedHsType,
21 RenamedMatchContext, extractHsTyVars )
22 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
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,
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 )
36 import TysWiredIn ( boolTy )
38 import BasicTypes ( RecFlag(..) )
43 import Util ( isSingleton )
49 %************************************************************************
51 \subsection{tcMatchesFun, tcMatchesCase}
53 %************************************************************************
55 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
56 @FunMonoBind@. The second argument is the name of the function, which
57 is used in error messages. It checks that all the equations have the
58 same number of arguments before using @tcMatches@ to do the work.
61 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
63 -> TcType -- Expected type
65 -> TcM ([TcMatch], LIE)
67 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
68 = -- Check that they all have the same no of arguments
69 -- Set the location to that of the first equation, so that
70 -- any inter-equation error messages get some vaguely
71 -- sensible location. Note: we have to do this odd
72 -- ann-grabbing, because we don't always have annotations in
73 -- hand when we call tcMatchesFun...
74 tcAddSrcLoc (getMatchLoc first_match) (
75 checkTc (sameNoOfArgs matches)
76 (varyingArgsErr fun_name matches)
79 -- ToDo: Don't use "expected" stuff if there ain't a type signature
80 -- because inconsistency between branches
81 -- may show up as something wrong with the (non-existent) type signature
83 -- No need to zonk expected_ty, because unifyFunTy does that on the fly
84 tcMatches xve (FunRhs fun_name) matches expected_ty
87 @tcMatchesCase@ doesn't do the argument-count check because the
88 parser guarantees that each equation has exactly one argument.
91 tcMatchesCase :: [RenamedMatch] -- The case alternatives
92 -> TcType -- Type of whole case expressions
93 -> TcM (TcType, -- Inferred type of the scrutinee
94 [TcMatch], -- Translated alternatives
97 tcMatchesCase matches expr_ty
98 = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
99 tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) ->
100 returnTc (scrut_ty, matches', lie)
102 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
103 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
108 tcMatches :: [(Name,Id)]
109 -> RenamedMatchContext
112 -> TcM ([TcMatch], LIE)
114 tcMatches xve fun_or_case matches expected_ty
115 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
116 returnTc (matches, plusLIEs lies)
118 tc_match match = tcMatch xve fun_or_case match expected_ty
122 %************************************************************************
126 %************************************************************************
129 tcMatch :: [(Name,Id)]
130 -> RenamedMatchContext
132 -> TcType -- Expected result-type of the Match.
133 -- Early unification with this guy gives better error messages
134 -- We regard the Match as having type
135 -- (ty1 -> ... -> tyn -> result_ty)
136 -- where there are n patterns.
137 -> TcM (TcMatch, LIE)
139 tcMatch xve1 ctxt match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty
140 = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
141 tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
143 tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
144 returnTc (Match [] pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
147 tc_grhss pats' rhs_ty
148 = -- Check that the remaining "expected type" is not a rank-2 type
149 -- If it is it'll mess up the unifier when checking the RHS
150 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc` \_ ->
152 -- Deal with the result signature
153 -- It "wraps" the rest of the body typecheck because it may
154 -- bring into scope the type variables in the signature
155 tc_result_sig maybe_rhs_sig rhs_ty $
157 -- Typecheck the body
158 tcExtendLocalValEnv xve1 $
159 tcGRHSs ctxt grhss rhs_ty `thenTc` \ (grhss', lie) ->
160 returnTc ((pats', grhss'), lie)
162 tc_result_sig Nothing rhs_ty thing_inside
164 tc_result_sig (Just sig) rhs_ty thing_inside
165 = tcAddScopedTyVars [sig] $
166 tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
168 -- Check that the signature isn't a polymorphic one, which
169 -- we don't permit (at present, anyway)
170 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
171 unifyTauTy sig_ty rhs_ty `thenTc_`
175 -- glue_on just avoids stupid dross
176 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
177 glue_on is_rec mbinds (GRHSs grhss binds ty)
178 = 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 tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
228 returnTc (rhs_ty, lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2)
229 ) `thenTc` \ (rhs_ty, 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 tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
248 -- Find the not-already-in-scope signature type variables,
249 -- kind-check them, and bring them into scope
251 -- We no longer specify that these type variables must be univerally
252 -- quantified (lots of email on the subject). If you want to put that
253 -- back in, you need to
254 -- a) Do a checkSigTyVars after thing_inside
255 -- b) More insidiously, don't pass in expected_ty, else
256 -- we unify with it too early and checkSigTyVars barfs
257 -- Instead you have to pass in a fresh ty var, and unify
258 -- it with expected_ty afterwards
259 tcAddScopedTyVars sig_tys thing_inside
260 = tcGetEnv `thenNF_Tc` \ env ->
262 all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
263 sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
264 not_in_scope tv = not (tcInLocalScope env tv)
266 tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) thing_inside
268 tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
269 -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
270 -> LIE -- and context
271 -> LIE -- Required context
272 -> TcType -- and type of the Match; vars in here must not escape
273 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
274 tcCheckExistentialPat ids ex_tvs lie_avail lie_req match_ty
275 | isEmptyBag ex_tvs && all not_overloaded ids
276 -- Short cut for case when there are no existentials
277 -- and no polymorphic overloaded variables
278 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
280 -- Here we must discharge op Methods
281 = ASSERT( isEmptyLIE lie_avail )
282 returnTc (lie_req, EmptyMonoBinds)
285 = tcExtendGlobalTyVars (tyVarsOfType match_ty) $
286 tcAddErrCtxtM (sigPatCtxt tv_list ids) $
288 -- In case there are any polymorpic, overloaded binders in the pattern
289 -- (which can happen in the case of rank-2 type signatures, or data constructors
290 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
291 bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
293 -- Deal with overloaded functions bound by the pattern
294 tcSimplifyCheck doc tv_list (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
295 checkSigTyVars tv_list emptyVarSet `thenTc_`
297 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
299 doc = text ("the existential context of a data constructor")
300 tv_list = bagToList ex_tvs
301 not_overloaded id = not (isOverloadedTy (idType id))
303 tc_match_pats [] expected_ty
304 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
306 tc_match_pats (pat:pats) expected_ty
307 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
308 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
309 tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
312 lie_req `plusLIE` lie_reqs,
313 pat_tvs `unionBags` pats_tvs,
314 pat_ids `unionBags` pats_ids,
315 lie_avail `plusLIE` lie_avails
320 %************************************************************************
324 %************************************************************************
326 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
328 [ (g x, h x) | ... ; let g v = ...
329 | ... ; let h v = ... ]
331 It's possible that g,h are overloaded, so we need to feed the LIE from the
332 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
333 Similarly if we had an existential pattern match:
335 data T = forall a. Show a => C a
337 [ (show x, show y) | ... ; C x <- ...
340 Then we need the LIE from (show x, show y) to be simplified against
341 the bindings for x and y.
343 It's difficult to do this in parallel, so we rely on the renamer to
344 ensure that g,h and x,y don't duplicate, and simply grow the environment.
345 So the binders of the first parallel group will be in scope in the second
346 group. But that's fine; there's no shadowing to worry about.
349 tcStmts do_or_lc m_ty stmts
350 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
353 :: (TcStmt -> thing -> thing) -- Combiner
354 -> RenamedMatchContext
355 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
356 -- elt_ty, where type of the comprehension is (m elt_ty)
362 tcStmtsAndThen combine do_or_lc m_ty [] do_next
365 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
366 = tcStmtAndThen combine do_or_lc m_ty stmt
367 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
370 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
371 = tcBindsAndThen -- No error context, but a binding group is
372 (glue_binds combine) -- rather a large thing for an error context anyway
376 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
377 = tcAddSrcLoc src_loc $
378 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
379 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
380 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
381 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
383 thing_inside `thenTc` \ (thing, lie) ->
384 returnTc ((BindStmt pat' exp' src_loc, thing), lie)
385 ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
386 returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
387 lie `plusLIE` exp_lie)
391 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
392 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
393 returnTc (combine (ParStmtOut pairs') thing, lie)
396 = thing_inside `thenTc` \ (thing, stmts_lie) ->
397 returnTc (([], thing), stmts_lie)
399 loop ((bndrs,stmts) : pairs)
401 combine_par (DoCtxt ListComp) m_ty stmts
402 -- Notice we pass on m_ty; the result type is used only
403 -- to get escaping type variables for checkExistentialPat
404 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
405 loop pairs `thenTc` \ ((pairs', thing), lie) ->
406 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
408 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
410 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
413 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
414 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
415 if isDoExpr do_or_lc then
416 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
417 tcExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
418 returnTc (ExprStmt exp' any_ty locn, lie)
420 tcExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
421 returnTc (ExprStmt exp' boolTy locn, lie)
422 ) `thenTc` \ (stmt', stmt_lie) ->
424 thing_inside `thenTc` \ (thing, stmts_lie) ->
426 returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
430 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
431 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
432 if isDoExpr do_or_lc then
433 tcExpr exp (m res_elt_ty)
435 tcExpr exp res_elt_ty
436 ) `thenTc` \ (exp', stmt_lie) ->
438 thing_inside `thenTc` \ (thing, stmts_lie) ->
440 returnTc (combine (ResultStmt exp' locn) thing,
441 stmt_lie `plusLIE` stmts_lie)
444 ------------------------------
445 glue_binds combine is_rec binds thing
446 | nullMonoBinds binds = thing
447 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
451 %************************************************************************
453 \subsection{Errors and contexts}
455 %************************************************************************
457 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
458 number of args are used in each equation.
461 sameNoOfArgs :: [RenamedMatch] -> Bool
462 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
464 args_in_match :: RenamedMatch -> Int
465 args_in_match (Match _ pats _ _) = length pats
469 matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
470 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
472 varyingArgsErr name matches
473 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
476 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")