never executed always true always false
1
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE GADTs #-}
5 {-# LANGUAGE ScopedTypeVariables #-}
6 {-# LANGUAGE TupleSections #-}
7 {-# LANGUAGE TypeFamilies #-}
8 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
9 {-# LANGUAGE DisambiguateRecordFields #-}
10
11 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
12
13 {-
14 %
15 (c) The University of Glasgow 2006
16 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
17 -}
18
19 module GHC.Tc.Gen.Head
20 ( HsExprArg(..), EValArg(..), TcPass(..)
21 , AppCtxt(..), appCtxtLoc, insideExpansion
22 , splitHsApps, rebuildHsApps
23 , addArgWrap, isHsValArg
24 , countLeadingValArgs, isVisibleArg, pprHsExprArgTc
25 , countVisAndInvisValArgs, countHsWrapperInvisArgs
26
27 , tcInferAppHead, tcInferAppHead_maybe
28 , tcInferId, tcCheckId
29 , obviousSig
30 , tyConOf, tyConOfET, lookupParents, fieldNotInType
31 , notSelector, nonBidirectionalErr
32
33 , addExprCtxt, addFunResCtxt ) where
34
35 import {-# SOURCE #-} GHC.Tc.Gen.Expr( tcExpr, tcCheckMonoExprNC, tcCheckPolyExprNC )
36
37 import GHC.Tc.Gen.HsType
38 import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
39 import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig, lhsSigWcTypeContextSpan )
40 import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
41 import GHC.Tc.Utils.Monad
42 import GHC.Tc.Utils.Unify
43 import GHC.Types.Basic
44 import GHC.Types.Error
45 import GHC.Tc.Utils.Instantiate
46 import GHC.Tc.Instance.Family ( tcLookupDataFamInst )
47 import GHC.Core.FamInstEnv ( FamInstEnvs )
48 import GHC.Core.UsageEnv ( unitUE )
49 import GHC.Rename.Utils ( unknownSubordinateErr )
50 import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
51 import GHC.Unit.Module ( getModule )
52 import GHC.Tc.Errors.Types
53 import GHC.Tc.Solver ( InferMode(..), simplifyInfer )
54 import GHC.Tc.Utils.Env
55 import GHC.Tc.Utils.TcMType
56 import GHC.Tc.Types.Origin
57 import GHC.Tc.Utils.TcType as TcType
58 import GHC.Hs
59 import GHC.Hs.Syn.Type
60 import GHC.Types.Id
61 import GHC.Types.Id.Info
62 import GHC.Core.PatSyn( PatSyn )
63 import GHC.Core.ConLike( ConLike(..) )
64 import GHC.Core.DataCon
65 import GHC.Types.Name
66 import GHC.Types.Name.Reader
67 import GHC.Core.TyCon
68 import GHC.Core.TyCo.Rep
69 import GHC.Core.Type
70 import GHC.Tc.Types.Evidence
71 import GHC.Builtin.Types( multiplicityTy )
72 import GHC.Builtin.Names
73 import GHC.Builtin.Names.TH( liftStringName, liftName )
74 import GHC.Driver.Session
75 import GHC.Types.SrcLoc
76 import GHC.Utils.Misc
77 import GHC.Data.Maybe
78 import GHC.Utils.Outputable as Outputable
79 import GHC.Utils.Panic
80 import GHC.Utils.Panic.Plain
81 import Control.Monad
82
83 import Data.Function
84
85 import GHC.Prelude
86
87
88 {- *********************************************************************
89 * *
90 HsExprArg: auxiliary data type
91 * *
92 ********************************************************************* -}
93
94 {- Note [HsExprArg]
95 ~~~~~~~~~~~~~~~~~~~
96 The data type HsExprArg :: TcPass -> Type
97 is a very local type, used only within this module and GHC.Tc.Gen.App
98
99 * It's really a zipper for an application chain
100 See Note [Application chains and heads] in GHC.Tc.Gen.App for
101 what an "application chain" is.
102
103 * It's a GHC-specific type, so using TTG only where necessary
104
105 * It is indexed by TcPass, meaning
106 - HsExprArg TcpRn:
107 The result of splitHsApps, which decomposes a HsExpr GhcRn
108
109 - HsExprArg TcpInst:
110 The result of tcInstFun, which instantiates the function type
111 Adds EWrap nodes, the argument type in EValArg,
112 and the kind-checked type in ETypeArg
113
114 - HsExprArg TcpTc:
115 The result of tcArg, which typechecks the value args
116 In EValArg we now have a (LHsExpr GhcTc)
117
118 * rebuildPrefixApps is dual to splitHsApps, and zips an application
119 back into a HsExpr
120
121 Note [EValArg]
122 ~~~~~~~~~~~~~~
123 The data type EValArg is the payload of the EValArg constructor of
124 HsExprArg; i.e. a value argument of the application. EValArg has two
125 forms:
126
127 * ValArg: payload is just the expression itself. Simple.
128
129 * ValArgQL: captures the results of applying quickLookArg to the
130 argument in a ValArg. When we later want to typecheck that argument
131 we can just carry on from where quick-look left off. The fields of
132 ValArgQL exactly capture what is needed to complete the job.
133
134 Invariants:
135
136 1. With QL switched off, all arguments are ValArg; no ValArgQL
137
138 2. With QL switched on, tcInstFun converts some ValArgs to ValArgQL,
139 under the conditions when quick-look should happen (eg the argument
140 type is guarded) -- see quickLookArg
141
142 Note [splitHsApps]
143 ~~~~~~~~~~~~~~~~~~
144 The key function
145 splitHsApps :: HsExpr GhcRn -> (HsExpr GhcRn, HsExpr GhcRn, [HsExprArg 'TcpRn])
146 takes apart either an HsApp, or an infix OpApp, returning
147
148 * The "head" of the application, an expression that is often a variable;
149 this is used for typechecking
150
151 * The "user head" or "error head" of the application, to be reported to the
152 user in case of an error. Example:
153 (`op` e)
154 expands (via HsExpanded) to
155 (rightSection op e)
156 but we don't want to see 'rightSection' in error messages. So we keep the
157 innermost un-expanded head as the "error head".
158
159 * A list of HsExprArg, the arguments
160 -}
161
162 data TcPass = TcpRn -- Arguments decomposed
163 | TcpInst -- Function instantiated
164 | TcpTc -- Typechecked
165
166 data HsExprArg (p :: TcPass)
167 = -- See Note [HsExprArg]
168 EValArg { eva_ctxt :: AppCtxt
169 , eva_arg :: EValArg p
170 , eva_arg_ty :: !(XEVAType p) }
171
172 | ETypeArg { eva_ctxt :: AppCtxt
173 , eva_hs_ty :: LHsWcType GhcRn -- The type arg
174 , eva_ty :: !(XETAType p) } -- Kind-checked type arg
175
176 | EPrag AppCtxt
177 (HsPragE (GhcPass (XPass p)))
178
179 | EWrap EWrap
180
181 data EWrap = EPar AppCtxt
182 | EExpand (HsExpr GhcRn)
183 | EHsWrap HsWrapper
184
185 data EValArg (p :: TcPass) where -- See Note [EValArg]
186 ValArg :: LHsExpr (GhcPass (XPass p))
187 -> EValArg p
188
189 ValArgQL :: { va_expr :: LHsExpr GhcRn -- Original application
190 -- For location and error msgs
191 , va_fun :: (HsExpr GhcTc, AppCtxt) -- Function of the application,
192 -- typechecked, plus its context
193 , va_args :: [HsExprArg 'TcpInst] -- Args, instantiated
194 , va_ty :: TcRhoType } -- Result type
195 -> EValArg 'TcpInst -- Only exists in TcpInst phase
196
197 data AppCtxt
198 = VAExpansion
199 (HsExpr GhcRn) -- Inside an expansion of this expression
200 SrcSpan -- The SrcSpan of the expression
201 -- noSrcSpan if outermost
202
203 | VACall
204 (HsExpr GhcRn) Int -- In the third argument of function f
205 SrcSpan -- The SrcSpan of the application (f e1 e2 e3)
206
207 appCtxtLoc :: AppCtxt -> SrcSpan
208 appCtxtLoc (VAExpansion _ l) = l
209 appCtxtLoc (VACall _ _ l) = l
210
211 insideExpansion :: AppCtxt -> Bool
212 insideExpansion (VAExpansion {}) = True
213 insideExpansion (VACall {}) = False
214
215 instance Outputable AppCtxt where
216 ppr (VAExpansion e _) = text "VAExpansion" <+> ppr e
217 ppr (VACall f n _) = text "VACall" <+> int n <+> ppr f
218
219 type family XPass p where
220 XPass 'TcpRn = 'Renamed
221 XPass 'TcpInst = 'Renamed
222 XPass 'TcpTc = 'Typechecked
223
224 type family XETAType p where -- Type arguments
225 XETAType 'TcpRn = NoExtField
226 XETAType _ = Type
227
228 type family XEVAType p where -- Value arguments
229 XEVAType 'TcpRn = NoExtField
230 XEVAType _ = Scaled Type
231
232 mkEValArg :: AppCtxt -> LHsExpr GhcRn -> HsExprArg 'TcpRn
233 mkEValArg ctxt e = EValArg { eva_arg = ValArg e, eva_ctxt = ctxt
234 , eva_arg_ty = noExtField }
235
236 mkETypeArg :: AppCtxt -> LHsWcType GhcRn -> HsExprArg 'TcpRn
237 mkETypeArg ctxt hs_ty = ETypeArg { eva_ctxt = ctxt, eva_hs_ty = hs_ty
238 , eva_ty = noExtField }
239
240 addArgWrap :: HsWrapper -> [HsExprArg 'TcpInst] -> [HsExprArg 'TcpInst]
241 addArgWrap wrap args
242 | isIdHsWrapper wrap = args
243 | otherwise = EWrap (EHsWrap wrap) : args
244
245 splitHsApps :: HsExpr GhcRn
246 -> ( (HsExpr GhcRn, AppCtxt) -- Head
247 , [HsExprArg 'TcpRn]) -- Args
248 -- See Note [splitHsApps]
249 splitHsApps e = go e (top_ctxt 0 e) []
250 where
251 top_ctxt n (HsPar _ _ fun _) = top_lctxt n fun
252 top_ctxt n (HsPragE _ _ fun) = top_lctxt n fun
253 top_ctxt n (HsAppType _ fun _) = top_lctxt (n+1) fun
254 top_ctxt n (HsApp _ fun _) = top_lctxt (n+1) fun
255 top_ctxt n (XExpr (HsExpanded orig _)) = VACall orig n noSrcSpan
256 top_ctxt n other_fun = VACall other_fun n noSrcSpan
257
258 top_lctxt n (L _ fun) = top_ctxt n fun
259
260 go :: HsExpr GhcRn -> AppCtxt -> [HsExprArg 'TcpRn]
261 -> ((HsExpr GhcRn, AppCtxt), [HsExprArg 'TcpRn])
262 go (HsPar _ _ (L l fun) _) ctxt args = go fun (set l ctxt) (EWrap (EPar ctxt) : args)
263 go (HsPragE _ p (L l fun)) ctxt args = go fun (set l ctxt) (EPrag ctxt p : args)
264 go (HsAppType _ (L l fun) ty) ctxt args = go fun (dec l ctxt) (mkETypeArg ctxt ty : args)
265 go (HsApp _ (L l fun) arg) ctxt args = go fun (dec l ctxt) (mkEValArg ctxt arg : args)
266
267 -- See Note [Looking through HsExpanded]
268 go (XExpr (HsExpanded orig fun)) ctxt args
269 = go fun (VAExpansion orig (appCtxtLoc ctxt)) (EWrap (EExpand orig) : args)
270
271 -- See Note [Desugar OpApp in the typechecker]
272 go e@(OpApp _ arg1 (L l op) arg2) _ args
273 = ( (op, VACall op 0 (locA l))
274 , mkEValArg (VACall op 1 generatedSrcSpan) arg1
275 : mkEValArg (VACall op 2 generatedSrcSpan) arg2
276 : EWrap (EExpand e)
277 : args )
278
279 go e ctxt args = ((e,ctxt), args)
280
281 set :: SrcSpanAnnA -> AppCtxt -> AppCtxt
282 set l (VACall f n _) = VACall f n (locA l)
283 set _ ctxt@(VAExpansion {}) = ctxt
284
285 dec :: SrcSpanAnnA -> AppCtxt -> AppCtxt
286 dec l (VACall f n _) = VACall f (n-1) (locA l)
287 dec _ ctxt@(VAExpansion {}) = ctxt
288
289 rebuildHsApps :: HsExpr GhcTc -> AppCtxt -> [HsExprArg 'TcpTc]-> HsExpr GhcTc
290 rebuildHsApps fun _ [] = fun
291 rebuildHsApps fun ctxt (arg : args)
292 = case arg of
293 EValArg { eva_arg = ValArg arg, eva_ctxt = ctxt' }
294 -> rebuildHsApps (HsApp noAnn lfun arg) ctxt' args
295 ETypeArg { eva_hs_ty = hs_ty, eva_ty = ty, eva_ctxt = ctxt' }
296 -> rebuildHsApps (HsAppType ty lfun hs_ty) ctxt' args
297 EPrag ctxt' p
298 -> rebuildHsApps (HsPragE noExtField p lfun) ctxt' args
299 EWrap (EPar ctxt')
300 -> rebuildHsApps (gHsPar lfun) ctxt' args
301 EWrap (EExpand orig)
302 -> rebuildHsApps (XExpr (ExpansionExpr (HsExpanded orig fun))) ctxt args
303 EWrap (EHsWrap wrap)
304 -> rebuildHsApps (mkHsWrap wrap fun) ctxt args
305 where
306 lfun = L (noAnnSrcSpan $ appCtxtLoc ctxt) fun
307
308 isHsValArg :: HsExprArg id -> Bool
309 isHsValArg (EValArg {}) = True
310 isHsValArg _ = False
311
312 countLeadingValArgs :: [HsExprArg id] -> Int
313 countLeadingValArgs [] = 0
314 countLeadingValArgs (EValArg {} : args) = 1 + countLeadingValArgs args
315 countLeadingValArgs (EWrap {} : args) = countLeadingValArgs args
316 countLeadingValArgs (EPrag {} : args) = countLeadingValArgs args
317 countLeadingValArgs (ETypeArg {} : _) = 0
318
319 isValArg :: HsExprArg id -> Bool
320 isValArg (EValArg {}) = True
321 isValArg _ = False
322
323 isVisibleArg :: HsExprArg id -> Bool
324 isVisibleArg (EValArg {}) = True
325 isVisibleArg (ETypeArg {}) = True
326 isVisibleArg _ = False
327
328 -- | Count visible and invisible value arguments in a list
329 -- of 'HsExprArg' arguments.
330 countVisAndInvisValArgs :: [HsExprArg id] -> Arity
331 countVisAndInvisValArgs [] = 0
332 countVisAndInvisValArgs (EValArg {} : args) = 1 + countVisAndInvisValArgs args
333 countVisAndInvisValArgs (EWrap wrap : args) =
334 case wrap of { EHsWrap hsWrap -> countHsWrapperInvisArgs hsWrap + countVisAndInvisValArgs args
335 ; EPar {} -> countVisAndInvisValArgs args
336 ; EExpand {} -> countVisAndInvisValArgs args }
337 countVisAndInvisValArgs (EPrag {} : args) = countVisAndInvisValArgs args
338 countVisAndInvisValArgs (ETypeArg {}: args) = countVisAndInvisValArgs args
339
340 -- | Counts the number of invisible term-level arguments applied by an 'HsWrapper'.
341 -- Precondition: this wrapper contains no abstractions.
342 countHsWrapperInvisArgs :: HsWrapper -> Arity
343 countHsWrapperInvisArgs = go
344 where
345 go WpHole = 0
346 go (WpCompose wrap1 wrap2) = go wrap1 + go wrap2
347 go fun@(WpFun {}) = nope fun
348 go (WpCast {}) = 0
349 go evLam@(WpEvLam {}) = nope evLam
350 go (WpEvApp _) = 1
351 go tyLam@(WpTyLam {}) = nope tyLam
352 go (WpTyApp _) = 0
353 go (WpLet _) = 0
354 go (WpMultCoercion {}) = 0
355
356 nope x = pprPanic "countHsWrapperInvisApps" (ppr x)
357
358 instance OutputableBndrId (XPass p) => Outputable (HsExprArg p) where
359 ppr (EValArg { eva_arg = arg }) = text "EValArg" <+> ppr arg
360 ppr (EPrag _ p) = text "EPrag" <+> ppr p
361 ppr (ETypeArg { eva_hs_ty = hs_ty }) = char '@' <> ppr hs_ty
362 ppr (EWrap wrap) = ppr wrap
363
364 instance Outputable EWrap where
365 ppr (EPar _) = text "EPar"
366 ppr (EHsWrap w) = text "EHsWrap" <+> ppr w
367 ppr (EExpand orig) = text "EExpand" <+> ppr orig
368
369 instance OutputableBndrId (XPass p) => Outputable (EValArg p) where
370 ppr (ValArg e) = ppr e
371 ppr (ValArgQL { va_fun = fun, va_args = args, va_ty = ty})
372 = hang (text "ValArgQL" <+> ppr fun)
373 2 (vcat [ ppr args, text "va_ty:" <+> ppr ty ])
374
375 pprHsExprArgTc :: HsExprArg 'TcpInst -> SDoc
376 pprHsExprArgTc (EValArg { eva_arg = tm, eva_arg_ty = ty })
377 = text "EValArg" <+> hang (ppr tm) 2 (dcolon <+> ppr ty)
378 pprHsExprArgTc arg = ppr arg
379
380 {- Note [Desugar OpApp in the typechecker]
381 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
382 Operator sections are desugared in the renamer; see GHC.Rename.Expr
383 Note [Handling overloaded and rebindable constructs].
384 But for reasons explained there, we rename OpApp to OpApp. Then,
385 here in the typechecker, we desugar it to a use of HsExpanded.
386 That makes it possible to typecheck something like
387 e1 `f` e2
388 where
389 f :: forall a. t1 -> forall b. t2 -> t3
390
391 Note [Looking through HsExpanded]
392 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
393 When creating an application chain in splitHsApps, we must deal with
394 HsExpanded f1 (f `HsApp` e1) `HsApp` e2 `HsApp` e3
395
396 as a single application chain `f e1 e2 e3`. Otherwise stuff like overloaded
397 labels (#19154) won't work.
398
399 It's easy to achieve this: `splitHsApps` unwraps `HsExpanded`.
400 -}
401
402 {- *********************************************************************
403 * *
404 tcInferAppHead
405 * *
406 ********************************************************************* -}
407
408 tcInferAppHead :: (HsExpr GhcRn, AppCtxt)
409 -> [HsExprArg 'TcpRn]
410 -> TcM (HsExpr GhcTc, TcSigmaType)
411 -- Infer type of the head of an application
412 -- i.e. the 'f' in (f e1 ... en)
413 -- See Note [Application chains and heads] in GHC.Tc.Gen.App
414 -- We get back a /SigmaType/ because we have special cases for
415 -- * A bare identifier (just look it up)
416 -- This case also covers a record selector HsRecSel
417 -- * An expression with a type signature (e :: ty)
418 -- See Note [Application chains and heads] in GHC.Tc.Gen.App
419 --
420 -- Why do we need the arguments to infer the type of the head of the
421 -- application? Simply to inform add_head_ctxt about whether or not
422 -- to put push a new "In the expression..." context. (We don't push a
423 -- new one if there are no arguments, because we already have.)
424 --
425 -- Note that [] and (,,) are both HsVar:
426 -- see Note [Empty lists] and [ExplicitTuple] in GHC.Hs.Expr
427 --
428 -- NB: 'e' cannot be HsApp, HsTyApp, HsPrag, HsPar, because those
429 -- cases are dealt with by splitHsApps.
430 --
431 -- See Note [tcApp: typechecking applications] in GHC.Tc.Gen.App
432 tcInferAppHead (fun,ctxt) args
433 = setSrcSpan (appCtxtLoc ctxt) $
434 do { mb_tc_fun <- tcInferAppHead_maybe fun args
435 ; case mb_tc_fun of
436 Just (fun', fun_sigma) -> return (fun', fun_sigma)
437 Nothing -> add_head_ctxt fun args $
438 tcInfer (tcExpr fun) }
439
440 tcInferAppHead_maybe :: HsExpr GhcRn
441 -> [HsExprArg 'TcpRn]
442 -> TcM (Maybe (HsExpr GhcTc, TcSigmaType))
443 -- See Note [Application chains and heads] in GHC.Tc.Gen.App
444 -- Returns Nothing for a complicated head
445 tcInferAppHead_maybe fun args
446 = case fun of
447 HsVar _ (L _ nm) -> Just <$> tcInferId nm
448 HsRecSel _ f -> Just <$> tcInferRecSelId f
449 ExprWithTySig _ e hs_ty -> add_head_ctxt fun args $
450 Just <$> tcExprWithSig e hs_ty
451 HsOverLit _ lit -> Just <$> tcInferOverLit lit
452 _ -> return Nothing
453
454 add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
455 -- Don't push an expression context if the arguments are empty,
456 -- because it has already been pushed by tcExpr
457 add_head_ctxt fun args thing_inside
458 | null args = thing_inside
459 | otherwise = addExprCtxt fun thing_inside
460
461
462 {- *********************************************************************
463 * *
464 Record selectors
465 * *
466 ********************************************************************* -}
467
468 tcInferRecSelId :: FieldOcc GhcRn
469 -> TcM (HsExpr GhcTc, TcSigmaType)
470 tcInferRecSelId (FieldOcc sel_name lbl)
471 = do { sel_id <- tc_rec_sel_id
472 ; let expr = HsRecSel noExtField (FieldOcc sel_id lbl)
473 ; return (expr, idType sel_id)
474 }
475 where
476 occ :: OccName
477 occ = rdrNameOcc (unLoc lbl)
478
479 tc_rec_sel_id :: TcM TcId
480 -- Like tc_infer_id, but returns an Id not a HsExpr,
481 -- so we can wrap it back up into a HsRecSel
482 tc_rec_sel_id
483 = do { thing <- tcLookup sel_name
484 ; case thing of
485 ATcId { tct_id = id }
486 -> do { check_naughty occ id
487 ; check_local_id id
488 ; return id }
489
490 AGlobal (AnId id)
491 -> do { check_naughty occ id
492 ; return id }
493 -- A global cannot possibly be ill-staged
494 -- nor does it need the 'lifting' treatment
495 -- hence no checkTh stuff here
496
497 _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
498 ppr thing <+> text "used where a value identifier was expected" }
499
500 ------------------------
501
502 -- A type signature on the argument of an ambiguous record selector or
503 -- the record expression in an update must be "obvious", i.e. the
504 -- outermost constructor ignoring parentheses.
505 obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)
506 obviousSig (ExprWithTySig _ _ ty) = Just ty
507 obviousSig (HsPar _ _ p _) = obviousSig (unLoc p)
508 obviousSig (HsPragE _ _ p) = obviousSig (unLoc p)
509 obviousSig _ = Nothing
510
511 -- Extract the outermost TyCon of a type, if there is one; for
512 -- data families this is the representation tycon (because that's
513 -- where the fields live).
514 tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon
515 tyConOf fam_inst_envs ty0
516 = case tcSplitTyConApp_maybe ty of
517 Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))
518 Nothing -> Nothing
519 where
520 (_, _, ty) = tcSplitSigmaTy ty0
521
522 -- Variant of tyConOf that works for ExpTypes
523 tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon
524 tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0
525
526
527 -- For an ambiguous record field, find all the candidate record
528 -- selectors (as GlobalRdrElts) and their parents.
529 lookupParents :: Bool -> RdrName -> RnM [(RecSelParent, GlobalRdrElt)]
530 lookupParents is_selector rdr
531 = do { env <- getGlobalRdrEnv
532 -- Filter by isRecFldGRE because otherwise a non-selector variable with
533 -- an overlapping name can get through when NoFieldSelectors is enabled.
534 -- See Note [NoFieldSelectors] in GHC.Rename.Env.
535 ; let all_gres = lookupGRE_RdrName' rdr env
536 ; let gres | is_selector = filter isFieldSelectorGRE all_gres
537 | otherwise = filter isRecFldGRE all_gres
538 ; mapM lookupParent gres }
539 where
540 lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)
541 lookupParent gre = do { id <- tcLookupId (greMangledName gre)
542 ; case recordSelectorTyCon_maybe id of
543 Just rstc -> return (rstc, gre)
544 Nothing -> failWithTc (notSelector (greMangledName gre)) }
545
546
547 fieldNotInType :: RecSelParent -> RdrName -> TcRnMessage
548 fieldNotInType p rdr
549 = TcRnUnknownMessage $ mkPlainError noHints $
550 unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr
551
552 notSelector :: Name -> TcRnMessage
553 notSelector field
554 = TcRnUnknownMessage $ mkPlainError noHints $
555 hsep [quotes (ppr field), text "is not a record selector"]
556
557 naughtyRecordSel :: OccName -> TcRnMessage
558 naughtyRecordSel lbl
559 = TcRnUnknownMessage $ mkPlainError noHints $
560 text "Cannot use record selector" <+> quotes (ppr lbl) <+>
561 text "as a function due to escaped type variables" $$
562 text "Probable fix: use pattern-matching syntax instead"
563
564
565 {- *********************************************************************
566 * *
567 Expressions with a type signature
568 expr :: type
569 * *
570 ********************************************************************* -}
571
572 tcExprWithSig :: LHsExpr GhcRn -> LHsSigWcType (NoGhcTc GhcRn)
573 -> TcM (HsExpr GhcTc, TcSigmaType)
574 tcExprWithSig expr hs_ty
575 = do { sig_info <- checkNoErrs $ -- Avoid error cascade
576 tcUserTypeSig loc hs_ty Nothing
577 ; (expr', poly_ty) <- tcExprSig ctxt expr sig_info
578 ; return (ExprWithTySig noExtField expr' hs_ty, poly_ty) }
579 where
580 loc = getLocA (dropWildCards hs_ty)
581 ctxt = ExprSigCtxt (lhsSigWcTypeContextSpan hs_ty)
582
583 tcExprSig :: UserTypeCtxt -> LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTc, TcType)
584 tcExprSig ctxt expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })
585 = setSrcSpan loc $ -- Sets the location for the implication constraint
586 do { let poly_ty = idType poly_id
587 ; (wrap, expr') <- tcSkolemiseScoped ctxt poly_ty $ \rho_ty ->
588 tcCheckMonoExprNC expr rho_ty
589 ; return (mkLHsWrap wrap expr', poly_ty) }
590
591 tcExprSig _ expr sig@(PartialSig { psig_name = name, sig_loc = loc })
592 = setSrcSpan loc $ -- Sets the location for the implication constraint
593 do { (tclvl, wanted, (expr', sig_inst))
594 <- pushLevelAndCaptureConstraints $
595 do { sig_inst <- tcInstSig sig
596 ; expr' <- tcExtendNameTyVarEnv (mapSnd binderVar $ sig_inst_skols sig_inst) $
597 tcExtendNameTyVarEnv (sig_inst_wcs sig_inst) $
598 tcCheckPolyExprNC expr (sig_inst_tau sig_inst)
599 ; return (expr', sig_inst) }
600 -- See Note [Partial expression signatures]
601 ; let tau = sig_inst_tau sig_inst
602 infer_mode | null (sig_inst_theta sig_inst)
603 , isNothing (sig_inst_wcx sig_inst)
604 = ApplyMR
605 | otherwise
606 = NoRestrictions
607 ; (qtvs, givens, ev_binds, _)
608 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted
609
610 ; tau <- zonkTcType tau
611 ; let inferred_theta = map evVarPred givens
612 tau_tvs = tyCoVarsOfType tau
613 ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta
614 tau_tvs qtvs (Just sig_inst)
615 ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau
616 my_sigma = mkInvisForAllTys binders (mkPhiTy my_theta tau)
617 ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.
618 then return idHsWrapper -- Fast path; also avoids complaint when we infer
619 -- an ambiguous type and have AllowAmbiguousType
620 -- e..g infer x :: forall a. F a -> Int
621 else tcSubTypeSigma (ExprSigCtxt NoRRC) inferred_sigma my_sigma
622
623 ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)
624 ; let poly_wrap = wrap
625 <.> mkWpTyLams qtvs
626 <.> mkWpLams givens
627 <.> mkWpLet ev_binds
628 ; return (mkLHsWrap poly_wrap expr', my_sigma) }
629
630
631 {- Note [Partial expression signatures]
632 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
633 Partial type signatures on expressions are easy to get wrong. But
634 here is a guiding principile
635 e :: ty
636 should behave like
637 let x :: ty
638 x = e
639 in x
640
641 So for partial signatures we apply the MR if no context is given. So
642 e :: IO _ apply the MR
643 e :: _ => IO _ do not apply the MR
644 just like in GHC.Tc.Gen.Bind.decideGeneralisationPlan
645
646 This makes a difference (#11670):
647 peek :: Ptr a -> IO CLong
648 peek ptr = peekElemOff undefined 0 :: _
649 from (peekElemOff undefined 0) we get
650 type: IO w
651 constraints: Storable w
652
653 We must NOT try to generalise over 'w' because the signature specifies
654 no constraints so we'll complain about not being able to solve
655 Storable w. Instead, don't generalise; then _ gets instantiated to
656 CLong, as it should.
657 -}
658
659
660 {- *********************************************************************
661 * *
662 Overloaded literals
663 * *
664 ********************************************************************* -}
665
666 tcInferOverLit :: HsOverLit GhcRn -> TcM (HsExpr GhcTc, TcSigmaType)
667 tcInferOverLit lit@(OverLit { ol_val = val
668 , ol_ext = OverLitRn { ol_rebindable = rebindable
669 , ol_from_fun = L loc from_name } })
670 = -- Desugar "3" to (fromInteger (3 :: Integer))
671 -- where fromInteger is gotten by looking up from_name, and
672 -- the (3 :: Integer) is returned by mkOverLit
673 -- Ditto the string literal "foo" to (fromString ("foo" :: String))
674 do { from_id <- tcLookupId from_name
675 ; (wrap1, from_ty) <- topInstantiate orig (idType from_id)
676
677 ; (wrap2, sarg_ty, res_ty) <- matchActualFunTySigma herald mb_doc
678 (1, []) from_ty
679 ; hs_lit <- mkOverLit val
680 ; co <- unifyType mb_doc (hsLitType hs_lit) (scaledThing sarg_ty)
681
682 ; let lit_expr = L (l2l loc) $ mkHsWrapCo co $
683 HsLit noAnn hs_lit
684 from_expr = mkHsWrap (wrap2 <.> wrap1) $
685 HsVar noExtField (L loc from_id)
686 witness = HsApp noAnn (L (l2l loc) from_expr) lit_expr
687 lit' = lit { ol_ext = OverLitTc { ol_rebindable = rebindable
688 , ol_witness = witness
689 , ol_type = res_ty } }
690 ; return (HsOverLit noAnn lit', res_ty) }
691 where
692 orig = LiteralOrigin lit
693 mb_doc = Just (ppr from_name)
694 herald = sep [ text "The function" <+> quotes (ppr from_name)
695 , text "is applied to"]
696
697
698 {- *********************************************************************
699 * *
700 tcInferId, tcCheckId
701 * *
702 ********************************************************************* -}
703
704 tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTc)
705 tcCheckId name res_ty
706 = do { (expr, actual_res_ty) <- tcInferId name
707 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
708 ; addFunResCtxt rn_fun [] actual_res_ty res_ty $
709 tcWrapResultO (OccurrenceOf name) rn_fun expr actual_res_ty res_ty }
710 where
711 rn_fun = HsVar noExtField (noLocA name)
712
713 ------------------------
714 tcInferId :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
715 -- Look up an occurrence of an Id
716 -- Do not instantiate its type
717 tcInferId id_name
718 | id_name `hasKey` assertIdKey
719 = do { dflags <- getDynFlags
720 ; if gopt Opt_IgnoreAsserts dflags
721 then tc_infer_id id_name
722 else tc_infer_assert id_name }
723
724 | otherwise
725 = do { (expr, ty) <- tc_infer_id id_name
726 ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)
727 ; return (expr, ty) }
728
729 tc_infer_assert :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
730 -- Deal with an occurrence of 'assert'
731 -- See Note [Adding the implicit parameter to 'assert']
732 tc_infer_assert assert_name
733 = do { assert_error_id <- tcLookupId assertErrorName
734 ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)
735 (idType assert_error_id)
736 ; return (mkHsWrap wrap (HsVar noExtField (noLocA assert_error_id)), id_rho)
737 }
738
739 tc_infer_id :: Name -> TcM (HsExpr GhcTc, TcSigmaType)
740 tc_infer_id id_name
741 = do { thing <- tcLookup id_name
742 ; case thing of
743 ATcId { tct_id = id }
744 -> do { check_local_id id
745 ; return_id id }
746
747 AGlobal (AnId id) -> return_id id
748 -- A global cannot possibly be ill-staged
749 -- nor does it need the 'lifting' treatment
750 -- Hence no checkTh stuff here
751
752 AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
753 AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
754 AGlobal (ATyCon tc) -> fail_tycon tc
755 ATcTyCon tc -> fail_tycon tc
756 ATyVar name _ -> fail_tyvar name
757
758 _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
759 ppr thing <+> text "used where a value identifier was expected" }
760 where
761 fail_tycon tc = do
762 gre <- getGlobalRdrEnv
763 let msg = text "Illegal term-level use of the type constructor"
764 <+> quotes (ppr (tyConName tc))
765 pprov = case lookupGRE_Name gre (tyConName tc) of
766 Just gre -> nest 2 (pprNameProvenance gre)
767 Nothing -> empty
768 suggestions <- get_suggestions dataName
769 failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions))
770
771 fail_tyvar name = do
772 let msg = text "Illegal term-level use of the type variable"
773 <+> quotes (ppr name)
774 pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc name))
775 suggestions <- get_suggestions varName
776 failWithTc (TcRnUnknownMessage $ mkPlainError noHints (msg $$ pprov $$ suggestions))
777
778 get_suggestions ns = do
779 let occ = mkOccNameFS ns (occNameFS (occName id_name))
780 dflags <- getDynFlags
781 rdr_env <- getGlobalRdrEnv
782 lcl_env <- getLocalRdrEnv
783 imp_info <- getImports
784 curr_mod <- getModule
785 hpt <- getHpt
786 return $ unknownNameSuggestions WL_Anything dflags hpt curr_mod rdr_env
787 lcl_env imp_info (mkRdrUnqual occ)
788
789 return_id id = return (HsVar noExtField (noLocA id), idType id)
790
791 check_local_id :: Id -> TcM ()
792 check_local_id id
793 = do { checkThLocalId id
794 ; tcEmitBindingUsage $ unitUE (idName id) One }
795
796 check_naughty :: OccName -> TcId -> TcM ()
797 check_naughty lbl id
798 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)
799 | otherwise = return ()
800
801 tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType)
802 -- See Note [Typechecking data constructors]
803 tcInferDataCon con
804 = do { let tvs = dataConUserTyVarBinders con
805 theta = dataConOtherTheta con
806 args = dataConOrigArgTys con
807 res = dataConOrigResTy con
808 stupid_theta = dataConStupidTheta con
809
810 ; scaled_arg_tys <- mapM linear_to_poly args
811
812 ; let full_theta = stupid_theta ++ theta
813 all_arg_tys = map unrestricted full_theta ++ scaled_arg_tys
814 -- stupid-theta must come first
815 -- See Note [Instantiating stupid theta]
816
817 ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)
818 , mkInvisForAllTys tvs $ mkPhiTy full_theta $
819 mkVisFunTys scaled_arg_tys res ) }
820 where
821 linear_to_poly :: Scaled Type -> TcM (Scaled Type)
822 -- linear_to_poly implements point (3,4)
823 -- of Note [Typechecking data constructors]
824 linear_to_poly (Scaled One ty) = do { mul_var <- newFlexiTyVarTy multiplicityTy
825 ; return (Scaled mul_var ty) }
826 linear_to_poly scaled_ty = return scaled_ty
827
828 tcInferPatSyn :: Name -> PatSyn -> TcM (HsExpr GhcTc, TcSigmaType)
829 tcInferPatSyn id_name ps
830 = case patSynBuilderOcc ps of
831 Just (expr,ty) -> return (expr,ty)
832 Nothing -> failWithTc (nonBidirectionalErr id_name)
833
834 nonBidirectionalErr :: Outputable name => name -> TcRnMessage
835 nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $
836 text "non-bidirectional pattern synonym"
837 <+> quotes (ppr name) <+> text "used in an expression"
838
839 {- Note [Typechecking data constructors]
840 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
841 As per Note [Polymorphisation of linear fields] in
842 GHC.Core.Multiplicity, linear fields of data constructors get a
843 polymorphic multiplicity when the data constructor is used as a term:
844
845 Just :: forall {p} a. a %p -> Maybe a
846
847 So at an occurrence of a data constructor we do the following,
848 mostly in tcInferDataCon:
849
850 1. Get its type, say
851 K :: forall (r :: RuntimeRep) (a :: TYPE r). a %1 -> T r a
852 Note the %1: it is linear
853
854 2. We are going to return a ConLikeTc, thus:
855 XExpr (ConLikeTc K [r,a] [Scaled p a])
856 :: forall (r :: RuntimeRep) (a :: TYPE r). a %p -> T r a
857 where 'p' is a fresh multiplicity unification variable.
858
859 To get the returned ConLikeTc, we allocate a fresh multiplicity
860 variable for each linear argument, and store the type, scaled by
861 the fresh multiplicity variable in the ConLikeTc; along with
862 the type of the ConLikeTc. This is done by linear_to_poly.
863
864 3. If the argument is not linear (perhaps explicitly declared as
865 non-linear by the user), don't bother with this.
866
867 4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by
868 GHC.HsToCore.Expr.dsConLike to:
869 (/\r a. \(x %p :: a). K @r @a x)
870 which has the desired type given in the previous bullet.
871 The 'p' is the multiplicity unification variable, which
872 will by now have been unified to something, or defaulted in
873 `GHC.Tc.Utils.Zonk.commitFlexi`. So it won't just be an
874 (unbound) variable.
875
876 Wrinkles
877
878 * Why put [InvisTVBinder] in ConLikeTc, when we only need [TyVar] to
879 desugar? It's a bit of a toss-up, but having [InvisTvBinder] supports
880 a future hsExprType :: HsExpr GhcTc -> Type
881
882 * Note that the [InvisTvBinder] is strictly redundant anyway; it's
883 just the dataConUserTyVarBinders of the data constructor. Similarly
884 in the [Scaled TcType] field of ConLikeTc, the type comes directly
885 from the data constructor. The only bit that /isn't/ redundant is the
886 fresh multiplicity variables!
887
888 So an alternative would be to define ConLikeTc like this:
889 | ConLikeTc [TcType] -- Just the multiplicity variables
890 But then the desugarer (and hsExprType, when we implement it) would
891 need to repeat some of the work done here. So for now at least
892 ConLikeTc records this strictly-redundant info.
893
894 * See Note [Instantiating stupid theta] for an extra wrinkle
895
896
897 Note [Adding the implicit parameter to 'assert']
898 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
899 The typechecker transforms (assert e1 e2) to (assertError e1 e2).
900 This isn't really the Right Thing because there's no way to "undo"
901 if you want to see the original source code in the typechecker
902 output. We'll have fix this in due course, when we care more about
903 being able to reconstruct the exact original program.
904
905
906 Note [Instantiating stupid theta]
907 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
908 Consider a data type with a "stupid theta":
909 data Ord a => T a = MkT (Maybe a)
910
911 We want to generate an Ord constraint for every use of MkT; but
912 we also want to allow visible type application, such as
913 MkT @Int
914
915 So we generate (ConLikeTc MkT [a] [Ord a, Maybe a]), with type
916 forall a. Ord a => Maybe a -> T a
917
918 Now visible type application will work fine. But we desugar the
919 ConLikeTc to
920 /\a \(d:Ord a) (x:Maybe a). MkT x
921 Notice that 'd' is dropped in this desugaring. We don't need it;
922 it was only there to generate a Wanted constraint. (That is why
923 it is stupid.) To achieve this:
924
925 * We put the stupid-thata at the front of the list of argument
926 types in ConLikeTc
927
928 * GHC.HsToCore.Expr.dsConLike generates /lambdas/ for all the
929 arguments, but drops the stupid-theta arguments when building the
930 /application/.
931
932 Nice.
933 -}
934
935 {-
936 ************************************************************************
937 * *
938 Template Haskell checks
939 * *
940 ************************************************************************
941 -}
942
943 checkThLocalId :: Id -> TcM ()
944 -- The renamer has already done checkWellStaged,
945 -- in RnSplice.checkThLocalName, so don't repeat that here.
946 -- Here we just add constraints for cross-stage lifting
947 checkThLocalId id
948 = do { mb_local_use <- getStageAndBindLevel (idName id)
949 ; case mb_local_use of
950 Just (top_lvl, bind_lvl, use_stage)
951 | thLevel use_stage > bind_lvl
952 -> checkCrossStageLifting top_lvl id use_stage
953 _ -> return () -- Not a locally-bound thing, or
954 -- no cross-stage link
955 }
956
957 --------------------------------------
958 checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()
959 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
960 -- we must check whether there's a cross-stage lift to do
961 -- Examples \x -> [|| x ||]
962 -- [|| map ||]
963 --
964 -- This is similar to checkCrossStageLifting in GHC.Rename.Splice, but
965 -- this code is applied to *typed* brackets.
966
967 checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var q))
968 | isTopLevel top_lvl
969 = when (isExternalName id_name) (keepAlive id_name)
970 -- See Note [Keeping things alive for Template Haskell] in GHC.Rename.Splice
971
972 | otherwise
973 = -- Nested identifiers, such as 'x' in
974 -- E.g. \x -> [|| h x ||]
975 -- We must behave as if the reference to x was
976 -- h $(lift x)
977 -- We use 'x' itself as the splice proxy, used by
978 -- the desugarer to stitch it all back together.
979 -- If 'x' occurs many times we may get many identical
980 -- bindings of the same splice proxy, but that doesn't
981 -- matter, although it's a mite untidy.
982 do { let id_ty = idType id
983 ; checkTc (isTauTy id_ty) (polySpliceErr id)
984 -- If x is polymorphic, its occurrence sites might
985 -- have different instantiations, so we can't use plain
986 -- 'x' as the splice proxy name. I don't know how to
987 -- solve this, and it's probably unimportant, so I'm
988 -- just going to flag an error for now
989
990 ; lift <- if isStringTy id_ty then
991 do { sid <- tcLookupId GHC.Builtin.Names.TH.liftStringName
992 -- See Note [Lifting strings]
993 ; return (HsVar noExtField (noLocA sid)) }
994 else
995 setConstraintVar lie_var $
996 -- Put the 'lift' constraint into the right LIE
997 newMethodFromName (OccurrenceOf id_name)
998 GHC.Builtin.Names.TH.liftName
999 [getRuntimeRep id_ty, id_ty]
1000
1001 -- Warning for implicit lift (#17804)
1002 ; addDetailedDiagnostic (TcRnImplicitLift id)
1003
1004 -- Update the pending splices
1005 ; ps <- readMutVar ps_var
1006 ; let pending_splice = PendingTcSplice id_name
1007 (nlHsApp (mkLHsWrap (applyQuoteWrapper q) (noLocA lift))
1008 (nlHsVar id))
1009 ; writeMutVar ps_var (pending_splice : ps)
1010
1011 ; return () }
1012 where
1013 id_name = idName id
1014
1015 checkCrossStageLifting _ _ _ = return ()
1016
1017 polySpliceErr :: Id -> TcRnMessage
1018 polySpliceErr id
1019 = TcRnUnknownMessage $ mkPlainError noHints $
1020 text "Can't splice the polymorphic local variable" <+> quotes (ppr id)
1021
1022 {-
1023 Note [Lifting strings]
1024 ~~~~~~~~~~~~~~~~~~~~~~
1025 If we see $(... [| s |] ...) where s::String, we don't want to
1026 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1027 So this conditional short-circuits the lifting mechanism to generate
1028 (liftString "xy") in that case. I didn't want to use overlapping instances
1029 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1030 errors in a polymorphic situation.
1031
1032 If this check fails (which isn't impossible) we get another chance; see
1033 Note [Converting strings] in Convert.hs
1034
1035 Local record selectors
1036 ~~~~~~~~~~~~~~~~~~~~~~
1037 Record selectors for TyCons in this module are ordinary local bindings,
1038 which show up as ATcIds rather than AGlobals. So we need to check for
1039 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1040 -}
1041
1042
1043 {- *********************************************************************
1044 * *
1045 Error reporting for function result mis-matches
1046 * *
1047 ********************************************************************* -}
1048
1049 addFunResCtxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn]
1050 -> TcType -> ExpRhoType
1051 -> TcM a -> TcM a
1052 -- When we have a mis-match in the return type of a function
1053 -- try to give a helpful message about too many/few arguments
1054 -- But not in generated code, where we don't want
1055 -- to mention internal (rebindable syntax) function names
1056 addFunResCtxt fun args fun_res_ty env_ty thing_inside
1057 = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg) thing_inside
1058 -- NB: use a landmark error context, so that an empty context
1059 -- doesn't suppress some more useful context
1060 where
1061 mk_msg
1062 = do { mb_env_ty <- readExpType_maybe env_ty
1063 -- by the time the message is rendered, the ExpType
1064 -- will be filled in (except if we're debugging)
1065 ; fun_res' <- zonkTcType fun_res_ty
1066 ; env' <- case mb_env_ty of
1067 Just env_ty -> zonkTcType env_ty
1068 Nothing ->
1069 do { dumping <- doptM Opt_D_dump_tc_trace
1070 ; massert dumping
1071 ; newFlexiTyVarTy liftedTypeKind }
1072 ; let -- See Note [Splitting nested sigma types in mismatched
1073 -- function types]
1074 (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'
1075 -- No need to call tcSplitNestedSigmaTys here, since env_ty is
1076 -- an ExpRhoTy, i.e., it's already instantiated.
1077 (_, _, env_tau) = tcSplitSigmaTy env'
1078 (args_fun, res_fun) = tcSplitFunTys fun_tau
1079 (args_env, res_env) = tcSplitFunTys env_tau
1080 n_fun = length args_fun
1081 n_env = length args_env
1082 info | -- Check for too few args
1083 -- fun_tau = a -> b, res_tau = Int
1084 n_fun > n_env
1085 , not_fun res_env
1086 = text "Probable cause:" <+> quotes (ppr fun)
1087 <+> text "is applied to too few arguments"
1088
1089 | -- Check for too many args
1090 -- fun_tau = a -> Int, res_tau = a -> b -> c -> d
1091 -- The final guard suppresses the message when there
1092 -- aren't enough args to drop; eg. the call is (f e1)
1093 n_fun < n_env
1094 , not_fun res_fun
1095 , (n_fun + count isValArg args) >= n_env
1096 -- Never suggest that a naked variable is
1097 -- applied to too many args!
1098 = text "Possible cause:" <+> quotes (ppr fun)
1099 <+> text "is applied to too many arguments"
1100
1101 | otherwise
1102 = Outputable.empty
1103
1104 ; return info }
1105
1106 not_fun ty -- ty is definitely not an arrow type,
1107 -- and cannot conceivably become one
1108 = case tcSplitTyConApp_maybe ty of
1109 Just (tc, _) -> isAlgTyCon tc
1110 Nothing -> False
1111
1112 {-
1113 Note [Splitting nested sigma types in mismatched function types]
1114 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1115 When one applies a function to too few arguments, GHC tries to determine this
1116 fact if possible so that it may give a helpful error message. It accomplishes
1117 this by checking if the type of the applied function has more argument types
1118 than supplied arguments.
1119
1120 Previously, GHC computed the number of argument types through tcSplitSigmaTy.
1121 This is incorrect in the face of nested foralls, however!
1122 This caused Ticket #13311, for instance:
1123
1124 f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b
1125
1126 If one uses `f` like so:
1127
1128 do { f; putChar 'a' }
1129
1130 Then tcSplitSigmaTy will decompose the type of `f` into:
1131
1132 Tyvars: [a]
1133 Context: (Monoid a)
1134 Argument types: []
1135 Return type: forall b. Monoid b => Maybe a -> Maybe b
1136
1137 That is, it will conclude that there are *no* argument types, and since `f`
1138 was given no arguments, it won't print a helpful error message. On the other
1139 hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:
1140
1141 Tyvars: [a, b]
1142 Context: (Monoid a, Monoid b)
1143 Argument types: [Maybe a]
1144 Return type: Maybe b
1145
1146 So now GHC recognizes that `f` has one more argument type than it was actually
1147 provided.
1148 -}
1149
1150
1151 {- *********************************************************************
1152 * *
1153 Misc utility functions
1154 * *
1155 ********************************************************************* -}
1156
1157 addExprCtxt :: HsExpr GhcRn -> TcRn a -> TcRn a
1158 addExprCtxt e thing_inside
1159 = case e of
1160 HsUnboundVar {} -> thing_inside
1161 _ -> addErrCtxt (exprCtxt e) thing_inside
1162 -- The HsUnboundVar special case addresses situations like
1163 -- f x = _
1164 -- when we don't want to say "In the expression: _",
1165 -- because it is mentioned in the error message itself
1166
1167 exprCtxt :: HsExpr GhcRn -> SDoc
1168 exprCtxt expr = hang (text "In the expression:") 2 (ppr (stripParensHsExpr expr))