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, 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, tcExtendLocalValEnv, tcExtendGlobalTyVars )
27 import TcPat ( tcPat, tcMonoPatBndr, polyPatSig )
28 import TcMType ( newTyVarTy )
29 import TcType ( TcType, TcTyVar, tyVarsOfType, isTauTy,
30 mkFunTy, isOverloadedTy, liftedTypeKind, openTypeKind )
31 import TcBinds ( tcBindsAndThen )
32 import TcUnify ( subFunTy, unifyTauTy, checkSigTyVars, sigPatCtxt )
33 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
35 import TysWiredIn ( boolTy )
37 import BasicTypes ( RecFlag(..) )
41 import Util ( isSingleton )
47 %************************************************************************
49 \subsection{tcMatchesFun, tcMatchesCase}
51 %************************************************************************
53 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
54 @FunMonoBind@. The second argument is the name of the function, which
55 is used in error messages. It checks that all the equations have the
56 same number of arguments before using @tcMatches@ to do the work.
59 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
61 -> TcType -- Expected type
63 -> TcM ([TcMatch], LIE)
65 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
66 = -- Check that they all have the same no of arguments
67 -- Set the location to that of the first equation, so that
68 -- any inter-equation error messages get some vaguely
69 -- sensible location. Note: we have to do this odd
70 -- ann-grabbing, because we don't always have annotations in
71 -- hand when we call tcMatchesFun...
72 tcAddSrcLoc (getMatchLoc first_match) (
73 checkTc (sameNoOfArgs matches)
74 (varyingArgsErr fun_name matches)
77 -- ToDo: Don't use "expected" stuff if there ain't a type signature
78 -- because inconsistency between branches
79 -- may show up as something wrong with the (non-existent) type signature
81 -- No need to zonk expected_ty, because subFunTy does that on the fly
82 tcMatches xve (FunRhs fun_name) matches expected_ty
85 @tcMatchesCase@ doesn't do the argument-count check because the
86 parser guarantees that each equation has exactly one argument.
89 tcMatchesCase :: [RenamedMatch] -- The case alternatives
90 -> TcType -- Type of whole case expressions
91 -> TcM (TcType, -- Inferred type of the scrutinee
92 [TcMatch], -- Translated alternatives
95 tcMatchesCase matches expr_ty
96 = newTyVarTy openTypeKind `thenNF_Tc` \ scrut_ty ->
97 tcMatches [] CaseAlt matches (mkFunTy scrut_ty expr_ty) `thenTc` \ (matches', lie) ->
98 returnTc (scrut_ty, matches', lie)
100 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
101 tcMatchLambda match res_ty = tcMatch [] LambdaExpr match res_ty
106 tcMatches :: [(Name,Id)]
107 -> RenamedMatchContext
110 -> TcM ([TcMatch], LIE)
112 tcMatches xve fun_or_case matches expected_ty
113 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
114 returnTc (matches, plusLIEs lies)
116 tc_match match = tcMatch xve fun_or_case match expected_ty
120 %************************************************************************
124 %************************************************************************
127 tcMatch :: [(Name,Id)]
128 -> RenamedMatchContext
130 -> TcType -- Expected result-type of the Match.
131 -- Early unification with this guy gives better error messages
132 -- We regard the Match as having type
133 -- (ty1 -> ... -> tyn -> result_ty)
134 -- where there are n patterns.
135 -> TcM (TcMatch, LIE)
137 tcMatch xve1 ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty
138 = tcAddSrcLoc (getMatchLoc match) $ -- At one stage I removed this;
139 tcAddErrCtxt (matchCtxt ctxt match) $ -- I'm not sure why, so I put it back
141 tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
142 returnTc (Match pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
145 tc_grhss pats' rhs_ty
146 = -- Check that the remaining "expected type" is not a rank-2 type
147 -- If it is it'll mess up the unifier when checking the RHS
148 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc` \_ ->
150 -- Deal with the result signature
151 -- It "wraps" the rest of the body typecheck because it may
152 -- bring into scope the type variables in the signature
153 tc_result_sig maybe_rhs_sig rhs_ty $
155 -- Typecheck the body
156 tcExtendLocalValEnv xve1 $
157 tcGRHSs ctxt grhss rhs_ty `thenTc` \ (grhss', lie) ->
158 returnTc ((pats', grhss'), lie)
160 tc_result_sig Nothing rhs_ty thing_inside
162 tc_result_sig (Just sig) rhs_ty thing_inside
163 = tcAddScopedTyVars [sig] $
164 tcHsSigType ResSigCtxt sig `thenTc` \ sig_ty ->
166 -- Check that the signature isn't a polymorphic one, which
167 -- we don't permit (at present, anyway)
168 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
169 unifyTauTy sig_ty rhs_ty `thenTc_`
173 -- glue_on just avoids stupid dross
174 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
175 glue_on is_rec mbinds (GRHSs grhss binds ty)
176 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
178 tcGRHSs :: RenamedMatchContext -> RenamedGRHSs
180 -> TcM (TcGRHSs, LIE)
182 tcGRHSs ctxt (GRHSs grhss binds _) expected_ty
183 = tcBindsAndThen glue_on binds (tc_grhss grhss)
186 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
187 returnTc (GRHSs grhss' EmptyBinds expected_ty, plusLIEs lies)
189 tc_grhs (GRHS guarded locn)
191 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
192 returnTc (GRHS guarded' locn, lie)
196 %************************************************************************
198 \subsection{tcMatchPats}
200 %************************************************************************
204 :: [RenamedPat] -> TcType
205 -> ([TypecheckedPat] -> TcType -> TcM (a, LIE))
206 -> TcM (a, LIE, TcDictBinds)
207 -- Typecheck the patterns, extend the environment to bind the variables,
208 -- do the thing inside, use any existentially-bound dictionaries to
209 -- discharge parts of the returning LIE, and deal with pattern type
212 tcMatchPats pats expected_ty thing_inside
213 = -- STEP 1: Bring pattern-signature type variables into scope
214 tcAddScopedTyVars (collectSigTysFromPats pats) (
216 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
217 tc_match_pats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
219 -- STEP 3: Extend the environment, and do the thing inside
221 xve = bagToList pat_bndrs
222 pat_ids = map snd xve
224 tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
226 returnTc (rhs_ty, lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2)
227 ) `thenTc` \ (rhs_ty, lie_req1, ex_tvs, pat_ids, lie_avail, result, lie_req2) ->
229 -- STEP 4: Check for existentially bound type variables
230 -- Do this *outside* the scope of the tcAddScopedTyVars, else checkSigTyVars
231 -- complains that 'a' is captured by the inscope 'a'! (Test (d) in checkSigTyVars.)
233 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
234 -- might need (via lie_req2) something made available from an 'outer'
235 -- pattern. But it's inconvenient to deal with, and I can't find an example
236 tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req2 expected_ty `thenTc` \ (lie_req2', ex_binds) ->
237 -- NB: we *must* pass "expected_ty" not "result_ty" to tcCheckExistentialPat
238 -- For example, we must reject this program:
239 -- data C = forall a. C (a -> Int)
241 -- Here, result_ty will be simply Int, but expected_ty is (a -> Int).
243 returnTc (result, lie_req1 `plusLIE` lie_req2', ex_binds)
245 tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
246 -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
247 -> LIE -- and context
248 -> LIE -- Required context
249 -> TcType -- and type of the Match; vars in here must not escape
250 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
251 tcCheckExistentialPat ids ex_tvs lie_avail lie_req match_ty
252 | isEmptyBag ex_tvs && all not_overloaded ids
253 -- Short cut for case when there are no existentials
254 -- and no polymorphic overloaded variables
255 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
257 -- Here we must discharge op Methods
258 = ASSERT( isEmptyLIE lie_avail )
259 returnTc (lie_req, EmptyMonoBinds)
262 = tcExtendGlobalTyVars (tyVarsOfType match_ty) $
263 tcAddErrCtxtM (sigPatCtxt tv_list ids) $
265 -- In case there are any polymorpic, overloaded binders in the pattern
266 -- (which can happen in the case of rank-2 type signatures, or data constructors
267 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
268 bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
270 -- Deal with overloaded functions bound by the pattern
271 tcSimplifyCheck doc tv_list (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
272 checkSigTyVars tv_list emptyVarSet `thenTc_`
274 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
276 doc = text ("the existential context of a data constructor")
277 tv_list = bagToList ex_tvs
278 not_overloaded id = not (isOverloadedTy (idType id))
280 tc_match_pats [] expected_ty
281 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
283 tc_match_pats (pat:pats) expected_ty
284 = subFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
285 -- This is the unique place we call subFunTy
286 -- The point is that if expected_y is a "hole", we want
287 -- to make arg_ty and rest_ty as "holes" too.
288 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
289 tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
292 lie_req `plusLIE` lie_reqs,
293 pat_tvs `unionBags` pats_tvs,
294 pat_ids `unionBags` pats_ids,
295 lie_avail `plusLIE` lie_avails
300 %************************************************************************
304 %************************************************************************
306 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
308 [ (g x, h x) | ... ; let g v = ...
309 | ... ; let h v = ... ]
311 It's possible that g,h are overloaded, so we need to feed the LIE from the
312 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
313 Similarly if we had an existential pattern match:
315 data T = forall a. Show a => C a
317 [ (show x, show y) | ... ; C x <- ...
320 Then we need the LIE from (show x, show y) to be simplified against
321 the bindings for x and y.
323 It's difficult to do this in parallel, so we rely on the renamer to
324 ensure that g,h and x,y don't duplicate, and simply grow the environment.
325 So the binders of the first parallel group will be in scope in the second
326 group. But that's fine; there's no shadowing to worry about.
329 tcStmts do_or_lc m_ty stmts
330 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
333 :: (TcStmt -> thing -> thing) -- Combiner
334 -> RenamedMatchContext
335 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
336 -- elt_ty, where type of the comprehension is (m elt_ty)
342 tcStmtsAndThen combine do_or_lc m_ty [] do_next
345 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
346 = tcStmtAndThen combine do_or_lc m_ty stmt
347 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
350 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
351 = tcBindsAndThen -- No error context, but a binding group is
352 (glue_binds combine) -- rather a large thing for an error context anyway
356 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
357 = tcAddSrcLoc src_loc $
358 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
359 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
360 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
361 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
363 thing_inside `thenTc` \ (thing, lie) ->
364 returnTc ((BindStmt pat' exp' src_loc, thing), lie)
365 ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
366 returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
367 lie `plusLIE` exp_lie)
371 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
372 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
373 returnTc (combine (ParStmtOut pairs') thing, lie)
376 = thing_inside `thenTc` \ (thing, stmts_lie) ->
377 returnTc (([], thing), stmts_lie)
379 loop ((bndrs,stmts) : pairs)
381 combine_par (DoCtxt ListComp) m_ty stmts
382 -- Notice we pass on m_ty; the result type is used only
383 -- to get escaping type variables for checkExistentialPat
384 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
385 loop pairs `thenTc` \ ((pairs', thing), lie) ->
386 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
388 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
390 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
393 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp _ locn) thing_inside
394 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
395 if isDoExpr do_or_lc then
396 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
397 tcExpr exp (m any_ty) `thenNF_Tc` \ (exp', lie) ->
398 returnTc (ExprStmt exp' any_ty locn, lie)
400 tcExpr exp boolTy `thenNF_Tc` \ (exp', lie) ->
401 returnTc (ExprStmt exp' boolTy locn, lie)
402 ) `thenTc` \ (stmt', stmt_lie) ->
404 thing_inside `thenTc` \ (thing, stmts_lie) ->
406 returnTc (combine stmt' thing, stmt_lie `plusLIE` stmts_lie)
410 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
411 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
412 if isDoExpr do_or_lc then
413 tcExpr exp (m res_elt_ty)
415 tcExpr exp res_elt_ty
416 ) `thenTc` \ (exp', stmt_lie) ->
418 thing_inside `thenTc` \ (thing, stmts_lie) ->
420 returnTc (combine (ResultStmt exp' locn) thing,
421 stmt_lie `plusLIE` stmts_lie)
424 ------------------------------
425 glue_binds combine is_rec binds thing
426 | nullMonoBinds binds = thing
427 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
431 %************************************************************************
433 \subsection{Errors and contexts}
435 %************************************************************************
437 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
438 number of args are used in each equation.
441 sameNoOfArgs :: [RenamedMatch] -> Bool
442 sameNoOfArgs matches = isSingleton (nub (map args_in_match matches))
444 args_in_match :: RenamedMatch -> Int
445 args_in_match (Match pats _ _) = length pats
449 matchCtxt ctxt match = hang (pprMatchContext ctxt <> colon) 4 (pprMatch ctxt match)
450 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)
452 varyingArgsErr name matches
453 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
456 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")