2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcMatches: Typecheck some @Matches@
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
16 module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda,
17 matchCtxt, TcMatchCtxt(..),
18 tcStmts, tcDoStmts, tcBody,
19 tcDoStmt, tcMDoStmt, tcGuardStmt
22 #include "HsVersions.h"
24 import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRho, tcMonoExpr, tcPolyExpr )
46 %************************************************************************
48 \subsection{tcMatchesFun, tcMatchesCase}
50 %************************************************************************
52 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
53 @FunMonoBind@. The second argument is the name of the function, which
54 is used in error messages. It checks that all the equations have the
55 same number of arguments before using @tcMatches@ to do the work.
58 tcMatchesFun :: Name -> Bool
60 -> BoxyRhoType -- Expected type of function
61 -> TcM (HsWrapper, MatchGroup TcId) -- Returns type of body
63 tcMatchesFun fun_name inf matches exp_ty
64 = do { -- Check that they all have the same no of arguments
65 -- Location is in the monad, set the caller so that
66 -- any inter-equation error messages get some vaguely
67 -- sensible location. Note: we have to do this odd
68 -- ann-grabbing, because we don't always have annotations in
69 -- hand when we call tcMatchesFun...
70 checkArgs 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 -- This is one of two places places we call subFunTys
77 -- The point is that if expected_y is a "hole", we want
78 -- to make pat_tys and rhs_ty as "holes" too.
79 ; subFunTys doc n_pats exp_ty $ \ pat_tys rhs_ty ->
80 tcMatches match_ctxt pat_tys rhs_ty matches
83 doc = ptext SLIT("The equation(s) for") <+> quotes (ppr fun_name)
84 <+> ptext SLIT("have") <+> speakNOf n_pats (ptext SLIT("argument"))
85 n_pats = matchGroupArity matches
86 match_ctxt = MC { mc_what = FunRhs fun_name inf, mc_body = tcBody }
89 @tcMatchesCase@ doesn't do the argument-count check because the
90 parser guarantees that each equation has exactly one argument.
93 tcMatchesCase :: TcMatchCtxt -- Case context
94 -> TcRhoType -- Type of scrutinee
95 -> MatchGroup Name -- The case alternatives
96 -> BoxyRhoType -- Type of whole case expressions
97 -> TcM (MatchGroup TcId) -- Translated alternatives
99 tcMatchesCase ctxt scrut_ty matches res_ty
100 = tcMatches ctxt [scrut_ty] res_ty matches
102 tcMatchLambda :: MatchGroup Name -> BoxyRhoType -> TcM (HsWrapper, MatchGroup TcId)
103 tcMatchLambda match res_ty
104 = subFunTys doc n_pats res_ty $ \ pat_tys rhs_ty ->
105 tcMatches match_ctxt pat_tys rhs_ty match
107 n_pats = matchGroupArity match
108 doc = sep [ ptext SLIT("The lambda expression")
109 <+> quotes (pprSetDepth 1 $ pprMatches LambdaExpr match),
110 -- The pprSetDepth makes the abstraction print briefly
111 ptext SLIT("has") <+> speakNOf n_pats (ptext SLIT("argument"))]
112 match_ctxt = MC { mc_what = LambdaExpr,
116 @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
119 tcGRHSsPat :: GRHSs Name -> BoxyRhoType -> TcM (GRHSs TcId)
120 -- Used for pattern bindings
121 tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (emptyRefinement, res_ty)
122 -- emptyRefinement: no refinement in a pattern binding
124 match_ctxt = MC { mc_what = PatBindRhs,
129 %************************************************************************
133 %************************************************************************
136 tcMatches :: TcMatchCtxt
137 -> [BoxySigmaType] -- Expected pattern types
138 -> BoxyRhoType -- Expected result-type of the Match.
140 -> TcM (MatchGroup TcId)
142 data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module
143 = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is
144 mc_body :: LHsExpr Name -- Type checker for a body of an alternative
145 -> (Refinement, BoxyRhoType)
146 -> TcM (LHsExpr TcId) }
148 tcMatches ctxt pat_tys rhs_ty (MatchGroup matches _)
149 = do { matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches
150 ; return (MatchGroup matches' (mkFunTys pat_tys rhs_ty)) }
153 tcMatch :: TcMatchCtxt
154 -> [BoxySigmaType] -- Expected pattern types
155 -> BoxyRhoType -- Expected result-type of the Match.
159 tcMatch ctxt pat_tys rhs_ty match
160 = wrapLocM (tc_match ctxt pat_tys rhs_ty) match
162 tc_match ctxt pat_tys rhs_ty match@(Match pats maybe_rhs_sig grhss)
163 = add_match_ctxt match $
164 do { (pats', grhss') <- tcLamPats pats pat_tys rhs_ty $
165 tc_grhss ctxt maybe_rhs_sig grhss
166 ; return (Match pats' Nothing grhss') }
168 tc_grhss ctxt Nothing grhss rhs_ty
169 = tcGRHSs ctxt grhss rhs_ty -- No result signature
171 -- Result type sigs are no longer supported
172 tc_grhss ctxt (Just res_sig) grhss (co, rhs_ty)
173 = do { addErr (ptext SLIT("Ignoring (deprecated) result type signature")
175 ; tcGRHSs ctxt grhss (co, rhs_ty) }
177 -- For (\x -> e), tcExpr has already said "In the expresssion \x->e"
178 -- so we don't want to add "In the lambda abstraction \x->e"
179 add_match_ctxt match thing_inside
180 = case mc_what ctxt of
181 LambdaExpr -> thing_inside
182 m_ctxt -> addErrCtxt (matchCtxt m_ctxt match) thing_inside
185 tcGRHSs :: TcMatchCtxt -> GRHSs Name -> (Refinement, BoxyRhoType)
188 -- Notice that we pass in the full res_ty, so that we get
189 -- good inference from simple things like
190 -- f = \(x::forall a.a->a) -> <stuff>
191 -- We used to force it to be a monotype when there was more than one guard
192 -- but we don't need to do that any more
194 tcGRHSs ctxt (GRHSs grhss binds) res_ty
195 = do { (binds', grhss') <- tcLocalBinds binds $
196 mappM (wrapLocM (tcGRHS ctxt res_ty)) grhss
198 ; returnM (GRHSs grhss' binds') }
201 tcGRHS :: TcMatchCtxt -> (Refinement, BoxyRhoType) -> GRHS Name -> TcM (GRHS TcId)
203 tcGRHS ctxt res_ty (GRHS guards rhs)
204 = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $
206 ; return (GRHS guards' rhs') }
208 stmt_ctxt = PatGuard (mc_what ctxt)
212 %************************************************************************
214 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
216 %************************************************************************
219 tcDoStmts :: HsStmtContext Name
223 -> TcM (HsExpr TcId) -- Returns a HsDo
224 tcDoStmts ListComp stmts body res_ty
225 = do { (elt_ty, coi) <- boxySplitListTy res_ty
226 ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts
227 (emptyRefinement,elt_ty) $
229 ; return $ mkHsWrapCoI coi
230 (HsDo ListComp stmts' body' (mkListTy elt_ty)) }
232 tcDoStmts PArrComp stmts body res_ty
233 = do { (elt_ty, coi) <- boxySplitPArrTy res_ty
234 ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts
235 (emptyRefinement, elt_ty) $
237 ; return $ mkHsWrapCoI coi
238 (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) }
240 tcDoStmts DoExpr stmts body res_ty
241 = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
242 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
243 ; (stmts', body') <- tcStmts DoExpr (tcDoStmt m_ty) stmts
244 (emptyRefinement, res_ty') $
246 ; return $ mkHsWrapCoI coi (HsDo DoExpr stmts' body' res_ty') }
248 tcDoStmts ctxt@(MDoExpr _) stmts body res_ty
249 = do { ((m_ty, elt_ty), coi) <- boxySplitAppTy res_ty
250 ; let res_ty' = mkAppTy m_ty elt_ty -- The boxySplit consumes res_ty
251 tc_rhs rhs = withBox liftedTypeKind $ \ pat_ty ->
252 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
254 ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts
255 (emptyRefinement, res_ty') $
258 ; let names = [mfixName, bindMName, thenMName, returnMName, failMName]
259 ; insts <- mapM (newMethodFromName DoOrigin m_ty) names
262 (HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty') }
264 tcDoStmts ctxt stmts body res_ty = pprPanic "tcDoStmts" (pprStmtContext ctxt)
266 tcBody :: LHsExpr Name -> (Refinement, BoxyRhoType) -> TcM (LHsExpr TcId)
267 tcBody body (reft, res_ty)
268 = do { traceTc (text "tcBody" <+> ppr res_ty <+> ppr reft)
269 ; let (co, res_ty') = refineResType reft res_ty
270 ; body' <- tcPolyExpr body res_ty'
271 ; return (mkLHsWrap co body') }
275 %************************************************************************
279 %************************************************************************
283 = forall thing. HsStmtContext Name
285 -> (Refinement, BoxyRhoType) -- Result type for comprehension
286 -> ((Refinement,BoxyRhoType) -> TcM thing) -- Checker for what follows the stmt
287 -> TcM (Stmt TcId, thing)
289 -- The incoming BoxyRhoType may be refined by type refinements
290 -- before being passed to the thing_inside
292 tcStmts :: HsStmtContext Name
293 -> TcStmtChecker -- NB: higher-rank type
295 -> (Refinement, BoxyRhoType)
296 -> ((Refinement, BoxyRhoType) -> TcM thing)
297 -> TcM ([LStmt TcId], thing)
299 -- Note the higher-rank type. stmt_chk is applied at different
300 -- types in the equations for tcStmts
302 tcStmts ctxt stmt_chk [] res_ty thing_inside
303 = do { thing <- thing_inside res_ty
304 ; return ([], thing) }
306 -- LetStmts are handled uniformly, regardless of context
307 tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside
308 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
309 tcStmts ctxt stmt_chk stmts res_ty thing_inside
310 ; return (L loc (LetStmt binds') : stmts', thing) }
312 -- For the vanilla case, handle the location-setting part
313 tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
314 = do { (stmt', (stmts', thing)) <-
316 addErrCtxt (stmtCtxt ctxt stmt) $
317 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
319 tcStmts ctxt stmt_chk stmts res_ty' $
321 ; return (L loc stmt' : stmts', thing) }
323 --------------------------------
325 tcGuardStmt :: TcStmtChecker
326 tcGuardStmt ctxt (ExprStmt guard _ _) res_ty thing_inside
327 = do { guard' <- tcMonoExpr guard boolTy
328 ; thing <- thing_inside res_ty
329 ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) }
331 tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside
332 = do { (rhs', rhs_ty) <- tcInferRho rhs
333 ; (pat', thing) <- tcLamPat pat rhs_ty res_ty thing_inside
334 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
336 tcGuardStmt ctxt stmt res_ty thing_inside
337 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
340 --------------------------------
341 -- List comprehensions and PArrays
343 tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray)
346 -- A generator, pat <- rhs
347 tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside
348 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ ty ->
349 tcMonoExpr rhs (mkTyConApp m_tc [ty])
350 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
351 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
354 tcLcStmt m_tc ctxt (ExprStmt rhs _ _) res_ty thing_inside
355 = do { rhs' <- tcMonoExpr rhs boolTy
356 ; thing <- thing_inside res_ty
357 ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) }
359 -- A parallel set of comprehensions
360 -- [ (g x, h x) | ... ; let g v = ...
361 -- | ... ; let h v = ... ]
363 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
364 -- (g x, h x) up through both lots of bindings (so we get the bindInstsOfLocalFuns).
365 -- Similarly if we had an existential pattern match:
367 -- data T = forall a. Show a => C a
369 -- [ (show x, show y) | ... ; C x <- ...
370 -- | ... ; C y <- ... ]
372 -- Then we need the LIE from (show x, show y) to be simplified against
373 -- the bindings for x and y.
375 -- It's difficult to do this in parallel, so we rely on the renamer to
376 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
377 -- So the binders of the first parallel group will be in scope in the second
378 -- group. But that's fine; there's no shadowing to worry about.
380 tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside
381 = do { (pairs', thing) <- loop bndr_stmts_s
382 ; return (ParStmt pairs', thing) }
384 -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing)
385 loop [] = do { thing <- thing_inside elt_ty -- No refinement from pattern
386 ; return ([], thing) } -- matching in the branches
388 loop ((stmts, names) : pairs)
389 = do { (stmts', (ids, pairs', thing))
390 <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ elt_ty' ->
391 do { ids <- tcLookupLocalIds names
392 ; (pairs', thing) <- loop pairs
393 ; return (ids, pairs', thing) }
394 ; return ( (stmts', ids) : pairs', thing ) }
396 tcLcStmt m_tc ctxt stmt elt_ty thing_inside
397 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
399 --------------------------------
401 -- The main excitement here is dealing with rebindable syntax
403 tcDoStmt :: TcType -- Monad type, m
406 tcDoStmt m_ty ctxt (BindStmt pat rhs bind_op fail_op) reft_res_ty@(_,res_ty) thing_inside
407 = do { (rhs', pat_ty) <- withBox liftedTypeKind $ \ pat_ty ->
408 tcMonoExpr rhs (mkAppTy m_ty pat_ty)
409 -- We should use type *inference* for the RHS computations, becuase of GADTs.
410 -- do { pat <- rhs; <rest> }
412 -- case rhs of { pat -> <rest> }
413 -- We do inference on rhs, so that information about its type can be refined
414 -- when type-checking the pattern.
416 ; (pat', thing) <- tcLamPat pat pat_ty reft_res_ty thing_inside
418 -- Deal with rebindable syntax; (>>=) :: m a -> (a -> m b) -> m b
419 ; let bind_ty = mkFunTys [mkAppTy m_ty pat_ty,
420 mkFunTy pat_ty res_ty] res_ty
421 ; bind_op' <- tcSyntaxOp DoOrigin bind_op bind_ty
422 -- If (but only if) the pattern can fail,
423 -- typecheck the 'fail' operator
424 ; fail_op' <- if isIrrefutableHsPat pat'
425 then return noSyntaxExpr
426 else tcSyntaxOp DoOrigin fail_op (mkFunTy stringTy res_ty)
427 ; return (BindStmt pat' rhs' bind_op' fail_op', thing) }
430 tcDoStmt m_ty ctxt (ExprStmt rhs then_op _) reft_res_ty@(_,res_ty) thing_inside
431 = do { -- Deal with rebindable syntax; (>>) :: m a -> m b -> m b
432 a_ty <- newFlexiTyVarTy liftedTypeKind
433 ; let rhs_ty = mkAppTy m_ty a_ty
434 then_ty = mkFunTys [rhs_ty, res_ty] res_ty
435 ; then_op' <- tcSyntaxOp DoOrigin then_op then_ty
436 ; rhs' <- tcPolyExpr rhs rhs_ty
437 ; thing <- thing_inside reft_res_ty
438 ; return (ExprStmt rhs' then_op' rhs_ty, thing) }
440 tcDoStmt m_ty ctxt stmt res_ty thing_inside
441 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
443 --------------------------------
445 -- The distinctive features here are
447 -- (b) no rebindable syntax
449 tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference
451 tcMDoStmt tc_rhs ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside
452 = do { (rhs', pat_ty) <- tc_rhs rhs
453 ; (pat', thing) <- tcLamPat pat pat_ty res_ty thing_inside
454 ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) }
456 tcMDoStmt tc_rhs ctxt (ExprStmt rhs then_op _) res_ty thing_inside
457 = do { (rhs', elt_ty) <- tc_rhs rhs
458 ; thing <- thing_inside res_ty
459 ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) }
461 tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _) res_ty thing_inside
462 = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind
463 ; let rec_ids = zipWith mkLocalId recNames rec_tys
464 ; tcExtendIdEnv rec_ids $ do
465 { (stmts', (later_ids, rec_rets))
466 <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ res_ty' ->
467 -- ToDo: res_ty not really right
468 do { rec_rets <- zipWithM tc_ret recNames rec_tys
469 ; later_ids <- tcLookupLocalIds laterNames
470 ; return (later_ids, rec_rets) }
472 ; (thing,lie) <- tcExtendIdEnv later_ids (getLIE (thing_inside res_ty))
473 -- NB: The rec_ids for the recursive things
474 -- already scope over this part. This binding may shadow
475 -- some of them with polymorphic things with the same Name
476 -- (see note [RecStmt] in HsExpr)
477 ; lie_binds <- bindInstsOfLocalFuns lie later_ids
479 ; return (RecStmt stmts' later_ids rec_ids rec_rets lie_binds, thing)
482 -- Unify the types of the "final" Ids with those of "knot-tied" Ids
483 tc_ret rec_name mono_ty
484 = do { poly_id <- tcLookupId rec_name
485 -- poly_id may have a polymorphic type
486 -- but mono_ty is just a monomorphic type variable
487 ; co_fn <- tcSubExp (idType poly_id) mono_ty
488 ; return (mkHsWrap co_fn (HsVar poly_id)) }
490 tcMDoStmt tc_rhs ctxt stmt res_ty thing_inside
491 = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt)
496 %************************************************************************
498 \subsection{Errors and contexts}
500 %************************************************************************
502 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
503 number of args are used in each equation.
506 checkArgs :: Name -> MatchGroup Name -> TcM ()
507 checkArgs fun (MatchGroup (match1:matches) _)
508 | null bad_matches = return ()
510 = failWithTc (vcat [ptext SLIT("Equations for") <+> quotes (ppr fun) <+>
511 ptext SLIT("have different numbers of arguments"),
512 nest 2 (ppr (getLoc match1)),
513 nest 2 (ppr (getLoc (head bad_matches)))])
515 n_args1 = args_in_match match1
516 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
518 args_in_match :: LMatch Name -> Int
519 args_in_match (L _ (Match pats _ _)) = length pats
520 checkArgs fun other = panic "TcPat.checkArgs" -- Matches always non-empty
524 matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colon)
525 4 (pprMatch ctxt match)
527 stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pprStmtContext ctxt <> colon)