2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, tcStmts, tcGRHSs ) where
9 #include "HsVersions.h"
11 import {-# SOURCE #-} TcExpr( tcExpr )
13 import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..),
14 MonoBinds(..), StmtCtxt(..), Stmt(..),
17 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
18 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
21 import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, noSigs, sigPatCtxt )
22 import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
23 import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv )
24 import TcPat ( tcPat, polyPatSig )
25 import TcType ( TcType, newTyVarTy, newTyVarTy_OpenKind )
26 import TcBinds ( tcBindsAndThen )
27 import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
28 import TcUnify ( unifyFunTy, unifyTauTy )
30 import TysWiredIn ( boolTy )
32 import BasicTypes ( RecFlag(..) )
33 import Type ( Kind, tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind )
42 %************************************************************************
44 \subsection{tcMatchesFun, tcMatchesCase}
46 %************************************************************************
48 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
49 @FunMonoBind@. The second argument is the name of the function, which
50 is used in error messages. It checks that all the equations have the
51 same number of arguments before using @tcMatches@ to do the work.
54 tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group
56 -> TcType -- Expected type
58 -> TcM s ([TcMatch], LIE)
60 tcMatchesFun xve fun_name expected_ty matches@(first_match:_)
61 = -- Check that they all have the same no of arguments
62 -- Set the location to that of the first equation, so that
63 -- any inter-equation error messages get some vaguely
64 -- sensible location. Note: we have to do this odd
65 -- ann-grabbing, because we don't always have annotations in
66 -- hand when we call tcMatchesFun...
67 tcAddSrcLoc (getMatchLoc first_match) (
68 checkTc (sameNoOfArgs matches)
69 (varyingArgsErr fun_name matches)
72 -- ToDo: Don't use "expected" stuff if there ain't a type signature
73 -- because inconsistency between branches
74 -- may show up as something wrong with the (non-existent) type signature
76 -- No need to zonk expected_ty, because unifyFunTy does that on the fly
77 tcMatches xve matches expected_ty (FunRhs fun_name)
80 @tcMatchesCase@ doesn't do the argument-count check because the
81 parser guarantees that each equation has exactly one argument.
84 tcMatchesCase :: [RenamedMatch] -- The case alternatives
85 -> TcType -- Type of whole case expressions
86 -> TcM s (TcType, -- Inferred type of the scrutinee
87 [TcMatch], -- Translated alternatives
90 tcMatchesCase matches expr_ty
91 = newTyVarTy_OpenKind `thenNF_Tc` \ scrut_ty ->
92 tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) ->
93 returnTc (scrut_ty, matches', lie)
95 tcMatchLambda :: RenamedMatch -> TcType -> TcM s (TcMatch, LIE)
96 tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody
101 tcMatches :: [(Name,Id)]
105 -> TcM s ([TcMatch], LIE)
107 tcMatches xve matches expected_ty fun_or_case
108 = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) ->
109 returnTc (matches, plusLIEs lies)
111 tc_match match = tcMatch xve match expected_ty fun_or_case
115 %************************************************************************
119 %************************************************************************
122 tcMatch :: [(Name,Id)]
124 -> TcType -- Expected result-type of the Match.
125 -- Early unification with this guy gives better error messages
127 -> TcM s (TcMatch, LIE)
129 tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
130 = tcAddSrcLoc (getMatchLoc match) $
131 tcAddErrCtxt (matchCtxt ctxt match) $
133 if null sig_tvs then -- The common case
134 tc_match expected_ty `thenTc` \ (_, match_and_lie) ->
135 returnTc match_and_lie
138 -- If there are sig tve we must be careful *not* to use
139 -- expected_ty right away, else we'll unify with tyvars free
140 -- in the envt. So invent a fresh tyvar and use that instead
141 newTyVarTy_OpenKind `thenNF_Tc` \ tyvar_ty ->
143 -- Extend the tyvar env and check the match itself
144 mapNF_Tc tcHsTyVar sig_tvs `thenNF_Tc` \ sig_tyvars ->
145 tcExtendTyVarEnv sig_tyvars (
147 ) `thenTc` \ (pat_ids, match_and_lie) ->
149 -- Check that the scoped type variables from the patterns
150 -- have not been constrained
151 tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) (
152 checkSigTyVars sig_tyvars
155 -- *Now* we're free to unify with expected_ty
156 unifyTauTy expected_ty tyvar_ty `thenTc_`
158 returnTc match_and_lie
161 tc_match expexted_ty -- Any sig tyvars are in scope by now
162 = -- STEP 1: Typecheck the patterns
163 tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
165 xve2 = bagToList pat_bndrs
166 pat_ids = map snd xve2
167 ex_tv_list = bagToList ex_tvs
170 -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
171 -- If it is it'll mess up the unifier when checking the RHS
172 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
174 -- STEP 3: Unify with the rhs type signature if any
175 (case maybe_rhs_sig of
176 Nothing -> returnTc ()
177 Just sig -> tcHsType sig `thenTc` \ sig_ty ->
179 -- Check that the signature isn't a polymorphic one, which
180 -- we don't permit (at present, anyway)
181 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
182 unifyTauTy rhs_ty sig_ty
185 -- STEP 4: Typecheck the guarded RHSs and the associated where clause
186 tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
187 tcGRHSs grhss rhs_ty ctxt
188 )) `thenTc` \ (grhss', lie_req2) ->
190 -- STEP 5: Check for existentially bound type variables
191 tcExtendGlobalTyVars (tyVarsOfType rhs_ty) (
192 tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $
193 checkSigTyVars ex_tv_list `thenTc` \ zonked_ex_tvs ->
195 (text ("the existential context of a data constructor"))
196 (mkVarSet zonked_ex_tvs)
197 lie_avail (lie_req1 `plusLIE` lie_req2)
198 ) `thenTc` \ (lie_req', ex_binds) ->
200 -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
201 -- (which can happen in the case of rank-2 type signatures, or data constructors
202 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
203 bindInstsOfLocalFuns lie_req' pat_ids `thenTc` \ (lie_req'', inst_binds) ->
207 grhss'' = glue_on Recursive ex_binds $
208 glue_on Recursive inst_binds grhss'
210 returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
212 -- glue_on just avoids stupid dross
213 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
214 glue_on is_rec mbinds (GRHSs grhss binds ty)
215 = GRHSs grhss (MonoBind mbinds [] is_rec `ThenBinds` binds) ty
217 tcGRHSs :: RenamedGRHSs
218 -> TcType -> StmtCtxt
219 -> TcM s (TcGRHSs, LIE)
221 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
222 = tcBindsAndThen glue_on binds (tc_grhss grhss)
225 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
226 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
228 tc_grhs (GRHS guarded locn)
230 tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
231 returnTc (GRHS guarded' locn, lie)
235 %************************************************************************
237 \subsection{tcMatchPats}
239 %************************************************************************
242 tcMatchPats [] expected_ty
243 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
245 tcMatchPats (pat:pats) expected_ty
246 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
247 tcPat noSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
248 tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
251 lie_req `plusLIE` lie_reqs,
252 pat_tvs `unionBags` pats_tvs,
253 pat_ids `unionBags` pats_ids,
254 lie_avail `plusLIE` lie_avails
259 %************************************************************************
263 %************************************************************************
268 -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
270 -> TcType -- elt_ty, where type of the comprehension is (m elt_ty)
271 -> TcM s ([TcStmt], LIE)
273 tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
274 = ASSERT( null stmts )
275 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
276 tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
277 returnTc ([ReturnStmt exp'], exp_lie)
279 -- ExprStmt at the end
280 tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
281 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
282 tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
283 returnTc ([ExprStmt exp' src_loc], exp_lie)
285 -- ExprStmt not at the end
286 tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
287 = ASSERT( isDoStmt do_or_lc )
288 tcAddSrcLoc src_loc (
289 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
290 -- exp has type (m tau) for some tau (doesn't matter what)
291 newTyVarTy_OpenKind `thenNF_Tc` \ any_ty ->
292 tcExpr exp (m any_ty)
293 ) `thenTc` \ (exp', exp_lie) ->
294 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
295 returnTc (ExprStmt exp' src_loc : stmts',
296 exp_lie `plusLIE` stmts_lie)
298 tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
299 = ASSERT( not (isDoStmt do_or_lc) )
300 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
301 tcAddSrcLoc src_loc $
303 ) `thenTc` \ (exp', exp_lie) ->
304 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
305 returnTc (GuardStmt exp' src_loc : stmts',
306 exp_lie `plusLIE` stmts_lie)
308 tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
309 = tcAddSrcLoc src_loc (
310 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
311 newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
312 tcPat noSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
313 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
314 returnTc (pat', exp',
315 pat_lie `plusLIE` exp_lie,
316 pat_tvs, pat_ids, avail)
317 ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
319 new_val_env = bagToList pat_bndrs
320 pat_ids = map snd new_val_env
321 pat_tv_list = bagToList pat_tvs
324 -- Do the rest; we don't need to add the pat_tvs to the envt
325 -- because they all appear in the pat_ids's types
326 tcExtendLocalValEnv new_val_env (
327 tcStmts do_or_lc m stmts elt_ty
328 ) `thenTc` \ (stmts', stmts_lie) ->
331 -- Reinstate context for existential checks
332 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
333 tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
334 tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $
336 checkSigTyVars pat_tv_list `thenTc` \ zonked_pat_tvs ->
339 (text ("the existential context of a data constructor"))
340 (mkVarSet zonked_pat_tvs)
341 lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
343 returnTc (BindStmt pat' exp' src_loc :
344 LetStmt (MonoBind dict_binds [] Recursive) :
346 lie_req `plusLIE` final_lie)
348 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
349 = tcBindsAndThen -- No error context, but a binding group is
350 combine -- rather a large thing for an error context anyway
352 (tcStmts do_or_lc m stmts elt_ty)
354 combine is_rec binds' stmts' = LetStmt (MonoBind binds' [] is_rec) : stmts'
357 isDoStmt DoStmt = True
358 isDoStmt other = False
362 %************************************************************************
364 \subsection{Errors and contexts}
366 %************************************************************************
368 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
369 number of args are used in each equation.
372 sameNoOfArgs :: [RenamedMatch] -> Bool
373 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
375 args_in_match :: RenamedMatch -> Int
376 args_in_match (Match _ pats _ _) = length pats
380 matchCtxt CaseAlt match
381 = hang (ptext SLIT("In a case alternative:"))
382 4 (pprMatch (True,empty) {-is_case-} match)
384 matchCtxt (FunRhs fun) match
385 = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
386 4 (pprMatch (False, ppr_fun) {-not case-} match)
390 matchCtxt LambdaBody match
391 = hang (ptext SLIT("In the lambda expression"))
392 4 (pprMatch (True, empty) match)
394 varyingArgsErr name matches
395 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
398 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
400 stmtCtxt do_or_lc stmt
401 = hang (ptext SLIT("In") <+> what <> colon)
404 what = case do_or_lc of
405 ListComp -> ptext SLIT("a list-comprehension qualifier")
406 DoStmt -> ptext SLIT("a do statement:")
407 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
408 FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
409 CaseAlt -> thing <+> ptext SLIT("a case alternative")
410 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
412 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
413 GuardStmt _ _ -> ptext SLIT("a guard for")
414 ExprStmt _ _ -> ptext SLIT("the right-hand side of")