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 )
46 import SrcLoc ( Located(..), getLoc )
47 import ErrUtils ( Message )
50 %************************************************************************
52 \subsection{tcMatchesFun, tcMatchesCase}
54 %************************************************************************
56 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
57 @FunMonoBind@. The second argument is the name of the function, which
58 is used in error messages. It checks that all the equations have the
59 same number of arguments before using @tcMatches@ to do the work.
64 -> BoxyRhoType -- Expected type of function
65 -> TcM (ExprCoFn, MatchGroup TcId) -- Returns type of body
67 tcMatchesFun fun_name matches exp_ty
68 = do { -- Check that they all have the same no of arguments
69 -- Location is in the monad, set the caller so that
70 -- any inter-equation error messages get some vaguely
71 -- sensible location. Note: we have to do this odd
72 -- ann-grabbing, because we don't always have annotations in
73 -- hand when we call tcMatchesFun...
74 checkArgs fun_name matches
76 -- ToDo: Don't use "expected" stuff if there ain't a type signature
77 -- because inconsistency between branches
78 -- may show up as something wrong with the (non-existent) type signature
80 -- This is one of two places places we call subFunTys
81 -- The point is that if expected_y is a "hole", we want
82 -- to make pat_tys and rhs_ty as "holes" too.
83 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
84 tcMatches match_ctxt pat_tys rhs_ty matches
87 doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
88 <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
89 n_pats = matchGroupArity matches
90 match_ctxt = MC { mc_what = FunRhs fun_name, mc_body = tcPolyExpr }
93 @tcMatchesCase@ doesn't do the argument-count check because the
94 parser guarantees that each equation has exactly one argument.
97 tcMatchesCase :: TcMatchCtxt -- Case context
98 -> TcRhoType -- Type of scrutinee
99 -> MatchGroup Name -- The case alternatives
100 -> BoxyRhoType -- Type of whole case expressions
101 -> TcM (MatchGroup TcId) -- Translated alternatives
103 tcMatchesCase ctxt scrut_ty matches res_ty
104 = tcMatches ctxt [scrut_ty] res_ty matches
106 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (ExprCoFn, MatchGroup TcId)
107 tcMatchLambda match res_ty
108 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
109 tcMatches match_ctxt pat_tys rhs_ty match
111 n_pats = matchGroupArity match
112 doc = sep [ ptext SLIT("The lambda expression")
113 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
114 -- The pprSetDepth makes the abstraction print briefly
115 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
116 match_ctxt = MC { mc_what = LambdaExpr,
117 mc_body = tcPolyExpr }
120 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
123 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
124 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss res_ty
126 match_ctxt = MC { mc_what = PatBindRhs,
127 mc_body = tcPolyExpr }
131 %************************************************************************
135 %************************************************************************
138 tcMatches :: TcMatchCtxt
139 -> [BoxySigmaType] -- Expected pattern types
140 -> BoxyRhoType -- Expected result-type of the Match.
142 -> TcM (MatchGroup TcId)
144 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
145 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
146 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
148 -> TcM (LHsExpr TcId) }
150 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
151 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
152 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
155 tcMatch :: TcMatchCtxt
156 -> [BoxySigmaType] -- Expected pattern types
157 -> BoxyRhoType -- Expected result-type of the Match.
161 tcMatch ctxt pat_tys rhs_ty match
162 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
164 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
165 = addErrCtxt (matchCtxt (mc_what ctxt) match) $
166 do { (pats', grhss') <- tcPats LamPat pats pat_tys rhs_ty $
167 tc_grhss ctxt maybe_rhs_sig grhss
168 ; returnM (Match pats' Nothing grhss') }
170 tc_grhss ctxt Nothing grhss rhs_ty
171 = tcGRHSs ctxt grhss rhs_ty -- No result signature
173 tc_grhss ctxt (Just res_sig) grhss rhs_ty
174 = do { (inner_ty, sig_tvs) <- tcPatSig ResSigCtxt res_sig rhs_ty
175 ; tcExtendTyVarEnv2 sig_tvs $
176 tcGRHSs ctxt grhss inner_ty }
179 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
181 -- Notice that we pass in the full res_ty, so that we get
182 -- good inference from simple things like
183 -- f = \(x::forall a.a->a) -> <stuff>
184 -- We used to force it to be a monotype when there was more than one guard
185 -- but we don't need to do that any more
187 tcGRHSs ctxt (GRHSs grhss binds) res_ty
188 = do { (binds', grhss') <- tcLocalBinds binds $
189 mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
191 ; returnM (GRHSs grhss' binds') }
194 tcGRHS :: TcMatchCtxt -> BoxyRhoType -> GRHS Name -> TcM (GRHS TcId)
196 tcGRHS ctxt res_ty (GRHS guards rhs)
197 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
199 ; return (GRHS guards' rhs') }
201 stmt_ctxt = PatGuard (mc_what ctxt)
205 %************************************************************************
207 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
209 %************************************************************************
212 tcDoStmts :: HsStmtContext Name
216 -> TcM (HsExpr TcId) -- Returns a HsDo
217 tcDoStmts ListComp stmts body res_ty
218 = do { elt_ty <- boxySplitListTy res_ty
219 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty $
220 tcBody (doBodyCtxt ListComp body) body
221 ; return (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
223 tcDoStmts PArrComp stmts body res_ty
224 = do { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
225 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty $
226 tcBody (doBodyCtxt PArrComp body) body
227 ; return (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
229 tcDoStmts DoExpr stmts body res_ty
230 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
231 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
232 ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts res_ty' $
233 tcBody (doBodyCtxt DoExpr body) body
234 ; return (HsDo DoExpr stmts' body' res_ty') }
236 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
237 = do { (m_ty, elt_ty) <- boxySplitAppTy res_ty
238 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
239 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
240 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
242 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $
243 tcBody (doBodyCtxt ctxt body) body
245 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
246 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
247 ; return (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
249 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
251 tcBody :: Message -> LHsExpr Name -> BoxyRhoType -> TcM (LHsExpr TcId)
252 tcBody ctxt body res_ty
253 = -- addErrCtxt ctxt $ -- This context adds little that is useful
254 tcPolyExpr body res_ty
258 %************************************************************************
262 %************************************************************************
266 = forall thing. HsStmtContext Name
268 -> BoxyRhoType -- Result type for comprehension
269 -> (BoxyRhoType -> TcM thing) -- Checker for what follows the stmt
270 -> TcM (Stmt TcId, thing)
272 -- The incoming BoxyRhoType may be refined by type refinements
273 -- before being passed to the thing_inside
275 tcStmts :: HsStmtContext Name
276 -> TcStmtChecker -- NB: higher-rank type
279 -> (BoxyRhoType -> TcM thing)
280 -> TcM ([LStmt TcId], thing)
282 -- Note the higher-rank type. stmt_chk is applied at different
283 -- types in the equations for tcStmts
285 tcStmts ctxt stmt_chk [] res_ty thing_inside
286 = do { thing <- thing_inside res_ty
287 ; return ([], thing) }
289 -- LetStmts are handled uniformly, regardless of context
290 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
291 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
292 tcStmts ctxt stmt_chk stmts res_ty thing_inside
293 ; return (L loc (LetStmt binds') : stmts', thing) }
295 -- For the vanilla case, handle the location-setting part
296 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
297 = do { (stmt', (stmts', thing)) <-
299 addErrCtxt (stmtCtxt ctxt stmt) $
300 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
302 tcStmts ctxt stmt_chk stmts res_ty' $
304 ; return (L loc stmt' : stmts', thing) }
306 --------------------------------
308 tcGuardStmt :: TcStmtChecker
309 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
310 = do { guard' <- tcMonoExpr guard boolTy
311 ; thing <- thing_inside res_ty
312 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
314 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
315 = do { (rhs', rhs_ty) <- tcInferRho rhs
316 ; (pat', thing) <- tcPat LamPat pat rhs_ty res_ty thing_inside
317 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
319 tcGuardStmt ctxt stmt res_ty thing_inside
320 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
323 --------------------------------
324 -- List comprehensions and PArrays
326 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
329 -- A generator, pat <- rhs
330 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
331 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
332 tcMonoExpr rhs (mkTyConApp m_tc [ty])
333 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
334 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
337 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
338 = do { rhs' <- tcMonoExpr rhs boolTy
339 ; thing <- thing_inside res_ty
340 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
342 -- A parallel set of comprehensions
343 -- [ (g x, h x) | ... ; let g v = ...
344 -- | ... ; let h v = ... ]
346 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
347 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
348 -- Similarly if we had an existential pattern match:
350 -- data T = forall a. Show a => C a
352 -- [ (show x, show y) | ... ; C x <- ...
353 -- | ... ; C y <- ... ]
355 -- Then we need the LIE from (show x, show y) to be simplified against
356 -- the bindings for x and y.
358 -- It's difficult to do this in parallel, so we rely on the renamer to
359 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
360 -- So the binders of the first parallel group will be in scope in the second
361 -- group. But that's fine; there's no shadowing to worry about.
363 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
364 = do { (pairs', thing) <- loop bndr_stmts_s
365 ; return (ParStmt pairs', thing) }
367 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
368 loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
369 ; return ([], thing) } -- matching in the branches
371 loop ((stmts, names) : pairs)
372 = do { (stmts', (ids, pairs', thing))
373 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
374 do { ids <- tcLookupLocalIds names
375 ; (pairs', thing) <- loop pairs
376 ; return (ids, pairs', thing) }
377 ; return ( (stmts', ids) : pairs', thing ) }
379 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
380 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
382 --------------------------------
384 -- The main excitement here is dealing with rebindable syntax
386 tcDoStmt :: TcType -- Monad type, m
389 tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
390 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
391 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
392 -- We should use type *inference* for the RHS computations, becuase of GADTs.
393 -- do { pat <- rhs; <rest> }
395 -- case rhs of { pat -> <rest> }
396 -- We do inference on rhs, so that information about its type can be refined
397 -- when type-checking the pattern.
399 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
401 -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
402 ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
403 mkFunTy pat_ty res_ty] res_ty
404 ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
405 -- If (but only if) the pattern can fail,
406 -- typecheck the 'fail' operator
407 ; fail_op' <- if isIrrefutableHsPat pat'
408 then return noSyntaxExpr
409 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
410 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
413 tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) res_ty thing_inside
414 = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
415 a_ty <- newFlexiTyVarTy liftedTypeKind
416 ; let rhs_ty = mkAppTy m_ty a_ty
417 then_ty = mkFunTys [rhs_ty, res_ty] res_ty
418 ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
419 ; rhs' <- tcPolyExpr rhs rhs_ty
420 ; thing <- thing_inside res_ty
421 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
423 tcDoStmt m_ty ctxt stmt res_ty thing_inside
424 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
426 --------------------------------
428 -- The distinctive features here are
430 -- (b) no rebindable syntax
432 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
434 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
435 = do { (rhs', pat_ty) <- tc_rhs rhs
436 ; (pat', thing) <- tcPat LamPat pat pat_ty res_ty thing_inside
437 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
439 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
440 = do { (rhs', elt_ty) <- tc_rhs rhs
441 ; thing <- thing_inside res_ty
442 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
444 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
445 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
446 ; let rec_ids = zipWith mkLocalId recNames rec_tys
447 ; tcExtendIdEnv rec_ids $ do
448 { (stmts', (later_ids, rec_rets))
449 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
450 -- ToDo: res_ty not really right
451 do { rec_rets <- zipWithM tc_ret recNames rec_tys
452 ; later_ids <- tcLookupLocalIds laterNames
453 ; return (later_ids, rec_rets) }
455 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
456 -- NB: The rec_ids for the recursive things
457 -- already scope over this part. This binding may shadow
458 -- some of them with polymorphic things with the same Name
459 -- (see note [RecStmt] in HsExpr)
460 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
462 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
465 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
466 tc_ret rec_name mono_ty
467 = do { poly_id <- tcLookupId rec_name
468 -- poly_id may have a polymorphic type
469 -- but mono_ty is just a monomorphic type variable
470 ; co_fn <- tcSubExp (idType poly_id) mono_ty
471 ; return (mkHsCoerce co_fn (HsVar poly_id)) }
473 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
474 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
479 %************************************************************************
481 \subsection{Errors and contexts}
483 %************************************************************************
485 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
486 number of args are used in each equation.
489 checkArgs :: Name -> MatchGroup Name -> TcM ()
490 checkArgs fun (MatchGroup (match1:matches) _)
491 | null bad_matches = return ()
493 = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
494 ptext SLIT("have different numbers of arguments"),
495 nest 2 (ppr (getLoc match1)),
496 nest 2 (ppr (getLoc (head bad_matches)))])
498 n_args1 = args_in_match match1
499 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
501 args_in_match :: LMatch Name -> Int
502 args_in_match (L _ (Match pats _ _)) = length pats
506 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
507 4 (pprMatch ctxt match)
509 doBodyCtxt :: HsStmtContext Name -> LHsExpr Name -> SDoc
510 doBodyCtxt ctxt body = hang (ptext SLIT("In the result of") <+> pprStmtContext ctxt <> colon)
513 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)