never executed always true always false
1
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE RankNTypes #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE TupleSections #-}
7 {-# LANGUAGE TypeFamilies #-}
8
9 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
10
11 {-
12 (c) The University of Glasgow 2006
13 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
14
15 -}
16
17 -- | Typecheck some @Matches@
18 module GHC.Tc.Gen.Match
19 ( tcMatchesFun
20 , tcGRHS
21 , tcGRHSsPat
22 , tcMatchesCase
23 , tcMatchLambda
24 , TcMatchCtxt(..)
25 , TcStmtChecker
26 , TcExprStmtChecker
27 , TcCmdStmtChecker
28 , tcStmts
29 , tcStmtsAndThen
30 , tcDoStmts
31 , tcBody
32 , tcDoStmt
33 , tcGuardStmt
34 )
35 where
36
37 import GHC.Prelude
38
39 import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
40 , tcMonoExpr, tcMonoExprNC, tcExpr
41 , tcCheckMonoExpr, tcCheckMonoExprNC
42 , tcCheckPolyExpr )
43
44 import GHC.Tc.Errors.Types
45 import GHC.Tc.Utils.Monad
46 import GHC.Tc.Utils.Env
47 import GHC.Tc.Gen.Pat
48 import GHC.Tc.Gen.Head( tcCheckId )
49 import GHC.Tc.Utils.TcMType
50 import GHC.Tc.Utils.TcType
51 import GHC.Tc.Gen.Bind
52 import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep )
53 import GHC.Tc.Utils.Unify
54 import GHC.Tc.Types.Origin
55 import GHC.Tc.Types.Evidence
56
57 import GHC.Core.Multiplicity
58 import GHC.Core.UsageEnv
59 import GHC.Core.TyCon
60 -- Create chunkified tuple tybes for monad comprehensions
61 import GHC.Core.Make
62
63 import GHC.Hs
64
65 import GHC.Builtin.Types
66 import GHC.Builtin.Types.Prim
67
68 import GHC.Utils.Outputable
69 import GHC.Utils.Panic
70 import GHC.Utils.Misc
71 import GHC.Driver.Session ( getDynFlags )
72
73 import GHC.Types.Error
74 import GHC.Types.Fixity (LexicalFixity(..))
75 import GHC.Types.Name
76 import GHC.Types.Id
77 import GHC.Types.SrcLoc
78
79 import Control.Monad
80 import Control.Arrow ( second )
81
82 {-
83 ************************************************************************
84 * *
85 \subsection{tcMatchesFun, tcMatchesCase}
86 * *
87 ************************************************************************
88
89 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
90 @FunMonoBind@. The second argument is the name of the function, which
91 is used in error messages. It checks that all the equations have the
92 same number of arguments before using @tcMatches@ to do the work.
93 -}
94
95 tcMatchesFun :: LocatedN Id -- MatchContext Id
96 -> MatchGroup GhcRn (LHsExpr GhcRn)
97 -> ExpRhoType -- Expected type of function
98 -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
99 -- Returns type of body
100 tcMatchesFun fun_id matches exp_ty
101 = do { -- Check that they all have the same no of arguments
102 -- Location is in the monad, set the caller so that
103 -- any inter-equation error messages get some vaguely
104 -- sensible location. Note: we have to do this odd
105 -- ann-grabbing, because we don't always have annotations in
106 -- hand when we call tcMatchesFun...
107 traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
108 ; checkArgs fun_name matches
109
110 ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
111 -- NB: exp_type may be polymorphic, but
112 -- matchExpectedFunTys can cope with that
113 tcScalingUsage Many $
114 -- toplevel bindings and let bindings are, at the
115 -- moment, always unrestricted. The value being bound
116 -- must, accordingly, be unrestricted. Hence them
117 -- being scaled by Many. When let binders come with a
118 -- multiplicity, then @tcMatchesFun@ will have to take
119 -- a multiplicity argument, and scale accordingly.
120 tcMatches match_ctxt pat_tys rhs_ty matches }
121 where
122 fun_name = idName (unLoc fun_id)
123 arity = matchGroupArity matches
124 herald = text "The equation(s) for"
125 <+> quotes (ppr fun_name) <+> text "have"
126 ctxt = GenSigCtxt -- Was: FunSigCtxt fun_name True
127 -- But that's wrong for f :: Int -> forall a. blah
128 what = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }
129 -- Careful: this fun_id could be an unfilled
130 -- thunk from fixM in tcMonoBinds, so we're
131 -- not allowed to look at it, except for
132 -- idName.
133 -- See Note [fixM for rhs_ty in tcMonoBinds]
134 match_ctxt = MC { mc_what = what, mc_body = tcBody }
135 strictness
136 | [L _ match] <- unLoc $ mg_alts matches
137 , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
138 = SrcStrict
139 | otherwise
140 = NoSrcStrict
141
142 {-
143 @tcMatchesCase@ doesn't do the argument-count check because the
144 parser guarantees that each equation has exactly one argument.
145 -}
146
147 tcMatchesCase :: (AnnoBody body) =>
148 TcMatchCtxt body -- Case context
149 -> Scaled TcSigmaType -- Type of scrutinee
150 -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives
151 -> ExpRhoType -- Type of whole case expressions
152 -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
153 -- Translated alternatives
154 -- wrapper goes from MatchGroup's ty to expected ty
155
156 tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty
157 = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches
158
159 tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
160 -> TcMatchCtxt HsExpr
161 -> MatchGroup GhcRn (LHsExpr GhcRn)
162 -> ExpRhoType
163 -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
164 tcMatchLambda herald match_ctxt match res_ty
165 = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->
166 tcMatches match_ctxt pat_tys rhs_ty match
167 where
168 n_pats | isEmptyMatchGroup match = 1 -- must be lambda-case
169 | otherwise = matchGroupArity match
170
171 -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
172
173 tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
174 -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
175 -- Used for pattern bindings
176 tcGRHSsPat grhss res_ty
177 = tcScalingUsage Many $
178 -- Like in tcMatchesFun, this scaling happens because all
179 -- let bindings are unrestricted. A difference, here, is
180 -- that when this is not the case, any more, we will have to
181 -- make sure that the pattern is strict, otherwise this will
182 -- desugar to incorrect code.
183 tcGRHSs match_ctxt grhss res_ty
184 where
185 match_ctxt :: TcMatchCtxt HsExpr -- AZ
186 match_ctxt = MC { mc_what = PatBindRhs,
187 mc_body = tcBody }
188
189 {- *********************************************************************
190 * *
191 tcMatch
192 * *
193 ********************************************************************* -}
194
195 data TcMatchCtxt body -- c.f. TcStmtCtxt, also in this module
196 = MC { mc_what :: HsMatchContext GhcTc, -- What kind of thing this is
197 mc_body :: LocatedA (body GhcRn) -- Type checker for a body of
198 -- an alternative
199 -> ExpRhoType
200 -> TcM (LocatedA (body GhcTc)) }
201
202 type AnnoBody body
203 = ( Outputable (body GhcRn)
204 , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
205 , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
206 , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
207 , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
208 , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
209 , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
210 , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
211 , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
212 )
213
214 -- | Type-check a MatchGroup.
215 tcMatches :: (AnnoBody body ) => TcMatchCtxt body
216 -> [Scaled ExpSigmaType] -- Expected pattern types
217 -> ExpRhoType -- Expected result-type of the Match.
218 -> MatchGroup GhcRn (LocatedA (body GhcRn))
219 -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
220
221 tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
222 , mg_origin = origin })
223 | null matches -- Deal with case e of {}
224 -- Since there are no branches, no one else will fill in rhs_ty
225 -- when in inference mode, so we must do it ourselves,
226 -- here, using expTypeToType
227 = do { tcEmitBindingUsage bottomUE
228 ; pat_tys <- mapM scaledExpTypeToType pat_tys
229 ; rhs_ty <- expTypeToType rhs_ty
230 ; _concrete_evs <- zipWithM
231 (\ i (Scaled _ pat_ty) ->
232 hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty)
233 [1..] pat_tys
234 ; return (MG { mg_alts = L l []
235 , mg_ext = MatchGroupTc pat_tys rhs_ty
236 , mg_origin = origin }) }
237
238 | otherwise
239 = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches
240 ; let (usages,matches') = unzip umatches
241 ; tcEmitBindingUsage $ supUEs usages
242 ; pat_tys <- mapM readScaledExpType pat_tys
243 ; rhs_ty <- readExpType rhs_ty
244 ; _concrete_evs <- zipWithM
245 (\ i (Scaled _ pat_ty) ->
246 hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty)
247 [1..] pat_tys
248 ; return (MG { mg_alts = L l matches'
249 , mg_ext = MatchGroupTc pat_tys rhs_ty
250 , mg_origin = origin }) }
251
252 -------------
253 tcMatch :: (AnnoBody body) => TcMatchCtxt body
254 -> [Scaled ExpSigmaType] -- Expected pattern types
255 -> ExpRhoType -- Expected result-type of the Match.
256 -> LMatch GhcRn (LocatedA (body GhcRn))
257 -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
258
259 tcMatch ctxt pat_tys rhs_ty match
260 = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match
261 where
262 tc_match ctxt pat_tys rhs_ty
263 match@(Match { m_pats = pats, m_grhss = grhss })
264 = add_match_ctxt match $
265 do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
266 tcGRHSs ctxt grhss rhs_ty
267 ; return (Match { m_ext = noAnn
268 , m_ctxt = mc_what ctxt, m_pats = pats'
269 , m_grhss = grhss' }) }
270
271 -- For (\x -> e), tcExpr has already said "In the expression \x->e"
272 -- so we don't want to add "In the lambda abstraction \x->e"
273 add_match_ctxt match thing_inside
274 = case mc_what ctxt of
275 LambdaExpr -> thing_inside
276 _ -> addErrCtxt (pprMatchInCtxt match) thing_inside
277
278 -------------
279 tcGRHSs :: AnnoBody body
280 => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
281 -> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
282
283 -- Notice that we pass in the full res_ty, so that we get
284 -- good inference from simple things like
285 -- f = \(x::forall a.a->a) -> <stuff>
286 -- We used to force it to be a monotype when there was more than one guard
287 -- but we don't need to do that any more
288
289 tcGRHSs ctxt (GRHSs _ grhss binds) res_ty
290 = do { (binds', ugrhss)
291 <- tcLocalBinds binds $
292 mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss
293 ; let (usages, grhss') = unzip ugrhss
294 ; tcEmitBindingUsage $ supUEs usages
295 ; return (GRHSs emptyComments grhss' binds') }
296
297 -------------
298 tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
299 -> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
300
301 tcGRHS ctxt res_ty (GRHS _ guards rhs)
302 = do { (guards', rhs')
303 <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
304 mc_body ctxt rhs
305 ; return (GRHS noAnn guards' rhs') }
306 where
307 stmt_ctxt = PatGuard (mc_what ctxt)
308
309 {-
310 ************************************************************************
311 * *
312 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
313 * *
314 ************************************************************************
315 -}
316
317 tcDoStmts :: HsDoFlavour
318 -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
319 -> ExpRhoType
320 -> TcM (HsExpr GhcTc) -- Returns a HsDo
321 tcDoStmts ListComp (L l stmts) res_ty
322 = do { res_ty <- expTypeToType res_ty
323 ; (co, elt_ty) <- matchExpectedListTy res_ty
324 ; let list_ty = mkListTy elt_ty
325 ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts
326 (mkCheckExpType elt_ty)
327 ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
328
329 tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
330 = do { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
331 ; res_ty <- readExpType res_ty
332 ; return (HsDo res_ty doExpr (L l stmts')) }
333
334 tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
335 = do { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
336 ; res_ty <- readExpType res_ty
337 ; return (HsDo res_ty mDoExpr (L l stmts')) }
338
339 tcDoStmts MonadComp (L l stmts) res_ty
340 = do { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
341 ; res_ty <- readExpType res_ty
342 ; return (HsDo res_ty MonadComp (L l stmts')) }
343 tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
344
345 tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
346 tcBody body res_ty
347 = do { traceTc "tcBody" (ppr res_ty)
348 ; tcMonoExpr body res_ty
349 }
350
351 {-
352 ************************************************************************
353 * *
354 \subsection{tcStmts}
355 * *
356 ************************************************************************
357 -}
358
359 type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
360 type TcCmdStmtChecker = TcStmtChecker HsCmd TcRhoType
361
362 type TcStmtChecker body rho_type
363 = forall thing. HsStmtContext GhcTc
364 -> Stmt GhcRn (LocatedA (body GhcRn))
365 -> rho_type -- Result type for comprehension
366 -> (rho_type -> TcM thing) -- Checker for what follows the stmt
367 -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
368
369 tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
370 -> TcStmtChecker body rho_type -- NB: higher-rank type
371 -> [LStmt GhcRn (LocatedA (body GhcRn))]
372 -> rho_type
373 -> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
374 tcStmts ctxt stmt_chk stmts res_ty
375 = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
376 const (return ())
377 ; return stmts' }
378
379 tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
380 -> TcStmtChecker body rho_type -- NB: higher-rank type
381 -> [LStmt GhcRn (LocatedA (body GhcRn))]
382 -> rho_type
383 -> (rho_type -> TcM thing)
384 -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
385
386 -- Note the higher-rank type. stmt_chk is applied at different
387 -- types in the equations for tcStmts
388
389 tcStmtsAndThen _ _ [] res_ty thing_inside
390 = do { thing <- thing_inside res_ty
391 ; return ([], thing) }
392
393 -- LetStmts are handled uniformly, regardless of context
394 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts)
395 res_ty thing_inside
396 = do { (binds', (stmts',thing)) <- tcLocalBinds binds $
397 tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
398 ; return (L loc (LetStmt x binds') : stmts', thing) }
399
400 -- Don't set the error context for an ApplicativeStmt. It ought to be
401 -- possible to do this with a popErrCtxt in the tcStmt case for
402 -- ApplicativeStmt, but it did something strange and broke a test (ado002).
403 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
404 | ApplicativeStmt{} <- stmt
405 = do { (stmt', (stmts', thing)) <-
406 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
407 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
408 thing_inside
409 ; return (L loc stmt' : stmts', thing) }
410
411 -- For the vanilla case, handle the location-setting part
412 | otherwise
413 = do { (stmt', (stmts', thing)) <-
414 setSrcSpanA loc $
415 addErrCtxt (pprStmtInCtxt ctxt stmt) $
416 stmt_chk ctxt stmt res_ty $ \ res_ty' ->
417 popErrCtxt $
418 tcStmtsAndThen ctxt stmt_chk stmts res_ty' $
419 thing_inside
420 ; return (L loc stmt' : stmts', thing) }
421
422 ---------------------------------------------------
423 -- Pattern guards
424 ---------------------------------------------------
425
426 tcGuardStmt :: TcExprStmtChecker
427 tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
428 = do { guard' <- tcScalingUsage Many $ tcCheckMonoExpr guard boolTy
429 -- Scale the guard to Many (see #19120 and #19193)
430 ; thing <- thing_inside res_ty
431 ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
432
433 tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
434 = do { -- The Many on the next line and the unrestricted on the line after
435 -- are linked. These must be the same multiplicity. Consider
436 -- x <- rhs -> u
437 --
438 -- The multiplicity of x in u must be the same as the multiplicity at
439 -- which the rhs has been consumed. When solving #18738, we want these
440 -- two multiplicity to still be the same.
441 (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs
442 -- Stmt has a context already
443 ; _concrete_ev <- hasFixedRuntimeRep FRRBindStmtGuard rhs_ty
444 ; (pat', thing) <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
445 pat (unrestricted rhs_ty) $
446 thing_inside res_ty
447 ; return (mkTcBindStmt pat' rhs', thing) }
448
449 tcGuardStmt _ stmt _ _
450 = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
451
452
453 ---------------------------------------------------
454 -- List comprehensions
455 -- (no rebindable syntax)
456 ---------------------------------------------------
457
458 -- Dealt with separately, rather than by tcMcStmt, because
459 -- a) We have special desugaring rules for list comprehensions,
460 -- which avoid creating intermediate lists. They in turn
461 -- assume that the bind/return operations are the regular
462 -- polymorphic ones, and in particular don't have any
463 -- coercion matching stuff in them. It's hard to avoid the
464 -- potential for non-trivial coercions in tcMcStmt
465
466 tcLcStmt :: TyCon -- The list type constructor ([])
467 -> TcExprStmtChecker
468
469 tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
470 = do { body' <- tcMonoExprNC body elt_ty
471 ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
472 ; return (LastStmt x body' noret noSyntaxExpr, thing) }
473
474 -- A generator, pat <- rhs
475 tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
476 = do { pat_ty <- newFlexiTyVarTy liftedTypeKind
477 ; rhs' <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
478 ; (pat', thing) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
479 thing_inside elt_ty
480 ; return (mkTcBindStmt pat' rhs', thing) }
481
482 -- A boolean guard
483 tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
484 = do { rhs' <- tcCheckMonoExpr rhs boolTy
485 ; thing <- thing_inside elt_ty
486 ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
487
488 -- ParStmt: See notes with tcMcStmt
489 tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
490 = do { (pairs', thing) <- loop bndr_stmts_s
491 ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
492 where
493 -- loop :: [([LStmt GhcRn], [GhcRn])]
494 -- -> TcM ([([LStmt GhcTc], [GhcTc])], thing)
495 loop [] = do { thing <- thing_inside elt_ty
496 ; return ([], thing) } -- matching in the branches
497
498 loop (ParStmtBlock x stmts names _ : pairs)
499 = do { (stmts', (ids, pairs', thing))
500 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
501 do { ids <- tcLookupLocalIds names
502 ; (pairs', thing) <- loop pairs
503 ; return (ids, pairs', thing) }
504 ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
505
506 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
507 , trS_bndrs = bindersMap
508 , trS_by = by, trS_using = using }) elt_ty thing_inside
509 = do { let (bndr_names, n_bndr_names) = unzip bindersMap
510 unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
511 -- The inner 'stmts' lack a LastStmt, so the element type
512 -- passed in to tcStmtsAndThen is never looked at
513 ; (stmts', (bndr_ids, by'))
514 <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
515 { by' <- traverse tcInferRho by
516 ; bndr_ids <- tcLookupLocalIds bndr_names
517 ; return (bndr_ids, by') }
518
519 ; let m_app ty = mkTyConApp m_tc [ty]
520
521 --------------- Typecheck the 'using' function -------------
522 -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm)
523 -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm)
524
525 -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm
526 ; let n_app = case form of
527 ThenForm -> (\ty -> ty)
528 _ -> m_app
529
530 by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present
531 by_arrow = case by' of
532 Nothing -> \ty -> ty
533 Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTyMany` e_ty) `mkVisFunTyMany` ty
534
535 tup_ty = mkBigCoreVarTupTy bndr_ids
536 poly_arg_ty = m_app alphaTy
537 poly_res_ty = m_app (n_app alphaTy)
538 using_poly_ty = mkInfForAllTy alphaTyVar $
539 by_arrow $
540 poly_arg_ty `mkVisFunTyMany` poly_res_ty
541
542 ; using' <- tcCheckPolyExpr using using_poly_ty
543 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
544
545 -- 'stmts' returns a result of type (m1_ty tuple_ty),
546 -- typically something like [(Int,Bool,Int)]
547 -- We don't know what tuple_ty is yet, so we use a variable
548 ; let mk_n_bndr :: Name -> TcId -> TcId
549 mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id))
550
551 -- Ensure that every old binder of type `b` is linked up with its
552 -- new binder which should have type `n b`
553 -- See Note [GroupStmt binder map] in GHC.Hs.Expr
554 n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids
555 bindersMap' = bndr_ids `zip` n_bndr_ids
556
557 -- Type check the thing in the environment with
558 -- these new binders and return the result
559 ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
560
561 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
562 , trS_by = fmap fst by', trS_using = final_using
563 , trS_ret = noSyntaxExpr
564 , trS_bind = noSyntaxExpr
565 , trS_fmap = noExpr
566 , trS_ext = unitTy
567 , trS_form = form }, thing) }
568
569 tcLcStmt _ _ stmt _ _
570 = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
571
572
573 ---------------------------------------------------
574 -- Monad comprehensions
575 -- (supports rebindable syntax)
576 ---------------------------------------------------
577
578 tcMcStmt :: TcExprStmtChecker
579
580 tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
581 = do { (body', return_op')
582 <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
583 \ [a_ty] [mult]->
584 tcScalingUsage mult $ tcCheckMonoExprNC body a_ty
585 ; thing <- thing_inside (panic "tcMcStmt: thing_inside")
586 ; return (LastStmt x body' noret return_op', thing) }
587
588 -- Generators for monad comprehensions ( pat <- rhs )
589 --
590 -- [ body | q <- gen ] -> gen :: m a
591 -- q :: a
592 --
593
594 tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
595 -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
596 = do { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op')
597 <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)
598 [SynRho, SynFun SynAny SynRho] res_ty $
599 \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] ->
600 do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
601 ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
602 thing_inside (mkCheckExpType new_res_ty)
603 ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) }
604
605 ; _concrete_ev <- hasFixedRuntimeRep (FRRBindStmt MonadComprehension) rhs_ty
606
607 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
608 ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
609 tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
610
611 ; let xbstc = XBindStmtTc
612 { xbstc_bindOp = bind_op'
613 , xbstc_boundResultType = new_res_ty
614 , xbstc_boundResultMult = pat_mult
615 , xbstc_failOp = fail_op'
616 }
617 ; return (BindStmt xbstc pat' rhs', thing) }
618
619 -- Boolean expressions.
620 --
621 -- [ body | stmts, expr ] -> expr :: m Bool
622 --
623 tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
624 = do { -- Deal with rebindable syntax:
625 -- guard_op :: test_ty -> rhs_ty
626 -- then_op :: rhs_ty -> new_res_ty -> res_ty
627 -- Where test_ty is, for example, Bool
628 ; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op')
629 <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
630 \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] ->
631 do { ((rhs', test_ty), guard_op')
632 <- tcScalingUsage rhs_mult $
633 tcSyntaxOp MCompOrigin guard_op [SynAny]
634 (mkCheckExpType rhs_ty) $
635 \ [test_ty] [test_mult] -> do
636 rhs' <- tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty
637 return $ (rhs', test_ty)
638 ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
639 ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') }
640
641 ; _evTerm1 <- hasFixedRuntimeRep FRRBodyStmtGuard test_ty
642 ; _evTerm2 <- hasFixedRuntimeRep (FRRBodyStmt MonadComprehension 1) rhs_ty
643 ; _evTerm3 <- hasFixedRuntimeRep (FRRBodyStmt MonadComprehension 2) new_res_ty
644
645 ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
646
647 -- Grouping statements
648 --
649 -- [ body | stmts, then group by e using f ]
650 -- -> e :: t
651 -- f :: forall a. (a -> t) -> m a -> m (m a)
652 -- [ body | stmts, then group using f ]
653 -- -> f :: forall a. m a -> m (m a)
654
655 -- We type [ body | (stmts, group by e using f), ... ]
656 -- f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
657 --
658 -- We type the functions as follows:
659 -- f <optional by> :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm)
660 -- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm)
661 -- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm)
662 -- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm)
663 --
664 tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
665 , trS_by = by, trS_using = using, trS_form = form
666 , trS_ret = return_op, trS_bind = bind_op
667 , trS_fmap = fmap_op }) res_ty thing_inside
668 = do { m1_ty <- newFlexiTyVarTy typeToTypeKind
669 ; m2_ty <- newFlexiTyVarTy typeToTypeKind
670 ; tup_ty <- newFlexiTyVarTy liftedTypeKind
671 ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any)
672
673 -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm
674 ; n_app <- case form of
675 ThenForm -> return (\ty -> ty)
676 _ -> do { n_ty <- newFlexiTyVarTy typeToTypeKind
677 ; return (n_ty `mkAppTy`) }
678 ; let by_arrow :: Type -> Type
679 -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present)
680 -- or res ('by' absent)
681 by_arrow = case by of
682 Nothing -> \res -> res
683 Just {} -> \res -> (alphaTy `mkVisFunTyMany` by_e_ty) `mkVisFunTyMany` res
684
685 poly_arg_ty = m1_ty `mkAppTy` alphaTy
686 using_arg_ty = m1_ty `mkAppTy` tup_ty
687 poly_res_ty = m2_ty `mkAppTy` n_app alphaTy
688 using_res_ty = m2_ty `mkAppTy` n_app tup_ty
689 using_poly_ty = mkInfForAllTy alphaTyVar $
690 by_arrow $
691 poly_arg_ty `mkVisFunTyMany` poly_res_ty
692
693 -- 'stmts' returns a result of type (m1_ty tuple_ty),
694 -- typically something like [(Int,Bool,Int)]
695 -- We don't know what tuple_ty is yet, so we use a variable
696 ; let (bndr_names, n_bndr_names) = unzip bindersMap
697 ; (stmts', (bndr_ids, by', return_op')) <-
698 tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
699 (mkCheckExpType using_arg_ty) $ \res_ty' -> do
700 { by' <- case by of
701 Nothing -> return Nothing
702 Just e -> do { e' <- tcCheckMonoExpr e by_e_ty
703 ; return (Just e') }
704
705 -- Find the Ids (and hence types) of all old binders
706 ; bndr_ids <- tcLookupLocalIds bndr_names
707
708 -- 'return' is only used for the binders, so we know its type.
709 -- return :: (a,b,c,..) -> m (a,b,c,..)
710 ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
711 [synKnownType (mkBigCoreVarTupTy bndr_ids)]
712 res_ty' $ \ _ _ -> return ()
713
714 ; return (bndr_ids, by', return_op') }
715
716 --------------- Typecheck the 'bind' function -------------
717 -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
718 ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
719 ; (_, bind_op') <- tcSyntaxOp MCompOrigin bind_op
720 [ synKnownType using_res_ty
721 , synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ]
722 res_ty $ \ _ _ -> return ()
723
724 --------------- Typecheck the 'fmap' function -------------
725 ; fmap_op' <- case form of
726 ThenForm -> return noExpr
727 _ -> fmap unLoc . tcCheckPolyExpr (noLocA fmap_op) $
728 mkInfForAllTy alphaTyVar $
729 mkInfForAllTy betaTyVar $
730 (alphaTy `mkVisFunTyMany` betaTy)
731 `mkVisFunTyMany` (n_app alphaTy)
732 `mkVisFunTyMany` (n_app betaTy)
733
734 --------------- Typecheck the 'using' function -------------
735 -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
736
737 ; using' <- tcCheckPolyExpr using using_poly_ty
738 ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
739
740 --------------- Building the bindersMap ----------------
741 ; let mk_n_bndr :: Name -> TcId -> TcId
742 mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id))
743
744 -- Ensure that every old binder of type `b` is linked up with its
745 -- new binder which should have type `n b`
746 -- See Note [GroupStmt binder map] in GHC.Hs.Expr
747 n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids
748 bindersMap' = bndr_ids `zip` n_bndr_ids
749
750 -- Type check the thing in the environment with
751 -- these new binders and return the result
752 ; thing <- tcExtendIdEnv n_bndr_ids $
753 thing_inside (mkCheckExpType new_res_ty)
754
755 ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
756 , trS_by = by', trS_using = final_using
757 , trS_ret = return_op', trS_bind = bind_op'
758 , trS_ext = n_app tup_ty
759 , trS_fmap = fmap_op', trS_form = form }, thing) }
760
761 -- A parallel set of comprehensions
762 -- [ (g x, h x) | ... ; let g v = ...
763 -- | ... ; let h v = ... ]
764 --
765 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
766 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
767 -- Similarly if we had an existential pattern match:
768 --
769 -- data T = forall a. Show a => C a
770 --
771 -- [ (show x, show y) | ... ; C x <- ...
772 -- | ... ; C y <- ... ]
773 --
774 -- Then we need the LIE from (show x, show y) to be simplified against
775 -- the bindings for x and y.
776 --
777 -- It's difficult to do this in parallel, so we rely on the renamer to
778 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
779 -- So the binders of the first parallel group will be in scope in the second
780 -- group. But that's fine; there's no shadowing to worry about.
781 --
782 -- Note: The `mzip` function will get typechecked via:
783 --
784 -- ParStmt [st1::t1, st2::t2, st3::t3]
785 --
786 -- mzip :: m st1
787 -- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call
788 -- -> m (st1, (st2, st3))
789 --
790 tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
791 = do { m_ty <- newFlexiTyVarTy typeToTypeKind
792
793 ; let mzip_ty = mkInfForAllTys [alphaTyVar, betaTyVar] $
794 (m_ty `mkAppTy` alphaTy)
795 `mkVisFunTyMany`
796 (m_ty `mkAppTy` betaTy)
797 `mkVisFunTyMany`
798 (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
799 ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty
800
801 -- type dummies since we don't know all binder types yet
802 ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
803 [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
804
805 -- Typecheck bind:
806 ; let tup_tys = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
807 tuple_ty = mk_tuple_ty tup_tys
808
809 ; (((blocks', thing), inner_res_ty), bind_op')
810 <- tcSyntaxOp MCompOrigin bind_op
811 [ synKnownType (m_ty `mkAppTy` tuple_ty)
812 , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
813 \ [inner_res_ty] _ ->
814 do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
815 tup_tys bndr_stmts_s
816 ; return (stuff, inner_res_ty) }
817
818 ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
819
820 where
821 mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
822
823 -- loop :: Type -- m_ty
824 -- -> ExpRhoType -- inner_res_ty
825 -- -> [TcType] -- tup_tys
826 -- -> [ParStmtBlock Name]
827 -- -> TcM ([([LStmt GhcTc], [TcId])], thing)
828 loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
829 ; return ([], thing) }
830 -- matching in the branches
831
832 loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
833 (ParStmtBlock x stmts names return_op : pairs)
834 = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
835 ; (stmts', (ids, return_op', pairs', thing))
836 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
837 \m_tup_ty' ->
838 do { ids <- tcLookupLocalIds names
839 ; let tup_ty = mkBigCoreVarTupTy ids
840 ; (_, return_op') <-
841 tcSyntaxOp MCompOrigin return_op
842 [synKnownType tup_ty] m_tup_ty' $
843 \ _ _ -> return ()
844 ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
845 ; return (ids, return_op', pairs', thing) }
846 ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
847 loop _ _ _ _ = panic "tcMcStmt.loop"
848
849 tcMcStmt _ stmt _ _
850 = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
851
852
853 ---------------------------------------------------
854 -- Do-notation
855 -- (supports rebindable syntax)
856 ---------------------------------------------------
857
858 tcDoStmt :: TcExprStmtChecker
859
860 tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
861 = do { body' <- tcMonoExprNC body res_ty
862 ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
863 ; return (LastStmt x body' noret noSyntaxExpr, thing) }
864
865 tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
866 = do { -- Deal with rebindable syntax:
867 -- (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty
868 -- This level of generality is needed for using do-notation
869 -- in full generality; see #1537
870
871 ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op')
872 <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $
873 \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] ->
874 do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
875 ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
876 thing_inside (mkCheckExpType new_res_ty)
877 ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) }
878
879 ; _concrete_ev <- hasFixedRuntimeRep (FRRBindStmt DoNotation) rhs_ty
880
881 -- If (but only if) the pattern can fail, typecheck the 'fail' operator
882 ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
883 tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
884 ; let xbstc = XBindStmtTc
885 { xbstc_bindOp = bind_op'
886 , xbstc_boundResultType = new_res_ty
887 , xbstc_boundResultMult = pat_mult
888 , xbstc_failOp = fail_op'
889 }
890 ; return (BindStmt xbstc pat' rhs', thing) }
891
892 tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
893 = do { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
894 thing_inside . mkCheckExpType
895 ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
896 Nothing -> (, Nothing) <$> tc_app_stmts res_ty
897 Just join_op ->
898 second Just <$>
899 (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
900 \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
901
902 ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
903
904 tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
905 = do { -- Deal with rebindable syntax;
906 -- (>>) :: rhs_ty -> new_res_ty -> res_ty
907 ; ((rhs', rhs_ty, new_res_ty, thing), then_op')
908 <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
909 \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] ->
910 do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
911 ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
912 ; return (rhs', rhs_ty, new_res_ty, thing) }
913 ; _evTerm1 <- hasFixedRuntimeRep (FRRBodyStmt DoNotation 1) rhs_ty
914 ; _evTerm2 <- hasFixedRuntimeRep (FRRBodyStmt DoNotation 2) new_res_ty
915 ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
916
917 tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
918 , recS_rec_ids = rec_names, recS_ret_fn = ret_op
919 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
920 res_ty thing_inside
921 = do { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
922 ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
923 ; let tup_ids = zipWith (\n t -> mkLocalId n Many t) tup_names tup_elt_tys
924 -- Many because it's a recursive definition
925 tup_ty = mkBigCoreTupTy tup_elt_tys
926
927 ; tcExtendIdEnv tup_ids $ do
928 { ((stmts', (ret_op', tup_rets)), stmts_ty)
929 <- tcInfer $ \ exp_ty ->
930 tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
931 do { tup_rets <- zipWithM tcCheckId tup_names
932 (map mkCheckExpType tup_elt_tys)
933 -- Unify the types of the "final" Ids (which may
934 -- be polymorphic) with those of "knot-tied" Ids
935 ; (_, ret_op')
936 <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
937 inner_res_ty $ \_ _ -> return ()
938 ; return (ret_op', tup_rets) }
939
940 ; ((_, mfix_op'), mfix_res_ty)
941 <- tcInfer $ \ exp_ty ->
942 tcSyntaxOp DoOrigin mfix_op
943 [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $
944 \ _ _ -> return ()
945
946 ; ((thing, new_res_ty), bind_op')
947 <- tcSyntaxOp DoOrigin bind_op
948 [ synKnownType mfix_res_ty
949 , SynFun (synKnownType tup_ty) SynRho ]
950 res_ty $
951 \ [new_res_ty] _ ->
952 do { thing <- thing_inside (mkCheckExpType new_res_ty)
953 ; return (thing, new_res_ty) }
954
955 ; let rec_ids = takeList rec_names tup_ids
956 ; later_ids <- tcLookupLocalIds later_names
957 ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
958 ppr later_ids <+> ppr (map idType later_ids)]
959 ; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids
960 , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
961 , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
962 , recS_ext = RecStmtTc
963 { recS_bind_ty = new_res_ty
964 , recS_later_rets = []
965 , recS_rec_rets = tup_rets
966 , recS_ret_ty = stmts_ty} }, thing)
967 }}
968
969 tcDoStmt _ stmt _ _
970 = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
971
972
973
974 ---------------------------------------------------
975 -- MonadFail Proposal warnings
976 ---------------------------------------------------
977
978 -- The idea behind issuing MonadFail warnings is that we add them whenever a
979 -- failable pattern is encountered. However, instead of throwing a type error
980 -- when the constraint cannot be satisfied, we only issue a warning in
981 -- "GHC.Tc.Errors".
982
983 tcMonadFailOp :: CtOrigin
984 -> LPat GhcTc
985 -> SyntaxExpr GhcRn -- The fail op
986 -> TcType -- Type of the whole do-expression
987 -> TcRn (FailOperator GhcTc) -- Typechecked fail op
988 -- Get a 'fail' operator expression, to use if the pattern match fails.
989 -- This won't be used in cases where we've already determined the pattern
990 -- match can't fail (so the fail op is Nothing), however, it seems that the
991 -- isIrrefutableHsPat test is still required here for some reason I haven't
992 -- yet determined.
993 tcMonadFailOp orig pat fail_op res_ty = do
994 dflags <- getDynFlags
995 if isIrrefutableHsPat dflags pat
996 then return Nothing
997 else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
998 (mkCheckExpType res_ty) $ \_ _ -> return ())
999
1000 {-
1001 Note [Treat rebindable syntax first]
1002 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1003 When typechecking
1004 do { bar; ... } :: IO ()
1005 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
1006 pushing info from the context into the RHS. To do this, we check the
1007 rebindable syntax first, and push that information into (tcLExprNC rhs).
1008 Otherwise the error shows up when checking the rebindable syntax, and
1009 the expected/inferred stuff is back to front (see #3613).
1010
1011 Note [typechecking ApplicativeStmt]
1012
1013 join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
1014
1015 fresh type variables:
1016 pat_ty_1..pat_ty_n
1017 exp_ty_1..exp_ty_n
1018 t_1..t_(n-1)
1019
1020 body :: body_ty
1021 (\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
1022 pat_i :: pat_ty_i
1023 e_i :: exp_ty_i
1024 <$> :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
1025 <*>_i :: t_(i-1) -> exp_ty_i -> t_i
1026 join :: tn -> res_ty
1027 -}
1028
1029 tcApplicativeStmts
1030 :: HsStmtContext GhcTc
1031 -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
1032 -> ExpRhoType -- rhs_ty
1033 -> (TcRhoType -> TcM t) -- thing_inside
1034 -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
1035
1036 tcApplicativeStmts ctxt pairs rhs_ty thing_inside
1037 = do { body_ty <- newFlexiTyVarTy liftedTypeKind
1038 ; let arity = length pairs
1039 ; ts <- replicateM (arity-1) $ newInferExpType
1040 ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
1041 ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
1042 ; let fun_ty = mkVisFunTysMany pat_tys body_ty
1043
1044 -- NB. do the <$>,<*> operators first, we don't want type errors here
1045 -- i.e. goOps before goArgs
1046 -- See Note [Treat rebindable syntax first]
1047 ; let (ops, args) = unzip pairs
1048 ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
1049
1050 -- Typecheck each ApplicativeArg separately
1051 -- See Note [ApplicativeDo and constraints]
1052 ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
1053
1054 -- Bring into scope all the things bound by the args,
1055 -- and typecheck the thing_inside
1056 -- See Note [ApplicativeDo and constraints]
1057 ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
1058 thing_inside body_ty
1059
1060 ; return (zip ops' args', body_ty, res) }
1061 where
1062 goOps _ [] = return []
1063 goOps t_left ((op,t_i,exp_ty) : ops)
1064 = do { (_, op')
1065 <- tcSyntaxOp DoOrigin op
1066 [synKnownType t_left, synKnownType exp_ty] t_i $
1067 \ _ _ -> return ()
1068 ; t_i <- readExpType t_i
1069 ; ops' <- goOps t_i ops
1070 ; return (op' : ops') }
1071
1072 goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
1073 -> TcM (ApplicativeArg GhcTc)
1074
1075 goArg body_ty (ApplicativeArgOne
1076 { xarg_app_arg_one = fail_op
1077 , app_arg_pattern = pat
1078 , arg_expr = rhs
1079 , ..
1080 }, pat_ty, exp_ty)
1081 = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $
1082 addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs)) $
1083 do { rhs' <- tcCheckMonoExprNC rhs exp_ty
1084 ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
1085 return ()
1086 ; fail_op' <- fmap join . forM fail_op $ \fail ->
1087 tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
1088
1089 ; return (ApplicativeArgOne
1090 { xarg_app_arg_one = fail_op'
1091 , app_arg_pattern = pat'
1092 , arg_expr = rhs'
1093 , .. }
1094 ) }
1095
1096 goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
1097 = do { (stmts', (ret',pat')) <-
1098 tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
1099 \res_ty -> do
1100 { ret' <- tcExpr ret res_ty
1101 ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
1102 return ()
1103 ; return (ret', pat')
1104 }
1105 ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
1106
1107 get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
1108 get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat
1109 get_arg_bndrs (ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders CollNoDictBinders pat
1110
1111 {- Note [ApplicativeDo and constraints]
1112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1113 An applicative-do is supposed to take place in parallel, so
1114 constraints bound in one arm can't possibly be available in another
1115 (#13242). Our current rule is this (more details and discussion
1116 on the ticket). Consider
1117
1118 ...stmts...
1119 ApplicativeStmts [arg1, arg2, ... argN]
1120 ...more stmts...
1121
1122 where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
1123 Now, we say that:
1124
1125 * Constraints required by the argi can be solved from
1126 constraint bound by ...stmts...
1127
1128 * Constraints and existentials bound by the argi are not available
1129 to solve constraints required either by argj (where i /= j),
1130 or by ...more stmts....
1131
1132 * Within the stmts of each 'argi' individually, however, constraints bound
1133 by earlier stmts can be used to solve later ones.
1134
1135 To achieve this, we just typecheck each 'argi' separately, bring all
1136 the variables they bind into scope, and typecheck the thing_inside.
1137
1138 ************************************************************************
1139 * *
1140 \subsection{Errors and contexts}
1141 * *
1142 ************************************************************************
1143
1144 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
1145 number of args are used in each equation.
1146 -}
1147
1148 checkArgs :: AnnoBody body
1149 => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
1150 checkArgs _ (MG { mg_alts = L _ [] })
1151 = return ()
1152 checkArgs fun (MG { mg_alts = L _ (match1:matches) })
1153 | null bad_matches
1154 = return ()
1155 | otherwise
1156 = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
1157 (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
1158 text "have different numbers of arguments"
1159 , nest 2 (ppr (getLocA match1))
1160 , nest 2 (ppr (getLocA (head bad_matches)))])
1161 where
1162 n_args1 = args_in_match match1
1163 bad_matches = [m | m <- matches, args_in_match m /= n_args1]
1164
1165 args_in_match :: (LocatedA (Match GhcRn body1) -> Int)
1166 args_in_match (L _ (Match { m_pats = pats })) = length pats