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(..),
17 pprMatch, getMatchLoc, pprMatchContext, isDoExpr,
18 mkMonoBind, nullMonoBinds, collectSigTysFromPats
20 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedPat, RenamedHsType,
22 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TypecheckedPat )
25 import TcMonoType ( kcHsSigTypes, tcScopedTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
26 import Inst ( LIE, isEmptyLIE, plusLIE, emptyLIE, plusLIEs, lieToList )
27 import TcEnv ( TcId, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars,
29 import TcPat ( tcPat, tcMonoPatBndr, polyPatSig )
30 import TcType ( TcType, newTyVarTy )
31 import TcBinds ( tcBindsAndThen )
32 import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
33 import TcUnify ( unifyFunTy, unifyTauTy )
35 import TysWiredIn ( boolTy, mkListTy )
37 import BasicTypes ( RecFlag(..) )
38 import Type ( tyVarsOfType, isTauTy, mkFunTy,
39 liftedTypeKind, openTypeKind, splitSigmaTy )
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 unifyFunTy does that on the fly
83 tcMatches xve matches expected_ty (FunRhs fun_name)
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 [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
99 returnTc (scrut_ty, matches', lie)
101 tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE)
102 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr
107 tcMatches :: [(Name,Id)]
111 -> TcM ([TcMatch], LIE)
113 tcMatches xve matches expected_ty fun_or_case
114 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
115 returnTc (matches, plusLIEs lies)
117 tc_match match = tcMatch xve match expected_ty fun_or_case
121 %************************************************************************
125 %************************************************************************
128 tcMatch :: [(Name,Id)]
130 -> TcType -- Expected result-type of the Match.
131 -- Early unification with this guy gives better error messages
133 -> TcM (TcMatch, LIE)
135 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
136 = tcMatchPats pats expected_ty tc_grhss `thenTc` \ ((pats', grhss'), lie, ex_binds) ->
137 returnTc (Match [] pats' Nothing (glue_on Recursive ex_binds grhss'), lie)
140 tc_grhss pats' rhs_ty
141 = -- Check that the remaining "expected type" is not a rank-2 type
142 -- If it is it'll mess up the unifier when checking the RHS
143 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
145 -- Deal with the result signature
146 tc_result_sig maybe_rhs_sig (
148 -- Typecheck the body
149 tcExtendLocalValEnv xve1 $
150 tcGRHSs grhss rhs_ty ctxt `thenTc` \ (grhss', lie) ->
151 returnTc ((pats', grhss'), lie)
154 tc_result_sig Nothing thing_inside
156 tc_result_sig (Just sig) thing_inside
157 = tcAddScopedTyVars [sig] $
158 tcHsSigType sig `thenTc` \ sig_ty ->
160 -- Check that the signature isn't a polymorphic one, which
161 -- we don't permit (at present, anyway)
162 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
163 unifyTauTy expected_ty sig_ty `thenTc_`
167 -- glue_on just avoids stupid dross
168 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
169 glue_on is_rec mbinds (GRHSs grhss binds ty)
170 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
172 tcGRHSs :: RenamedGRHSs
173 -> TcType -> HsMatchContext
174 -> TcM (TcGRHSs, LIE)
176 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
177 = tcBindsAndThen glue_on binds (tc_grhss grhss)
180 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
181 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
183 tc_grhs (GRHS guarded locn)
185 tcStmts ctxt (\ty -> ty, expected_ty) guarded `thenTc` \ (guarded', lie) ->
186 returnTc (GRHS guarded' locn, lie)
190 %************************************************************************
192 \subsection{tcMatchPats}
194 %************************************************************************
198 :: [RenamedPat] -> TcType
199 -> ([TypecheckedPat] -> TcType -> TcM (a, LIE))
200 -> TcM (a, LIE, TcDictBinds)
201 -- Typecheck the patterns, extend the environment to bind the variables,
202 -- do the thing inside, use any existentially-bound dictionaries to
203 -- discharge parts of the returning LIE, and deal with pattern type
206 tcMatchPats pats expected_ty thing_inside
207 = -- STEP 1: Bring pattern-signature type variables into scope
208 tcAddScopedTyVars (collectSigTysFromPats pats) $
210 -- STEP 2: Typecheck the patterns themselves, gathering all the stuff
211 tc_match_pats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
213 -- STEP 3: Extend the environment, and do the thing inside
215 xve = bagToList pat_bndrs
216 pat_ids = map snd xve
218 tcExtendLocalValEnv xve (thing_inside pats' rhs_ty) `thenTc` \ (result, lie_req2) ->
220 -- STEP 4: Check for existentially bound type variables
221 -- I'm a bit concerned that lie_req1 from an 'inner' pattern in the list
222 -- might need (via lie_req2) something made available from an 'outer'
223 -- pattern. But it's inconvenient to deal with, and I can't find an example
224 tcCheckExistentialPat pat_ids ex_tvs lie_avail lie_req1 rhs_ty `thenTc` \ (lie_req1', ex_binds) ->
226 returnTc (result, lie_req1' `plusLIE` lie_req2, ex_binds)
228 tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a
229 -- Find the not-already-in-scope signature type variables,
230 -- kind-check them, and bring them into scope
232 -- We no longer specify that these type variables must be univerally
233 -- quantified (lots of email on the subject). If you want to put that
234 -- back in, you need to
235 -- a) Do a checkSigTyVars after thing_inside
236 -- b) More insidiously, don't pass in expected_ty, else
237 -- we unify with it too early and checkSigTyVars barfs
238 -- Instead you have to pass in a fresh ty var, and unify
239 -- it with expected_ty afterwards
240 tcAddScopedTyVars sig_tys thing_inside
241 = tcGetEnv `thenNF_Tc` \ env ->
243 all_sig_tvs = foldr (unionNameSets . extractHsTyVars) emptyNameSet sig_tys
244 sig_tvs = filter not_in_scope (nameSetToList all_sig_tvs)
245 not_in_scope tv = not (tcInLocalScope env tv)
247 tcScopedTyVars sig_tvs (kcHsSigTypes sig_tys) thing_inside
249 tcCheckExistentialPat :: [TcId] -- Ids bound by this pattern
250 -> Bag TcTyVar -- Existentially quantified tyvars bound by pattern
251 -> LIE -- and context
252 -> LIE -- Required context
253 -> TcType -- and result type; vars in here must not escape
254 -> TcM (LIE, TcDictBinds) -- LIE to float out and dict bindings
255 tcCheckExistentialPat ids ex_tvs lie_avail lie_req result_ty
256 | isEmptyBag ex_tvs && all not_overloaded ids
257 -- Short cut for case when there are no existentials
258 -- and no polymorphic overloaded variables
259 -- e.g. f :: (forall a. Ord a => a -> a) -> Int -> Int
261 -- Here we must discharge op Methods
262 = ASSERT( isEmptyLIE lie_avail )
263 returnTc (lie_req, EmptyMonoBinds)
266 = tcExtendGlobalTyVars (tyVarsOfType result_ty) $
267 tcAddErrCtxtM (sigPatCtxt tv_list ids) $
269 -- In case there are any polymorpic, overloaded binders in the pattern
270 -- (which can happen in the case of rank-2 type signatures, or data constructors
271 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
272 bindInstsOfLocalFuns lie_req ids `thenTc` \ (lie1, inst_binds) ->
274 -- Deal with overloaded functions bound by the pattern
275 tcSimplifyCheck doc tv_list
276 (lieToList lie_avail) lie1 `thenTc` \ (lie2, dict_binds) ->
277 checkSigTyVars tv_list emptyVarSet `thenTc_`
279 returnTc (lie2, dict_binds `AndMonoBinds` inst_binds)
281 doc = text ("the existential context of a data constructor")
282 tv_list = bagToList ex_tvs
283 not_overloaded id = case splitSigmaTy (idType id) of
284 (_, theta, _) -> null theta
286 tc_match_pats [] expected_ty
287 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
289 tc_match_pats (pat:pats) expected_ty
290 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
291 tcPat tcMonoPatBndr pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
292 tc_match_pats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
295 lie_req `plusLIE` lie_reqs,
296 pat_tvs `unionBags` pats_tvs,
297 pat_ids `unionBags` pats_ids,
298 lie_avail `plusLIE` lie_avails
303 %************************************************************************
307 %************************************************************************
309 Typechecking statements is rendered a bit tricky by parallel list comprehensions:
311 [ (g x, h x) | ... ; let g v = ...
312 | ... ; let h v = ... ]
314 It's possible that g,h are overloaded, so we need to feed the LIE from the
315 (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
316 Similarly if we had an existential pattern match:
318 data T = forall a. Show a => C a
320 [ (show x, show y) | ... ; C x <- ...
323 Then we need the LIE from (show x, show y) to be simplified against
324 the bindings for x and y.
326 It's difficult to do this in parallel, so we rely on the renamer to
327 ensure that g,h and x,y don't duplicate, and simply grow the environment.
328 So the binders of the first parallel group will be in scope in the second
329 group. But that's fine; there's no shadowing to worry about.
332 tcStmts do_or_lc m_ty stmts
333 = tcStmtsAndThen (:) do_or_lc m_ty stmts (returnTc ([], emptyLIE))
336 :: (TcStmt -> thing -> thing) -- Combiner
338 -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs
339 -- elt_ty, where type of the comprehension is (m elt_ty)
345 tcStmtsAndThen combine do_or_lc m_ty [] do_next
348 tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next
349 = tcStmtAndThen combine do_or_lc m_ty stmt
350 (tcStmtsAndThen combine do_or_lc m_ty stmts do_next)
353 tcStmtAndThen combine do_or_lc m_ty (LetStmt binds) thing_inside
354 = tcBindsAndThen -- No error context, but a binding group is
355 (glue_binds combine) -- rather a large thing for an error context anyway
359 tcStmtAndThen combine do_or_lc m_ty@(m,elt_ty) stmt@(BindStmt pat exp src_loc) thing_inside
360 = tcAddSrcLoc src_loc $
361 tcAddErrCtxt (stmtCtxt do_or_lc stmt) $
362 newTyVarTy liftedTypeKind `thenNF_Tc` \ pat_ty ->
363 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
364 tcMatchPats [pat] (mkFunTy pat_ty (m elt_ty)) (\ [pat'] _ ->
366 thing_inside `thenTc` \ (thing, lie) ->
367 returnTc ((BindStmt pat' exp' src_loc, thing), lie)
368 ) `thenTc` \ ((stmt', thing), lie, dict_binds) ->
369 returnTc (combine stmt' (glue_binds combine Recursive dict_binds thing),
370 lie `plusLIE` exp_lie)
374 tcStmtAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s) thing_inside
375 = loop bndr_stmts_s `thenTc` \ ((pairs', thing), lie) ->
376 returnTc (combine (ParStmtOut pairs') thing, lie)
379 = thing_inside `thenTc` \ (thing, stmts_lie) ->
380 returnTc (([], thing), stmts_lie)
382 loop ((bndrs,stmts) : pairs)
384 combine_par ListComp m_ty stmts
385 -- Notice we pass on m_ty; the result type is used only
386 -- to get escaping type variables for checkExistentialPat
387 (tcLookupLocalIds bndrs `thenNF_Tc` \ bndrs' ->
388 loop pairs `thenTc` \ ((pairs', thing), lie) ->
389 returnTc (([], (bndrs', pairs', thing)), lie)) `thenTc` \ ((stmts', (bndrs', pairs', thing)), lie) ->
391 returnTc ( ((bndrs',stmts') : pairs', thing), lie)
393 combine_par stmt (stmts, thing) = (stmt:stmts, thing)
396 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ExprStmt exp locn) thing_inside
397 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
398 if isDoExpr do_or_lc then
399 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
400 tcExpr exp (m any_ty)
403 ) `thenTc` \ (exp', stmt_lie) ->
405 thing_inside `thenTc` \ (thing, stmts_lie) ->
407 returnTc (combine (ExprStmt exp' locn) thing,
408 stmt_lie `plusLIE` stmts_lie)
412 tcStmtAndThen combine do_or_lc m_ty@(m, res_elt_ty) stmt@(ResultStmt exp locn) thing_inside
413 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
414 if isDoExpr do_or_lc then
415 tcExpr exp (m res_elt_ty)
417 tcExpr exp res_elt_ty
418 ) `thenTc` \ (exp', stmt_lie) ->
420 thing_inside `thenTc` \ (thing, stmts_lie) ->
422 returnTc (combine (ResultStmt exp' locn) thing,
423 stmt_lie `plusLIE` stmts_lie)
426 ------------------------------
427 glue_binds combine is_rec binds thing
428 | nullMonoBinds binds = thing
429 | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing
433 %************************************************************************
435 \subsection{Errors and contexts}
437 %************************************************************************
439 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
440 number of args are used in each equation.
443 sameNoOfArgs :: [RenamedMatch] -> Bool
444 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
446 args_in_match :: RenamedMatch -> Int
447 args_in_match (Match _ pats _ _) = length pats
451 matchCtxt CaseAlt match
452 = hang (ptext SLIT("In a case alternative:"))
453 4 (pprMatch (True,empty) {-is_case-} match)
455 matchCtxt (FunRhs fun) match
456 = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
457 4 (pprMatch (False, ppr_fun) {-not case-} match)
461 matchCtxt LambdaExpr match
462 = hang (ptext SLIT("In the lambda expression"))
463 4 (pprMatch (True, empty) match)
465 varyingArgsErr name matches
466 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
469 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
471 stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt)