2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcMatches]{Typecheck some @Matches@}
7 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
8 matchCtxt, TcMatchCtxt(..),
10 tcDoStmt, tcMDoStmt, tcGuardStmt
13 #include "HsVersions.h"
15 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
17 import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
18 Match(..), LMatch, GRHSs(..), GRHS(..),
19 Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
20 pprMatch, isIrrefutableHsPat, mkHsCoerce,
21 pprMatchContext, pprStmtContext,
22 noSyntaxExpr, matchGroupArity, pprMatches,
26 import TcHsType ( tcPatSig, UserTypeCtxt(..) )
27 import Inst ( newMethodFromName )
28 import TcEnv ( TcId, tcLookupLocalIds, tcLookupId, tcExtendIdEnv,
30 import TcPat ( PatCtxt(..), tcPats, tcPat )
31 import TcMType ( newFlexiTyVarTy, newFlexiTyVarTys )
32 import TcType ( TcType, TcRhoType,
33 BoxySigmaType, BoxyRhoType,
34 mkFunTys, mkFunTy, mkAppTy, mkTyConApp,
36 import TcBinds ( tcLocalBinds )
37 import TcUnify ( boxySplitAppTy, boxySplitTyConApp, boxySplitListTy,
38 subFunTys, tcSubExp, withBox )
39 import TcSimplify ( bindInstsOfLocalFuns )
41 import TysWiredIn ( stringTy, boolTy, parrTyCon, listTyCon, mkListTy, mkPArrTy )
42 import PrelNames ( bindMName, returnMName, mfixName, thenMName, failMName )
43 import Id ( idType, mkLocalId )
44 import TyCon ( TyCon )
45 import Util ( isSingleton )
47 import SrcLoc ( Located(..), getLoc )
48 import ErrUtils ( Message )
53 %************************************************************************
55 \subsection{tcMatchesFun, tcMatchesCase}
57 %************************************************************************
59 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
60 @FunMonoBind@. The second argument is the name of the function, which
61 is used in error messages. It checks that all the equations have the
62 same number of arguments before using @tcMatches@ to do the work.
67 -> BoxyRhoType -- Expected type of function
68 -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body
70 tcMatchesFun fun_name matches exp_ty
71 = do { -- Check that they all have the same no of arguments
72 -- Location is in the monad, set the caller so that
73 -- any inter-equation error messages get some vaguely
74 -- sensible location. Note: we have to do this odd
75 -- ann-grabbing, because we don't always have annotations in
76 -- hand when we call tcMatchesFun...
77 checkArgs 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 -- This is one of two places places we call subFunTys
84 -- The point is that if expected_y is a "hole", we want
85 -- to make pat_tys and rhs_ty as "holes" too.
86 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
87 tcMatches match_ctxt pat_tys rhs_ty matches
90 doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
91 <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
92 n_pats = matchGroupArity matches
93 match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcPolyExpr }
96 @tcMatchesCase@ doesn't do the argument-count check because the
97 parser guarantees that each equation has exactly one argument.
100 tcMatchesCase :: TcMatchCtxt -- Case context
101 -> TcRhoType -- Type of scrutinee
102 -> MatchGroup Name -- The case alternatives
103 -> BoxyRhoType -- Type of whole case expressions
104 -> TcM (MatchGroup TcId) -- Translated alternatives
106 tcMatchesCase ctxt scrut_ty matches res_ty
107 = tcMatches ctxt [scrut_ty] res_ty matches
109 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId)
110 tcMatchLambda match res_ty
111 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
112 tcMatches match_ctxt pat_tys rhs_ty match
114 n_pats = matchGroupArity match
115 doc = sep [ ptext SLIT("The lambda expression")
116 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
117 -- The pprSetDepth makes the abstraction print briefly
118 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("arguments"))]
119 match_ctxt = MC { mc_what = LambdaExpr,
120 mc_body = tcPolyExpr }
123 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
126 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
127 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
129 match_ctxt = MC { mc_what = PatBindRhs,
130 mc_body = tcPolyExpr }
134 %************************************************************************
138 %************************************************************************
141 tcMatches :: TcMatchCtxt
142 -> [BoxySigmaType] -- Expected pattern types
143 -> BoxyRhoType -- Expected result-type of the Match.
145 -> TcM (MatchGroup TcId)
147 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
148 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
149 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
151 -> TcM (LHsExpr TcId) }
153 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
154 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
155 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
158 tcMatch :: TcMatchCtxt
159 -> [BoxySigmaType] -- Expected pattern types
160 -> BoxyRhoType -- Expected result-type of the Match.
164 tcMatch ctxt pat_tys rhs_ty match
165 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
167 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
168 = addErrCtxt (matchCtxt (mc_what ctxt) match) $
169 do { (pats', grhss') <- tcPats LamPat pats pat_tys rhs_ty $
170 tc_grhss ctxt maybe_rhs_sig grhss
171 ; returnM (Match pats' Nothing grhss') }
173 tc_grhss ctxt Nothing grhss rhs_ty
174 = tcGRHSs ctxt grhss rhs_ty -- No result signature
176 tc_grhss ctxt (Just res_sig) grhss rhs_ty
177 = do { (inner_ty, sig_tvs) <- tcPatSig ResSigCtxt res_sig rhs_ty
178 ; tcExtendTyVarEnv2 sig_tvs $
179 tcGRHSs ctxt grhss inner_ty }
182 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
184 -- Notice that we pass in the full res_ty, so that we get
185 -- good inference from simple things like
186 -- f = \(x::forall a.a->a) -> <stuff>
187 -- We used to force it to be a monotype when there was more than one guard
188 -- but we don't need to do that any more
190 tcGRHSs ctxt (GRHSs grhss binds) res_ty
191 = do { (binds', grhss') <- tcLocalBinds binds $
192 mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
194 ; returnM (GRHSs grhss' binds') }
197 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
199 tcGRHS ctxt res_ty (GRHS guards rhs)
200 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
202 ; return (GRHS guards' rhs') }
204 stmt_ctxt = PatGuard (mc_what ctxt)
208 %************************************************************************
210 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
212 %************************************************************************
215 tcDoStmts :: HsStmtContext Name
219 -> TcM (HsExpr TcId) -- Returns a HsDo
220 tcDoStmts ListComp stmts body res_ty
221 = do { elt_ty <- boxySplitListTy res_ty
222 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty $
223 tcBody (doBodyCtxt ListComp body) body
224 ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
226 tcDoStmts PArrComp stmts body res_ty
227 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
228 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty $
229 tcBody (doBodyCtxt PArrComp body) body
230 ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
232 tcDoStmts DoExpr stmts body res_ty
233 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
234 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
235 ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts res_ty' $
236 tcBody (doBodyCtxt DoExpr body) body
237 ; return (HsDo DoExpr stmts' body' res_ty') }
239 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
240 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
241 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
242 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
243 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
245 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
246 tcBody (doBodyCtxt ctxt body) body
248 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
249 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
250 ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
252 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
254 tcBody :: Message -> LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
255 tcBody ctxt body res_ty
256 = -- addErrCtxt ctxt $ -- This context adds little that is useful
257 tcPolyExpr body res_ty
261 %************************************************************************
265 %************************************************************************
269 = forall thing. HsStmtContext Name
271 -> BoxyRhoType -- Result type for comprehension
272 -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
273 -> TcM (Stmt TcId, thing)
275 -- The incoming BoxyRhoType may be refined by type refinements
276 -- before being passed to the thing_inside
278 tcStmts :: HsStmtContext Name
279 -> TcStmtChecker -- NB: higher-rank type
282 -> (BoxyRhoType -> TcM thing)
283 -> TcM ([LStmt TcId], thing)
285 -- Note the higher-rank type. stmt_chk is applied at different
286 -- types in the equations for tcStmts
288 tcStmts ctxt stmt_chk [] res_ty thing_inside
289 = do { thing <- thing_inside res_ty
290 ; return ([], thing) }
292 -- LetStmts are handled uniformly, regardless of context
293 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
294 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
295 tcStmts ctxt stmt_chk stmts res_ty thing_inside
296 ; return (L loc (LetStmt binds') : stmts', thing) }
298 -- For the vanilla case, handle the location-setting part
299 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
300 = do { (stmt', (stmts', thing)) <-
302 addErrCtxt (stmtCtxt ctxt stmt) $
303 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
305 tcStmts ctxt stmt_chk stmts res_ty' $
307 ; return (L loc stmt' : stmts', thing) }
309 --------------------------------
311 tcGuardStmt :: TcStmtChecker
312 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
313 = do { guard' <- tcMonoExpr guard boolTy
314 ; thing <- thing_inside res_ty
315 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
317 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
318 = do { (rhs', rhs_ty) <- tcInferRho rhs
319 ; (pat', thing) <- tcPat LamPat pat rhs_ty res_ty thing_inside
320 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
322 tcGuardStmt ctxt stmt res_ty thing_inside
323 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
326 --------------------------------
327 -- List comprehensions and PArrays
329 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
332 -- A generator, pat <- rhs
333 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
334 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
335 tcMonoExpr rhs (mkTyConApp m_tc [ty])
336 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
337 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
340 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
341 = do { rhs' <- tcMonoExpr rhs boolTy
342 ; thing <- thing_inside res_ty
343 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
345 -- A parallel set of comprehensions
346 -- [ (g x, h x) | ... ; let g v = ...
347 -- | ... ; let h v = ... ]
349 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
350 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
351 -- Similarly if we had an existential pattern match:
353 -- data T = forall a. Show a => C a
355 -- [ (show x, show y) | ... ; C x <- ...
356 -- | ... ; C y <- ... ]
358 -- Then we need the LIE from (show x, show y) to be simplified against
359 -- the bindings for x and y.
361 -- It's difficult to do this in parallel, so we rely on the renamer to
362 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
363 -- So the binders of the first parallel group will be in scope in the second
364 -- group. But that's fine; there's no shadowing to worry about.
366 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
367 = do { (pairs', thing) <- loop bndr_stmts_s
368 ; return (ParStmt pairs', thing) }
370 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
371 loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
372 ; return ([], thing) } -- matching in the branches
374 loop ((stmts, names) : pairs)
375 = do { (stmts', (ids, pairs', thing))
376 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
377 do { ids <- tcLookupLocalIds names
378 ; (pairs', thing) <- loop pairs
379 ; return (ids, pairs', thing) }
380 ; return ( (stmts', ids) : pairs', thing ) }
382 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
383 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
385 --------------------------------
387 -- The main excitement here is dealing with rebindable syntax
389 tcDoStmt :: TcType -- Monad type, m
392 tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
393 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
394 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
395 -- We should use type *inference* for the RHS computations, becuase of GADTs.
396 -- do { pat <- rhs; <rest> }
398 -- case rhs of { pat -> <rest> }
399 -- We do inference on rhs, so that information about its type can be refined
400 -- when type-checking the pattern.
402 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
404 -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
405 ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
406 mkFunTy pat_ty res_ty] res_ty
407 ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
408 -- If (but only if) the pattern can fail,
409 -- typecheck the 'fail' operator
410 ; fail_op' <- if isIrrefutableHsPat pat'
411 then return noSyntaxExpr
412 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
413 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
416 tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) res_ty thing_inside
417 = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
418 a_ty <- newFlexiTyVarTy liftedTypeKind
419 ; let rhs_ty = mkAppTy m_ty a_ty
420 then_ty = mkFunTys [rhs_ty, res_ty] res_ty
421 ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
422 ; rhs' <- tcPolyExpr rhs rhs_ty
423 ; thing <- thing_inside res_ty
424 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
426 tcDoStmt m_ty ctxt stmt res_ty thing_inside
427 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
429 --------------------------------
431 -- The distinctive features here are
433 -- (b) no rebindable syntax
435 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
437 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
438 = do { (rhs', pat_ty) <- tc_rhs rhs
439 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
440 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
442 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
443 = do { (rhs', elt_ty) <- tc_rhs rhs
444 ; thing <- thing_inside res_ty
445 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
447 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
448 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
449 ; let rec_ids = zipWith mkLocalId recNames rec_tys
450 ; tcExtendIdEnv rec_ids $ do
451 { (stmts', (later_ids, rec_rets))
452 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
453 -- ToDo: res_ty not really right
454 do { rec_rets <- zipWithM tc_ret recNames rec_tys
455 ; later_ids <- tcLookupLocalIds laterNames
456 ; return (later_ids, rec_rets) }
458 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
459 -- NB: The rec_ids for the recursive things
460 -- already scope over this part. This binding may shadow
461 -- some of them with polymorphic things with the same Name
462 -- (see note [RecStmt] in HsExpr)
463 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
465 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
468 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
469 tc_ret rec_name mono_ty
470 = do { poly_id <- tcLookupId rec_name
471 -- poly_id may have a polymorphic type
472 -- but mono_ty is just a monomorphic type variable
473 ; co_fn <- tcSubExp (idType poly_id) mono_ty
474 ; return (mkHsCoerce co_fn (HsVar poly_id)) }
476 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
477 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
482 %************************************************************************
484 \subsection{Errors and contexts}
486 %************************************************************************
488 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
489 number of args are used in each equation.
492 checkArgs :: Name -> MatchGroup Name -> TcM ()
493 checkArgs fun (MatchGroup (match1:matches) _)
494 | null bad_matches = return ()
496 = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
497 ptext SLIT("have different numbers of arguments"),
498 nest 2 (ppr (getLoc match1)),
499 nest 2 (ppr (getLoc (head bad_matches)))])
501 n_args1 = args_in_match match1
502 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
504 args_in_match :: LMatch Name -> Int
505 args_in_match (L _ (Match pats _ _)) = length pats
509 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
510 4 (pprMatch ctxt match)
512 doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
513 doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
516 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)