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(..),
15 pprMatch, getMatchLoc, consLetStmt,
16 mkMonoBind, collectSigTysFromPats
18 import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
19 import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
22 import TcMonoType ( kcHsSigType, kcTyVarScope, newSigTyVars, checkSigTyVars, tcHsSigType, sigPatCtxt )
23 import Inst ( LIE, plusLIE, emptyLIE, plusLIEs )
24 import TcEnv ( tcExtendTyVarEnv, tcExtendLocalValEnv, tcExtendGlobalTyVars )
25 import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
26 import TcType ( TcType, newTyVarTy )
27 import TcBinds ( tcBindsAndThen )
28 import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
29 import TcUnify ( unifyFunTy, unifyTauTy )
31 import TysWiredIn ( boolTy )
33 import BasicTypes ( RecFlag(..) )
34 import Type ( tyVarsOfType, isTauTy, mkFunTy, boxedTypeKind, openTypeKind )
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 openTypeKind `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 tvs 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 openTypeKind `thenNF_Tc` \ tyvar_ty ->
143 -- Extend the tyvar env and check the match itself
144 kcTyVarScope sig_tvs (mapTc_ kcHsSigType sig_tys) `thenTc` \ sig_tv_kinds ->
145 newSigTyVars sig_tv_kinds `thenNF_Tc` \ sig_tyvars ->
146 tcExtendTyVarEnv sig_tyvars (tc_match tyvar_ty) `thenTc` \ (pat_ids, match_and_lie) ->
148 -- Check that the scoped type variables from the patterns
149 -- have not been constrained
150 tcAddErrCtxtM (sigPatCtxt sig_tyvars pat_ids) (
151 checkSigTyVars sig_tyvars emptyVarSet
154 -- *Now* we're free to unify with expected_ty
155 unifyTauTy expected_ty tyvar_ty `thenTc_`
157 returnTc match_and_lie
160 sig_tys = case maybe_rhs_sig of { Just t -> [t]; Nothing -> [] }
161 ++ collectSigTysFromPats pats
163 tc_match expected_ty -- Any sig tyvars are in scope by now
164 = -- STEP 1: Typecheck the patterns
165 tcMatchPats pats expected_ty `thenTc` \ (rhs_ty, pats', lie_req1, ex_tvs, pat_bndrs, lie_avail) ->
167 xve2 = bagToList pat_bndrs
168 pat_ids = map snd xve2
169 ex_tv_list = bagToList ex_tvs
172 -- STEP 2: Check that the remaining "expected type" is not a rank-2 type
173 -- If it is it'll mess up the unifier when checking the RHS
174 checkTc (isTauTy rhs_ty) lurkingRank2SigErr `thenTc_`
176 -- STEP 3: Unify with the rhs type signature if any
177 (case maybe_rhs_sig of
178 Nothing -> returnTc ()
179 Just sig -> tcHsSigType sig `thenTc` \ sig_ty ->
181 -- Check that the signature isn't a polymorphic one, which
182 -- we don't permit (at present, anyway)
183 checkTc (isTauTy sig_ty) (polyPatSig sig_ty) `thenTc_`
184 unifyTauTy rhs_ty sig_ty
187 -- STEP 4: Typecheck the guarded RHSs and the associated where clause
188 tcExtendLocalValEnv xve1 (tcExtendLocalValEnv xve2 (
189 tcGRHSs grhss rhs_ty ctxt
190 )) `thenTc` \ (grhss', lie_req2) ->
192 -- STEP 5: Check for existentially bound type variables
193 tcExtendGlobalTyVars (tyVarsOfType rhs_ty) (
194 tcAddErrCtxtM (sigPatCtxt ex_tv_list pat_ids) $
195 checkSigTyVars ex_tv_list emptyVarSet `thenTc` \ zonked_ex_tvs ->
197 (text ("the existential context of a data constructor"))
198 (mkVarSet zonked_ex_tvs)
199 lie_avail (lie_req1 `plusLIE` lie_req2)
200 ) `thenTc` \ (lie_req', ex_binds) ->
202 -- STEP 6 In case there are any polymorpic, overloaded binders in the pattern
203 -- (which can happen in the case of rank-2 type signatures, or data constructors
204 -- with polymorphic arguments), we must do a bindInstsOfLocalFns here
205 bindInstsOfLocalFuns lie_req' pat_ids `thenTc` \ (lie_req'', inst_binds) ->
209 grhss'' = glue_on Recursive ex_binds $
210 glue_on Recursive inst_binds grhss'
212 returnTc (pat_ids, (Match [] pats' Nothing grhss'', lie_req''))
214 -- glue_on just avoids stupid dross
215 glue_on _ EmptyMonoBinds grhss = grhss -- The common case
216 glue_on is_rec mbinds (GRHSs grhss binds ty)
217 = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty
219 tcGRHSs :: RenamedGRHSs
220 -> TcType -> StmtCtxt
221 -> TcM s (TcGRHSs, LIE)
223 tcGRHSs (GRHSs grhss binds _) expected_ty ctxt
224 = tcBindsAndThen glue_on binds (tc_grhss grhss)
227 = mapAndUnzipTc tc_grhs grhss `thenTc` \ (grhss', lies) ->
228 returnTc (GRHSs grhss' EmptyBinds (Just expected_ty), plusLIEs lies)
230 tc_grhs (GRHS guarded locn)
232 tcStmts ctxt (\ty -> ty) guarded expected_ty `thenTc` \ (guarded', lie) ->
233 returnTc (GRHS guarded' locn, lie)
237 %************************************************************************
239 \subsection{tcMatchPats}
241 %************************************************************************
244 tcMatchPats [] expected_ty
245 = returnTc (expected_ty, [], emptyLIE, emptyBag, emptyBag, emptyLIE)
247 tcMatchPats (pat:pats) expected_ty
248 = unifyFunTy expected_ty `thenTc` \ (arg_ty, rest_ty) ->
249 tcPat tcPatBndr_NoSigs pat arg_ty `thenTc` \ (pat', lie_req, pat_tvs, pat_ids, lie_avail) ->
250 tcMatchPats pats rest_ty `thenTc` \ (rhs_ty, pats', lie_reqs, pats_tvs, pats_ids, lie_avails) ->
253 lie_req `plusLIE` lie_reqs,
254 pat_tvs `unionBags` pats_tvs,
255 pat_ids `unionBags` pats_ids,
256 lie_avail `plusLIE` lie_avails
261 %************************************************************************
265 %************************************************************************
270 -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs
272 -> TcType -- elt_ty, where type of the comprehension is (m elt_ty)
273 -> TcM s ([TcStmt], LIE)
275 tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty
276 = ASSERT( null stmts )
277 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
278 tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) ->
279 returnTc ([ReturnStmt exp'], exp_lie)
281 -- ExprStmt at the end
282 tcStmts do_or_lc m [stmt@(ExprStmt exp src_loc)] elt_ty
283 = tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
284 tcExpr exp (m elt_ty) `thenTc` \ (exp', exp_lie) ->
285 returnTc ([ExprStmt exp' src_loc], exp_lie)
287 -- ExprStmt not at the end
288 tcStmts do_or_lc m (stmt@(ExprStmt exp src_loc) : stmts) elt_ty
289 = ASSERT( isDoStmt do_or_lc )
290 tcAddSrcLoc src_loc (
291 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
292 -- exp has type (m tau) for some tau (doesn't matter what)
293 newTyVarTy openTypeKind `thenNF_Tc` \ any_ty ->
294 tcExpr exp (m any_ty)
295 ) `thenTc` \ (exp', exp_lie) ->
296 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
297 returnTc (ExprStmt exp' src_loc : stmts',
298 exp_lie `plusLIE` stmts_lie)
300 tcStmts do_or_lc m (stmt@(GuardStmt exp src_loc) : stmts) elt_ty
301 = ASSERT( not (isDoStmt do_or_lc) )
302 tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
303 tcAddSrcLoc src_loc $
305 ) `thenTc` \ (exp', exp_lie) ->
306 tcStmts do_or_lc m stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
307 returnTc (GuardStmt exp' src_loc : stmts',
308 exp_lie `plusLIE` stmts_lie)
310 tcStmts do_or_lc m (stmt@(BindStmt pat exp src_loc) : stmts) elt_ty
311 = tcAddSrcLoc src_loc (
312 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
313 newTyVarTy boxedTypeKind `thenNF_Tc` \ pat_ty ->
314 tcPat tcPatBndr_NoSigs pat pat_ty `thenTc` \ (pat', pat_lie, pat_tvs, pat_ids, avail) ->
315 tcExpr exp (m pat_ty) `thenTc` \ (exp', exp_lie) ->
316 returnTc (pat', exp',
317 pat_lie `plusLIE` exp_lie,
318 pat_tvs, pat_ids, avail)
319 ) `thenTc` \ (pat', exp', lie_req, pat_tvs, pat_bndrs, lie_avail) ->
321 new_val_env = bagToList pat_bndrs
322 pat_ids = map snd new_val_env
323 pat_tv_list = bagToList pat_tvs
326 -- Do the rest; we don't need to add the pat_tvs to the envt
327 -- because they all appear in the pat_ids's types
328 tcExtendLocalValEnv new_val_env (
329 tcStmts do_or_lc m stmts elt_ty
330 ) `thenTc` \ (stmts', stmts_lie) ->
333 -- Reinstate context for existential checks
334 tcSetErrCtxt (stmtCtxt do_or_lc stmt) $
335 tcExtendGlobalTyVars (tyVarsOfType (m elt_ty)) $
336 tcAddErrCtxtM (sigPatCtxt pat_tv_list pat_ids) $
338 checkSigTyVars pat_tv_list emptyVarSet `thenTc` \ zonked_pat_tvs ->
341 (text ("the existential context of a data constructor"))
342 (mkVarSet zonked_pat_tvs)
343 lie_avail stmts_lie `thenTc` \ (final_lie, dict_binds) ->
345 returnTc (BindStmt pat' exp' src_loc :
346 consLetStmt (mkMonoBind dict_binds [] Recursive) stmts',
347 lie_req `plusLIE` final_lie)
349 tcStmts do_or_lc m (LetStmt binds : stmts) elt_ty
350 = tcBindsAndThen -- No error context, but a binding group is
351 combine -- rather a large thing for an error context anyway
353 (tcStmts do_or_lc m stmts elt_ty)
355 combine is_rec binds' stmts' = consLetStmt (mkMonoBind binds' [] is_rec) stmts'
358 isDoStmt DoStmt = True
359 isDoStmt other = False
363 %************************************************************************
365 \subsection{Errors and contexts}
367 %************************************************************************
369 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
370 number of args are used in each equation.
373 sameNoOfArgs :: [RenamedMatch] -> Bool
374 sameNoOfArgs matches = length (nub (map args_in_match matches)) == 1
376 args_in_match :: RenamedMatch -> Int
377 args_in_match (Match _ pats _ _) = length pats
381 matchCtxt CaseAlt match
382 = hang (ptext SLIT("In a case alternative:"))
383 4 (pprMatch (True,empty) {-is_case-} match)
385 matchCtxt (FunRhs fun) match
386 = hang (hcat [ptext SLIT("In an equation for function "), quotes (ppr_fun), char ':'])
387 4 (pprMatch (False, ppr_fun) {-not case-} match)
391 matchCtxt LambdaBody match
392 = hang (ptext SLIT("In the lambda expression"))
393 4 (pprMatch (True, empty) match)
395 varyingArgsErr name matches
396 = sep [ptext SLIT("Varying number of arguments for function"), quotes (ppr name)]
399 = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type")
401 stmtCtxt do_or_lc stmt
402 = hang (ptext SLIT("In") <+> what <> colon)
405 what = case do_or_lc of
406 ListComp -> ptext SLIT("a list-comprehension qualifier")
407 DoStmt -> ptext SLIT("a do statement")
408 PatBindRhs -> thing <+> ptext SLIT("a pattern binding")
409 FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f)
410 CaseAlt -> thing <+> ptext SLIT("a case alternative")
411 LambdaBody -> thing <+> ptext SLIT("a lambda abstraction")
413 BindStmt _ _ _ -> ptext SLIT("a pattern guard for")
414 GuardStmt _ _ -> ptext SLIT("a guard for")
415 ExprStmt _ _ -> ptext SLIT("the right-hand side of")