3 (c) The University of Glasgow 2006
4 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 \section[TcExpr]{Typecheck an expression}
9 {-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}
10 {-# LANGUAGE FlexibleContexts #-}
12 module TcExpr
( tcPolyExpr
, tcMonoExpr
, tcMonoExprNC
,
13 tcInferSigma
, tcInferSigmaNC
, tcInferRho
, tcInferRhoNC
,
14 tcSyntaxOp
, tcSyntaxOpGen
, SyntaxOpType
(..), synKnownType
,
17 getFixedTyVars
) where
19 #include
"HsVersions.h"
21 import {-# SOURCE #-} TcSplice
( tcSpliceExpr
, tcTypedBracket
, tcUntypedBracket
)
22 import THNames
( liftStringName
, liftName
)
30 import TcBinds
( chooseInferredQuantifiers
, tcLocalBinds
)
31 import TcSigs
( tcUserTypeSig
, tcInstSig
)
32 import TcSimplify
( simplifyInfer
, InferMode
(..) )
33 import FamInst
( tcGetFamInstEnvs
, tcLookupDataFamInst
)
34 import FamInstEnv
( FamInstEnvs
)
35 import RnEnv
( addUsedGRE
, addNameClashErrRn
36 , unknownSubordinateErr
)
41 import TcPatSyn
( tcPatSynBuilderOcc
, nonBidirectionalErr
)
60 import TysPrim
( intPrimTy
)
61 import PrimOp
( tagToEnumKey
)
63 import MkId
( proxyHashId
)
67 import VarEnv
( emptyTidyEnv
)
73 import Class
(classTyCon
)
74 import UniqFM
( nonDetEltsUFM
)
75 import qualified GHC
.LanguageExtensions
as LangExt
80 import qualified Data
.Set
as Set
83 ************************************************************************
85 \subsection{Main wrappers}
87 ************************************************************************
90 tcPolyExpr
, tcPolyExprNC
91 :: LHsExpr Name
-- Expression to type check
92 -> TcSigmaType
-- Expected type (could be a polytype)
93 -> TcM
(LHsExpr TcId
) -- Generalised expr with expected type
95 -- tcPolyExpr is a convenient place (frequent but not too frequent)
96 -- place to add context information.
97 -- The NC version does not do so, usually because the caller wants
100 tcPolyExpr expr res_ty
= tc_poly_expr expr
(mkCheckExpType res_ty
)
101 tcPolyExprNC expr res_ty
= tc_poly_expr_nc expr
(mkCheckExpType res_ty
)
103 -- these versions take an ExpType
104 tc_poly_expr
, tc_poly_expr_nc
:: LHsExpr Name
-> ExpSigmaType
-> TcM
(LHsExpr TcId
)
105 tc_poly_expr expr res_ty
106 = addExprErrCtxt expr
$
107 do { traceTc
"tcPolyExpr" (ppr res_ty
); tc_poly_expr_nc expr res_ty
}
109 tc_poly_expr_nc
(L loc expr
) res_ty
110 = do { traceTc
"tcPolyExprNC" (ppr res_ty
)
112 <- tcSkolemiseET GenSigCtxt res_ty
$ \ res_ty
->
114 -- NB: setSrcSpan *after* skolemising, so we get better
117 ; return $ L loc
(mkHsWrap wrap expr
') }
120 tcMonoExpr
, tcMonoExprNC
121 :: LHsExpr Name
-- Expression to type check
122 -> ExpRhoType
-- Expected type
123 -- Definitely no foralls at the top
124 -> TcM
(LHsExpr TcId
)
126 tcMonoExpr expr res_ty
127 = addErrCtxt
(exprCtxt expr
) $
128 tcMonoExprNC expr res_ty
130 tcMonoExprNC
(L loc expr
) res_ty
132 do { expr
' <- tcExpr expr res_ty
133 ; return (L loc expr
') }
136 tcInferSigma
, tcInferSigmaNC
:: LHsExpr Name
-> TcM
( LHsExpr TcId
138 -- Infer a *sigma*-type.
139 tcInferSigma expr
= addErrCtxt
(exprCtxt expr
) (tcInferSigmaNC expr
)
141 tcInferSigmaNC
(L loc expr
)
143 do { (expr
', sigma
) <- tcInferNoInst
(tcExpr expr
)
144 ; return (L loc expr
', sigma
) }
146 tcInferRho
, tcInferRhoNC
:: LHsExpr Name
-> TcM
(LHsExpr TcId
, TcRhoType
)
147 -- Infer a *rho*-type. The return type is always (shallowly) instantiated.
148 tcInferRho expr
= addErrCtxt
(exprCtxt expr
) (tcInferRhoNC expr
)
151 = do { (expr
', sigma
) <- tcInferSigmaNC expr
152 ; (wrap
, rho
) <- topInstantiate
(exprCtOrigin
(unLoc expr
)) sigma
153 ; return (mkLHsWrap wrap expr
', rho
) }
157 ************************************************************************
159 tcExpr: the main expression typechecker
161 ************************************************************************
163 NB: The res_ty is always deeply skolemised.
166 tcExpr
:: HsExpr Name
-> ExpRhoType
-> TcM
(HsExpr TcId
)
167 tcExpr
(HsVar
(L _ name
)) res_ty
= tcCheckId name res_ty
168 tcExpr
(HsUnboundVar uv
) res_ty
= tcUnboundId uv res_ty
170 tcExpr e
@(HsApp
{}) res_ty
= tcApp1 e res_ty
171 tcExpr e
@(HsAppType
{}) res_ty
= tcApp1 e res_ty
173 tcExpr e
@(HsLit lit
) res_ty
= do { let lit_ty
= hsLitType lit
174 ; tcWrapResult e
(HsLit lit
) lit_ty res_ty
}
176 tcExpr
(HsPar expr
) res_ty
= do { expr
' <- tcMonoExprNC expr res_ty
177 ; return (HsPar expr
') }
179 tcExpr
(HsSCC src lbl expr
) res_ty
180 = do { expr
' <- tcMonoExpr expr res_ty
181 ; return (HsSCC src lbl expr
') }
183 tcExpr
(HsTickPragma src info srcInfo expr
) res_ty
184 = do { expr
' <- tcMonoExpr expr res_ty
185 ; return (HsTickPragma src info srcInfo expr
') }
187 tcExpr
(HsCoreAnn src lbl expr
) res_ty
188 = do { expr
' <- tcMonoExpr expr res_ty
189 ; return (HsCoreAnn src lbl expr
') }
191 tcExpr
(HsOverLit lit
) res_ty
192 = do { lit
' <- newOverloadedLit lit res_ty
193 ; return (HsOverLit lit
') }
195 tcExpr
(NegApp expr neg_expr
) res_ty
196 = do { (expr
', neg_expr
')
197 <- tcSyntaxOp NegateOrigin neg_expr
[SynAny
] res_ty
$
199 tcMonoExpr expr
(mkCheckExpType arg_ty
)
200 ; return (NegApp expr
' neg_expr
') }
202 tcExpr e
@(HsIPVar x
) res_ty
203 = do { {- Implicit parameters must have a *tau-type* not a
204 type scheme. We enforce this by creating a fresh
205 type variable as its type. (Because res_ty may not
207 ip_ty
<- newOpenFlexiTyVarTy
208 ; let ip_name
= mkStrLitTy
(hsIPNameFS x
)
209 ; ipClass
<- tcLookupClass ipClassName
210 ; ip_var
<- emitWantedEvVar origin
(mkClassPred ipClass
[ip_name
, ip_ty
])
211 ; tcWrapResult e
(fromDict ipClass ip_name ip_ty
(HsVar
(noLoc ip_var
)))
214 -- Coerces a dictionary for `IP "x" t` into `t`.
215 fromDict ipClass x ty
= HsWrap
$ mkWpCastR
$
216 unwrapIP
$ mkClassPred ipClass
[x
,ty
]
217 origin
= IPOccOrigin x
219 tcExpr e
@(HsOverLabel l
) res_ty
-- See Note [Type-checking overloaded labels]
220 = do { isLabelClass
<- tcLookupClass isLabelClassName
221 ; alpha
<- newOpenFlexiTyVarTy
222 ; let lbl
= mkStrLitTy l
223 pred = mkClassPred isLabelClass
[lbl
, alpha
]
225 ; var
<- emitWantedEvVar origin
pred
226 ; let proxy_arg
= L loc
(mkHsWrap
(mkWpTyApps
[typeSymbolKind
, lbl
])
227 (HsVar
(L loc proxyHashId
)))
228 tm
= L loc
(fromDict
pred (HsVar
(L loc var
))) `HsApp` proxy_arg
229 ; tcWrapResult e tm alpha res_ty
}
231 -- Coerces a dictionary for `IsLabel "x" t` into `Proxy# x -> t`.
232 fromDict
pred = HsWrap
$ mkWpCastR
$ unwrapIP
pred
233 origin
= OverLabelOrigin l
235 tcExpr
(HsLam match
) res_ty
236 = do { (match
', wrap
) <- tcMatchLambda herald match_ctxt match res_ty
237 ; return (mkHsWrap wrap
(HsLam match
')) }
239 match_ctxt
= MC
{ mc_what
= LambdaExpr
, mc_body
= tcBody
}
240 herald
= sep
[ text
"The lambda expression" <+>
241 quotes
(pprSetDepth
(PartWay
1) $
243 -- The pprSetDepth makes the abstraction print briefly
246 tcExpr e
@(HsLamCase matches
) res_ty
247 = do { (matches
', wrap
)
248 <- tcMatchLambda msg match_ctxt matches res_ty
249 -- The laziness annotation is because we don't want to fail here
250 -- if there are multiple arguments
251 ; return (mkHsWrap wrap
$ HsLamCase matches
') }
253 msg
= sep
[ text
"The function" <+> quotes
(ppr e
)
255 match_ctxt
= MC
{ mc_what
= CaseAlt
, mc_body
= tcBody
}
257 tcExpr e
@(ExprWithTySig expr sig_ty
) res_ty
258 = do { let loc
= getLoc
(hsSigWcType sig_ty
)
259 ; sig_info
<- checkNoErrs
$ -- Avoid error cascade
260 tcUserTypeSig loc sig_ty Nothing
261 ; (expr
', poly_ty
) <- tcExprSig expr sig_info
262 ; let expr
'' = ExprWithTySigOut expr
' sig_ty
263 ; tcWrapResult e expr
'' poly_ty res_ty
}
266 Note [Type-checking overloaded labels]
267 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
268 Recall that (in GHC.OverloadedLabels) we have
270 class IsLabel (x :: Symbol) a where
271 fromLabel :: Proxy# x -> a
273 When we see an overloaded label like `#foo`, we generate a fresh
274 variable `alpha` for the type and emit an `IsLabel "foo" alpha`
275 constraint. Because the `IsLabel` class has a single method, it is
276 represented by a newtype, so we can coerce `IsLabel "foo" alpha` to
277 `Proxy# "foo" -> alpha` (just like for implicit parameters). We then
278 apply it to `proxy#` of type `Proxy# "foo"`.
280 That is, we translate `#foo` to `fromLabel (proxy# :: Proxy# "foo")`.
285 ************************************************************************
287 Infix operators and sections
289 ************************************************************************
293 Left sections, like (4 *), are equivalent to
295 or, if PostfixOperators is enabled, just
297 With PostfixOperators we don't actually require the function to take
298 two arguments at all. For example, (x `not`) means (not x); you get
299 postfix operators! Not Haskell 98, but it's less work and kind of
302 Note [Typing rule for ($)]
303 ~~~~~~~~~~~~~~~~~~~~~~~~~~
307 runST :: (forall s. ST s a) -> a
308 that I have finally given in and written a special type-checking
309 rule just for saturated applications of ($).
310 * Infer the type of the first argument
311 * Decompose it; should be of form (arg2_ty -> res_ty),
312 where arg2_ty might be a polytype
313 * Use arg2_ty to typecheck arg2
315 Note [Typing rule for seq]
316 ~~~~~~~~~~~~~~~~~~~~~~~~~~
319 which suggests this type for seq:
320 seq :: forall (a:*) (b:Open). a -> b -> b,
321 with (b:Open) meaning that be can be instantiated with an unboxed
322 tuple. The trouble is that this might accept a partially-applied
323 'seq', and I'm just not certain that would work. I'm only sure it's
324 only going to work when it's fully applied, so it turns into
325 case x of _ -> (# p,q #)
327 So it seems more uniform to treat 'seq' as it it was a language
330 See also Note [seqId magic] in MkId
333 tcExpr expr
@(OpApp arg1 op fix arg2
) res_ty
334 |
(L loc
(HsVar
(L lv op_name
))) <- op
335 , op_name `hasKey` seqIdKey
-- Note [Typing rule for seq]
336 = do { arg1_ty
<- newFlexiTyVarTy liftedTypeKind
337 ; let arg2_exp_ty
= res_ty
338 ; arg1
' <- tcArg op arg1 arg1_ty
1
339 ; arg2
' <- addErrCtxt
(funAppCtxt op arg2
2) $
340 tc_poly_expr_nc arg2 arg2_exp_ty
341 ; arg2_ty
<- readExpType arg2_exp_ty
342 ; op_id
<- tcLookupId op_name
343 ; let op
' = L loc
(HsWrap
(mkWpTyApps
[arg1_ty
, arg2_ty
])
344 (HsVar
(L lv op_id
)))
345 ; return $ OpApp arg1
' op
' fix arg2
' }
347 |
(L loc
(HsVar
(L lv op_name
))) <- op
348 , op_name `hasKey` dollarIdKey
-- Note [Typing rule for ($)]
349 = do { traceTc
"Application rule" (ppr op
)
350 ; (arg1
', arg1_ty
) <- tcInferSigma arg1
352 ; let doc
= text
"The first argument of ($) takes"
353 orig1
= exprCtOrigin
(unLoc arg1
)
354 ; (wrap_arg1
, [arg2_sigma
], op_res_ty
) <-
355 matchActualFunTys doc orig1
(Just arg1
) 1 arg1_ty
357 -- We have (arg1 $ arg2)
358 -- So: arg1_ty = arg2_ty -> op_res_ty
359 -- where arg2_sigma maybe polymorphic; that's the point
361 ; arg2
' <- tcArg op arg2 arg2_sigma
2
363 -- Make sure that the argument type has kind '*'
364 -- ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b
365 -- Eg we do not want to allow (D# $ 4.0#) Trac #5570
366 -- (which gives a seg fault)
368 -- The *result* type can have any kind (Trac #8739),
369 -- so we don't need to check anything for that
370 ; _
<- unifyKind
(Just arg2_sigma
) (typeKind arg2_sigma
) liftedTypeKind
371 -- ignore the evidence. arg2_sigma must have type * or #,
372 -- because we know arg2_sigma -> or_res_ty is well-kinded
373 -- (because otherwise matchActualFunTys would fail)
374 -- There's no possibility here of, say, a kind family reducing to *.
376 ; wrap_res
<- tcSubTypeHR orig1
(Just expr
) op_res_ty res_ty
379 ; op_id
<- tcLookupId op_name
380 ; res_ty
<- readExpType res_ty
381 ; let op
' = L loc
(HsWrap
(mkWpTyApps
[ getRuntimeRep
"tcExpr ($)" res_ty
384 (HsVar
(L lv op_id
)))
386 -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
387 -- wrap_res :: op_res_ty "->" res_ty
388 -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
390 -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)
391 wrap1
= mkWpFun idHsWrapper wrap_res arg2_sigma res_ty
394 ; return (OpApp
(mkLHsWrap wrap1 arg1
') op
' fix arg2
') }
396 |
(L loc
(HsRecFld
(Ambiguous lbl _
))) <- op
397 , Just sig_ty
<- obviousSig
(unLoc arg1
)
398 -- See Note [Disambiguating record fields]
399 = do { sig_tc_ty
<- tcHsSigWcType ExprSigCtxt sig_ty
400 ; sel_name
<- disambiguateSelector lbl sig_tc_ty
401 ; let op
' = L loc
(HsRecFld
(Unambiguous lbl sel_name
))
402 ; tcExpr
(OpApp arg1 op
' fix arg2
) res_ty
406 = do { traceTc
"Non Application rule" (ppr op
)
407 ; (wrap
, op
', [Left arg1
', Left arg2
'])
408 <- tcApp
(Just
$ mk_op_msg op
)
409 op
[Left arg1
, Left arg2
] res_ty
410 ; return (mkHsWrap wrap
$ OpApp arg1
' op
' fix arg2
') }
412 -- Right sections, equivalent to \ x -> x `op` expr, or
415 tcExpr expr
@(SectionR op arg2
) res_ty
416 = do { (op
', op_ty
) <- tcInferFun op
417 ; (wrap_fun
, [arg1_ty
, arg2_ty
], op_res_ty
) <-
418 matchActualFunTys
(mk_op_msg op
) SectionOrigin
(Just op
) 2 op_ty
419 ; wrap_res
<- tcSubTypeHR SectionOrigin
(Just expr
)
420 (mkFunTy arg1_ty op_res_ty
) res_ty
421 ; arg2
' <- tcArg op arg2 arg2_ty
2
422 ; return ( mkHsWrap wrap_res
$
423 SectionR
(mkLHsWrap wrap_fun op
') arg2
' ) }
425 tcExpr expr
@(SectionL arg1 op
) res_ty
426 = do { (op
', op_ty
) <- tcInferFun op
427 ; dflags
<- getDynFlags
-- Note [Left sections]
428 ; let n_reqd_args | xopt LangExt
.PostfixOperators dflags
= 1
431 ; (wrap_fn
, (arg1_ty
:arg_tys
), op_res_ty
)
432 <- matchActualFunTys
(mk_op_msg op
) SectionOrigin
(Just op
)
434 ; wrap_res
<- tcSubTypeHR SectionOrigin
(Just expr
)
435 (mkFunTys arg_tys op_res_ty
) res_ty
436 ; arg1
' <- tcArg op arg1 arg1_ty
1
437 ; return ( mkHsWrap wrap_res
$
438 SectionL arg1
' (mkLHsWrap wrap_fn op
') ) }
440 tcExpr expr
@(ExplicitTuple tup_args boxity
) res_ty
441 |
all tupArgPresent tup_args
442 = do { let arity
= length tup_args
443 tup_tc
= tupleTyCon boxity arity
444 ; res_ty
<- expTypeToType res_ty
445 ; (coi
, arg_tys
) <- matchExpectedTyConApp tup_tc res_ty
446 -- Unboxed tuples have RuntimeRep vars, which we
447 -- don't care about here
448 -- See Note [Unboxed tuple RuntimeRep vars] in TyCon
449 ; let arg_tys
' = case boxity
of Unboxed
-> drop arity arg_tys
451 ; tup_args1
<- tcTupArgs tup_args arg_tys
'
452 ; return $ mkHsWrapCo coi
(ExplicitTuple tup_args1 boxity
) }
455 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
456 do { let arity
= length tup_args
458 ; arg_tys
<- case boxity
of
459 { Boxed
-> newFlexiTyVarTys arity liftedTypeKind
460 ; Unboxed
-> replicateM arity newOpenFlexiTyVarTy
}
462 = mkFunTys
[ty |
(ty
, (L _
(Missing _
))) <- arg_tys `
zip` tup_args
]
463 (mkTupleTy boxity arg_tys
)
465 ; wrap
<- tcSubTypeHR
(Shouldn
'tHappenOrigin
"ExpTuple")
469 -- Handle tuple sections where
470 ; tup_args1
<- tcTupArgs tup_args arg_tys
472 ; return $ mkHsWrap wrap
(ExplicitTuple tup_args1 boxity
) }
474 tcExpr
(ExplicitSum alt arity expr _
) res_ty
475 = do { let sum_tc
= sumTyCon arity
476 ; res_ty
<- expTypeToType res_ty
477 ; (coi
, arg_tys
) <- matchExpectedTyConApp sum_tc res_ty
478 ; -- Drop levity vars, we don't care about them here
479 let arg_tys
' = drop arity arg_tys
480 ; expr
' <- tcPolyExpr expr
(arg_tys
' `getNth`
(alt
- 1))
481 ; return $ mkHsWrapCo coi
(ExplicitSum alt arity expr
' arg_tys
') }
483 tcExpr
(ExplicitList _ witness exprs
) res_ty
485 Nothing
-> do { res_ty
<- expTypeToType res_ty
486 ; (coi
, elt_ty
) <- matchExpectedListTy res_ty
487 ; exprs
' <- mapM (tc_elt elt_ty
) exprs
489 mkHsWrapCo coi
$ ExplicitList elt_ty Nothing exprs
' }
491 Just fln
-> do { ((exprs
', elt_ty
), fln
')
492 <- tcSyntaxOp ListOrigin fln
493 [synKnownType intTy
, SynList
] res_ty
$
496 mapM (tc_elt elt_ty
) exprs
497 ; return (exprs
', elt_ty
) }
499 ; return $ ExplicitList elt_ty
(Just fln
') exprs
' }
500 where tc_elt elt_ty expr
= tcPolyExpr expr elt_ty
502 tcExpr
(ExplicitPArr _ exprs
) res_ty
-- maybe empty
503 = do { res_ty
<- expTypeToType res_ty
504 ; (coi
, elt_ty
) <- matchExpectedPArrTy res_ty
505 ; exprs
' <- mapM (tc_elt elt_ty
) exprs
507 mkHsWrapCo coi
$ ExplicitPArr elt_ty exprs
' }
509 tc_elt elt_ty expr
= tcPolyExpr expr elt_ty
512 ************************************************************************
516 ************************************************************************
519 tcExpr
(HsLet
(L l binds
) expr
) res_ty
520 = do { (binds
', expr
') <- tcLocalBinds binds
$
521 tcMonoExpr expr res_ty
522 ; return (HsLet
(L l binds
') expr
') }
524 tcExpr
(HsCase scrut matches
) res_ty
525 = do { -- We used to typecheck the case alternatives first.
526 -- The case patterns tend to give good type info to use
527 -- when typechecking the scrutinee. For example
530 -- will report that map is applied to too few arguments
532 -- But now, in the GADT world, we need to typecheck the scrutinee
533 -- first, to get type info that may be refined in the case alternatives
534 (scrut
', scrut_ty
) <- tcInferRho scrut
536 ; traceTc
"HsCase" (ppr scrut_ty
)
537 ; matches
' <- tcMatchesCase match_ctxt scrut_ty matches res_ty
538 ; return (HsCase scrut
' matches
') }
540 match_ctxt
= MC
{ mc_what
= CaseAlt
,
543 tcExpr
(HsIf Nothing
pred b1 b2
) res_ty
-- Ordinary 'if'
544 = do { pred' <- tcMonoExpr
pred (mkCheckExpType boolTy
)
545 ; res_ty
<- tauifyExpType res_ty
546 -- Just like Note [Case branches must never infer a non-tau type]
547 -- in TcMatches (See #10619)
549 ; b1
' <- tcMonoExpr b1 res_ty
550 ; b2
' <- tcMonoExpr b2 res_ty
551 ; return (HsIf Nothing
pred' b1
' b2
') }
553 tcExpr
(HsIf
(Just fun
) pred b1 b2
) res_ty
554 = do { ((pred', b1
', b2
'), fun
')
555 <- tcSyntaxOp IfOrigin fun
[SynAny
, SynAny
, SynAny
] res_ty
$
556 \ [pred_ty
, b1_ty
, b2_ty
] ->
557 do { pred' <- tcPolyExpr
pred pred_ty
558 ; b1
' <- tcPolyExpr b1 b1_ty
559 ; b2
' <- tcPolyExpr b2 b2_ty
560 ; return (pred', b1
', b2
') }
561 ; return (HsIf
(Just fun
') pred' b1
' b2
') }
563 tcExpr
(HsMultiIf _ alts
) res_ty
564 = do { res_ty
<- if isSingleton alts
566 else tauifyExpType res_ty
567 -- Just like TcMatches
568 -- Note [Case branches must never infer a non-tau type]
570 ; alts
' <- mapM (wrapLocM
$ tcGRHS match_ctxt res_ty
) alts
571 ; res_ty
<- readExpType res_ty
572 ; return (HsMultiIf res_ty alts
') }
573 where match_ctxt
= MC
{ mc_what
= IfAlt
, mc_body
= tcBody
}
575 tcExpr
(HsDo do_or_lc stmts _
) res_ty
576 = do { expr
' <- tcDoStmts do_or_lc stmts res_ty
579 tcExpr
(HsProc pat cmd
) res_ty
580 = do { (pat
', cmd
', coi
) <- tcProc pat cmd res_ty
581 ; return $ mkHsWrapCo coi
(HsProc pat
' cmd
') }
583 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
584 -- See Note [Grand plan for static forms] in StaticPtrTable for an overview.
585 tcExpr
(HsStatic fvs expr
) res_ty
586 = do { res_ty
<- expTypeToType res_ty
587 ; (co
, (p_ty
, expr_ty
)) <- matchExpectedAppTy res_ty
588 ; (expr
', lie
) <- captureConstraints
$
589 addErrCtxt
(hang
(text
"In the body of a static form:")
592 tcPolyExprNC expr expr_ty
593 -- Check that the free variables of the static form are closed.
594 -- It's OK to use nonDetEltsUFM here as the only side effects of
595 -- checkClosedInStaticForm are error messages.
596 ; mapM_ checkClosedInStaticForm
$ nonDetEltsUFM fvs
598 -- Require the type of the argument to be Typeable.
599 -- The evidence is not used, but asking the constraint ensures that
600 -- the current implementation is as restrictive as future versions
601 -- of the StaticPointers extension.
602 ; typeableClass
<- tcLookupClass typeableClassName
603 ; _
<- emitWantedEvVar StaticOrigin
$
604 mkTyConApp
(classTyCon typeableClass
)
605 [liftedTypeKind
, expr_ty
]
606 -- Insert the constraints of the static form in a global list for later
608 ; emitStaticConstraints lie
610 -- Wrap the static form with the 'fromStaticPtr' call.
611 ; fromStaticPtr
<- newMethodFromName StaticOrigin fromStaticPtrName p_ty
612 ; let wrap
= mkWpTyApps
[expr_ty
]
614 ; return $ mkHsWrapCo co
$ HsApp
(L loc
$ mkHsWrap wrap fromStaticPtr
)
615 (L loc
(HsStatic fvs expr
'))
619 ************************************************************************
621 Record construction and update
623 ************************************************************************
626 tcExpr expr
@(RecordCon
{ rcon_con_name
= L loc con_name
627 , rcon_flds
= rbinds
}) res_ty
628 = do { con_like
<- tcLookupConLike con_name
630 -- Check for missing fields
631 ; checkMissingFields con_like rbinds
633 ; (con_expr
, con_sigma
) <- tcInferId con_name
634 ; (con_wrap
, con_tau
) <-
635 topInstantiate
(OccurrenceOf con_name
) con_sigma
636 -- a shallow instantiation should really be enough for
637 -- a data constructor.
638 ; let arity
= conLikeArity con_like
639 Right
(arg_tys
, actual_res_ty
) = tcSplitFunTysN arity con_tau
640 ; case conLikeWrapId_maybe con_like
of
641 Nothing
-> nonBidirectionalErr
(conLikeName con_like
)
643 res_wrap
<- tcSubTypeHR
(Shouldn
'tHappenOrigin
"RecordCon")
644 (Just expr
) actual_res_ty res_ty
645 ; rbinds
' <- tcRecordBinds con_like arg_tys rbinds
648 RecordCon
{ rcon_con_name
= L loc con_id
649 , rcon_con_expr
= mkHsWrap con_wrap con_expr
650 , rcon_con_like
= con_like
651 , rcon_flds
= rbinds
' } } }
654 Note [Type of a record update]
655 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
656 The main complication with RecordUpd is that we need to explicitly
657 handle the *non-updated* fields. Consider:
659 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
660 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
663 upd :: T a b c -> (b',c) -> T a b' c
664 upd t x = t { fb = x}
666 The result type should be (T a b' c)
667 not (T a b c), because 'b' *is not* mentioned in a non-updated field
668 not (T a b' c'), because 'c' *is* mentioned in a non-updated field
669 NB that it's not good enough to look at just one constructor; we must
670 look at them all; cf Trac #3219
672 After all, upd should be equivalent to:
678 So we need to give a completely fresh type to the result record,
679 and then constrain it by the fields that are *not* updated ("p" above).
680 We call these the "fixed" type variables, and compute them in getFixedTyVars.
682 Note that because MkT3 doesn't contain all the fields being updated,
683 its RHS is simply an error, so it doesn't impose any type constraints.
684 Hence the use of 'relevant_cont'.
686 Note [Implicit type sharing]
687 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
688 We also take into account any "implicit" non-update fields. For example
689 data T a b where { MkT { f::a } :: T a a; ... }
690 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
695 upd :: T a b -> a -> T a b
696 upd (t::T a b) (x::a)
697 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
698 We can't give it the more general type
699 upd :: T a b -> c -> T c b
701 Note [Criteria for update]
702 ~~~~~~~~~~~~~~~~~~~~~~~~~~
703 We want to allow update for existentials etc, provided the updated
704 field isn't part of the existential. For example, this should be ok.
705 data T a where { MkT { f1::a, f2::b->b } :: T a }
709 The criterion we use is this:
711 The types of the updated fields
712 mention only the universally-quantified type variables
713 of the data constructor
715 NB: this is not (quite) the same as being a "naughty" record selector
716 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
717 in the case of GADTs. Consider
718 data T a where { MkT :: { f :: a } :: T [a] }
719 Then f is not "naughty" because it has a well-typed record selector.
720 But we don't allow updates for 'f'. (One could consider trying to
721 allow this, but it makes my head hurt. Badly. And no one has asked
724 In principle one could go further, and allow
726 g t = t { f2 = \x -> x }
727 because the expression is polymorphic...but that seems a bridge too far.
729 Note [Data family example]
730 ~~~~~~~~~~~~~~~~~~~~~~~~~~
731 data instance T (a,b) = MkT { x::a, y::b }
733 data :TP a b = MkT { a::a, y::b }
734 coTP a b :: T (a,b) ~ :TP a b
736 Suppose r :: T (t1,t2), e :: t3
737 Then r { x=e } :: T (t3,t1)
740 MkT x y -> MkT e y |> co2
741 where co1 :: T (t1,t2) ~ :TP t1 t2
742 co2 :: :TP t3 t2 ~ T (t3,t2)
743 The wrapping with co2 is done by the constructor wrapper for MkT
747 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
749 * cons are the data constructors to be updated
751 * in_inst_tys, out_inst_tys have same length, and instantiate the
752 *representation* tycon of the data cons. In Note [Data
753 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
755 Note [Mixed Record Field Updates]
756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
757 Consider the following pattern synonym.
759 data MyRec = MyRec { foo :: Int, qux :: String }
761 pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
763 This allows updates such as the following
765 updater :: MyRec -> MyRec
766 updater a = a {f1 = 1 }
768 It would also make sense to allow the following update (which we reject).
770 updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
772 This leads to confusing behaviour when the selectors in fact refer the same
775 updater a = a {f1 = 1, foo = 2} ==? ???
777 For this reason, we reject a mixture of pattern synonym and normal record
778 selectors in the same update block. Although of course we still allow the
781 updater a = (a {f1 = 1}) {foo = 2}
783 > updater (MyRec 0 "str")
788 tcExpr expr
@(RecordUpd
{ rupd_expr
= record_expr
, rupd_flds
= rbnds
}) res_ty
789 = ASSERT
( notNull rbnds
)
790 do { -- STEP -2: typecheck the record_expr, the record to be updated
791 (record_expr
', record_rho
) <- tcInferRho record_expr
793 -- STEP -1 See Note [Disambiguating record fields]
794 -- After this we know that rbinds is unambiguous
795 ; rbinds
<- disambiguateRecordBinds record_expr record_rho rbnds res_ty
796 ; let upd_flds
= map (unLoc
. hsRecFieldLbl
. unLoc
) rbinds
797 upd_fld_occs
= map (occNameFS
. rdrNameOcc
. rdrNameAmbiguousFieldOcc
) upd_flds
798 sel_ids
= map selectorAmbiguousFieldOcc upd_flds
800 -- Check that the field names are really field names
801 -- and they are all field names for proper records or
802 -- all field names for pattern synonyms.
803 ; let bad_guys
= [ setSrcSpan loc
$ addErrTc
(notSelector fld_name
)
805 -- Excludes class ops
806 let L loc sel_id
= hsRecUpdFieldId
(unLoc fld
),
807 not (isRecordSelector sel_id
),
808 let fld_name
= idName sel_id
]
809 ; unless (null bad_guys
) (sequence bad_guys
>> failM
)
810 -- See note [Mixed Record Selectors]
811 ; let (data_sels
, pat_syn_sels
) =
812 partition isDataConRecordSelector sel_ids
813 ; MASSERT
( all isPatSynRecordSelector pat_syn_sels
)
814 ; checkTc
( null data_sels ||
null pat_syn_sels
)
815 ( mixedSelectors data_sels pat_syn_sels
)
818 -- Figure out the tycon and data cons from the first field name
819 ; let -- It's OK to use the non-tc splitters here (for a selector)
822 mtycon
:: Maybe TyCon
823 mtycon
= case idDetails sel_id
of
824 RecSelId
(RecSelData tycon
) _
-> Just tycon
827 con_likes
:: [ConLike
]
828 con_likes
= case idDetails sel_id
of
829 RecSelId
(RecSelData tc
) _
830 -> map RealDataCon
(tyConDataCons tc
)
831 RecSelId
(RecSelPatSyn ps
) _
833 _
-> panic
"tcRecordUpd"
834 -- NB: for a data type family, the tycon is the instance tycon
836 relevant_cons
= conLikesWithFields con_likes upd_fld_occs
837 -- A constructor is only relevant to this process if
838 -- it contains *all* the fields that are being updated
839 -- Other ones will cause a runtime error if they occur
842 -- Check that at least one constructor has all the named fields
843 -- i.e. has an empty set of bad fields returned by badFields
844 ; checkTc
(not (null relevant_cons
)) (badFieldsUpd rbinds con_likes
)
846 -- Take apart a representative constructor
847 ; let con1
= ASSERT
( not (null relevant_cons
) ) head relevant_cons
848 (con1_tvs
, _
, _
, _prov_theta
, req_theta
, con1_arg_tys
, _
)
849 = conLikeFullSig con1
850 con1_flds
= map flLabel
$ conLikeFieldLabels con1
851 con1_tv_tys
= mkTyVarTys con1_tvs
852 con1_res_ty
= case mtycon
of
853 Just tc
-> mkFamilyTyConApp tc con1_tv_tys
854 Nothing
-> conLikeResTy con1 con1_tv_tys
856 -- Check that we're not dealing with a unidirectional pattern
858 ; unless (isJust $ conLikeWrapId_maybe con1
)
859 (nonBidirectionalErr
(conLikeName con1
))
861 -- STEP 3 Note [Criteria for update]
862 -- Check that each updated field is polymorphic; that is, its type
863 -- mentions only the universally-quantified variables of the data con
864 ; let flds1_w_tys
= zipEqual
"tcExpr:RecConUpd" con1_flds con1_arg_tys
865 bad_upd_flds
= filter bad_fld flds1_w_tys
866 con1_tv_set
= mkVarSet con1_tvs
867 bad_fld
(fld
, ty
) = fld `
elem` upd_fld_occs
&&
868 not (tyCoVarsOfType ty `subVarSet` con1_tv_set
)
869 ; checkTc
(null bad_upd_flds
) (badFieldTypes bad_upd_flds
)
871 -- STEP 4 Note [Type of a record update]
872 -- Figure out types for the scrutinee and result
873 -- Both are of form (T a b c), with fresh type variables, but with
874 -- common variables where the scrutinee and result must have the same type
875 -- These are variables that appear in *any* arg of *any* of the
876 -- relevant constructors *except* in the updated fields
878 ; let fixed_tvs
= getFixedTyVars upd_fld_occs con1_tvs relevant_cons
879 is_fixed_tv tv
= tv `elemVarSet` fixed_tvs
881 mk_inst_ty
:: TCvSubst
-> (TyVar
, TcType
) -> TcM
(TCvSubst
, TcType
)
882 -- Deals with instantiation of kind variables
883 -- c.f. TcMType.newMetaTyVars
884 mk_inst_ty subst
(tv
, result_inst_ty
)
885 | is_fixed_tv tv
-- Same as result type
886 = return (extendTvSubst subst tv result_inst_ty
, result_inst_ty
)
887 |
otherwise -- Fresh type, of correct kind
888 = do { (subst
', new_tv
) <- newMetaTyVarX subst tv
889 ; return (subst
', mkTyVarTy new_tv
) }
891 ; (result_subst
, con1_tvs
') <- newMetaTyVars con1_tvs
892 ; let result_inst_tys
= mkTyVarTys con1_tvs
'
893 init_subst
= mkEmptyTCvSubst
(getTCvInScope result_subst
)
895 ; (scrut_subst
, scrut_inst_tys
) <- mapAccumLM mk_inst_ty init_subst
896 (con1_tvs `
zip` result_inst_tys
)
898 ; let rec_res_ty
= TcType
.substTy result_subst con1_res_ty
899 scrut_ty
= TcType
.substTy scrut_subst con1_res_ty
900 con1_arg_tys
' = map (TcType
.substTy result_subst
) con1_arg_tys
902 ; wrap_res
<- tcSubTypeHR
(exprCtOrigin expr
)
903 (Just expr
) rec_res_ty res_ty
904 ; co_scrut
<- unifyType
(Just record_expr
) record_rho scrut_ty
905 -- NB: normal unification is OK here (as opposed to subsumption),
906 -- because for this to work out, both record_rho and scrut_ty have
907 -- to be normal datatypes -- no contravariant stuff can go on
910 -- Typecheck the bindings
911 ; rbinds
' <- tcRecordUpd con1 con1_arg_tys
' rbinds
913 -- STEP 6: Deal with the stupid theta
914 ; let theta
' = substThetaUnchecked scrut_subst
(conLikeStupidTheta con1
)
915 ; instStupidTheta RecordUpdOrigin theta
'
917 -- Step 7: make a cast for the scrutinee, in the
918 -- case that it's from a data family
919 ; let fam_co
:: HsWrapper
-- RepT t1 .. tn ~R scrut_ty
920 fam_co | Just tycon
<- mtycon
921 , Just co_con
<- tyConFamilyCoercion_maybe tycon
922 = mkWpCastR
(mkTcUnbranchedAxInstCo co_con scrut_inst_tys
[])
926 -- Step 8: Check that the req constraints are satisfied
927 -- For normal data constructors req_theta is empty but we must do
928 -- this check for pattern synonyms.
929 ; let req_theta
' = substThetaUnchecked scrut_subst req_theta
930 ; req_wrap
<- instCallConstraints RecordUpdOrigin req_theta
'
935 RecordUpd
{ rupd_expr
= mkLHsWrap fam_co
(mkLHsWrapCo co_scrut record_expr
')
936 , rupd_flds
= rbinds
'
937 , rupd_cons
= relevant_cons
, rupd_in_tys
= scrut_inst_tys
938 , rupd_out_tys
= result_inst_tys
, rupd_wrap
= req_wrap
} }
940 tcExpr
(HsRecFld f
) res_ty
941 = tcCheckRecSelId f res_ty
944 ************************************************************************
946 Arithmetic sequences e.g. [a,b..]
947 and their parallel-array counterparts e.g. [: a,b.. :]
950 ************************************************************************
953 tcExpr
(ArithSeq _ witness
seq) res_ty
954 = tcArithSeq witness
seq res_ty
956 tcExpr
(PArrSeq _
seq@(FromTo expr1 expr2
)) res_ty
957 = do { res_ty
<- expTypeToType res_ty
958 ; (coi
, elt_ty
) <- matchExpectedPArrTy res_ty
959 ; expr1
' <- tcPolyExpr expr1 elt_ty
960 ; expr2
' <- tcPolyExpr expr2 elt_ty
961 ; enumFromToP
<- initDsTc
$ dsDPHBuiltin enumFromToPVar
962 ; enum_from_to
<- newMethodFromName
(PArrSeqOrigin
seq)
963 (idName enumFromToP
) elt_ty
965 mkHsWrapCo coi
$ PArrSeq enum_from_to
(FromTo expr1
' expr2
') }
967 tcExpr
(PArrSeq _
seq@(FromThenTo expr1 expr2 expr3
)) res_ty
968 = do { res_ty
<- expTypeToType res_ty
969 ; (coi
, elt_ty
) <- matchExpectedPArrTy res_ty
970 ; expr1
' <- tcPolyExpr expr1 elt_ty
971 ; expr2
' <- tcPolyExpr expr2 elt_ty
972 ; expr3
' <- tcPolyExpr expr3 elt_ty
973 ; enumFromThenToP
<- initDsTc
$ dsDPHBuiltin enumFromThenToPVar
974 ; eft
<- newMethodFromName
(PArrSeqOrigin
seq)
975 (idName enumFromThenToP
) elt_ty
-- !!!FIXME: chak
978 PArrSeq eft
(FromThenTo expr1
' expr2
' expr3
') }
980 tcExpr
(PArrSeq _ _
) _
981 = panic
"TcExpr.tcExpr: Infinite parallel array!"
982 -- the parser shouldn't have generated it and the renamer shouldn't have
986 ************************************************************************
990 ************************************************************************
993 -- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.
994 -- Here we get rid of it and add the finalizers to the global environment.
996 -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.
997 tcExpr
(HsSpliceE
(HsSpliced mod_finalizers
(HsSplicedExpr expr
)))
999 = do addModFinalizersWithLclEnv mod_finalizers
1001 tcExpr
(HsSpliceE splice
) res_ty
1002 = tcSpliceExpr splice res_ty
1003 tcExpr
(HsBracket brack
) res_ty
1004 = tcTypedBracket brack res_ty
1005 tcExpr
(HsRnBracketOut brack ps
) res_ty
1006 = tcUntypedBracket brack ps res_ty
1009 ************************************************************************
1013 ************************************************************************
1016 tcExpr other _
= pprPanic
"tcMonoExpr" (ppr other
)
1017 -- Include ArrForm, ArrApp, which shouldn't appear at all
1018 -- Also HsTcBracketOut, HsQuasiQuoteE
1021 ************************************************************************
1023 Arithmetic sequences [a..b] etc
1025 ************************************************************************
1028 tcArithSeq
:: Maybe (SyntaxExpr Name
) -> ArithSeqInfo Name
-> ExpRhoType
1029 -> TcM
(HsExpr TcId
)
1031 tcArithSeq witness
seq@(From expr
) res_ty
1032 = do { (wrap
, elt_ty
, wit
') <- arithSeqEltType witness res_ty
1033 ; expr
' <- tcPolyExpr expr elt_ty
1034 ; enum_from
<- newMethodFromName
(ArithSeqOrigin
seq)
1036 ; return $ mkHsWrap wrap
$
1037 ArithSeq enum_from wit
' (From expr
') }
1039 tcArithSeq witness
seq@(FromThen expr1 expr2
) res_ty
1040 = do { (wrap
, elt_ty
, wit
') <- arithSeqEltType witness res_ty
1041 ; expr1
' <- tcPolyExpr expr1 elt_ty
1042 ; expr2
' <- tcPolyExpr expr2 elt_ty
1043 ; enum_from_then
<- newMethodFromName
(ArithSeqOrigin
seq)
1044 enumFromThenName elt_ty
1045 ; return $ mkHsWrap wrap
$
1046 ArithSeq enum_from_then wit
' (FromThen expr1
' expr2
') }
1048 tcArithSeq witness
seq@(FromTo expr1 expr2
) res_ty
1049 = do { (wrap
, elt_ty
, wit
') <- arithSeqEltType witness res_ty
1050 ; expr1
' <- tcPolyExpr expr1 elt_ty
1051 ; expr2
' <- tcPolyExpr expr2 elt_ty
1052 ; enum_from_to
<- newMethodFromName
(ArithSeqOrigin
seq)
1053 enumFromToName elt_ty
1054 ; return $ mkHsWrap wrap
$
1055 ArithSeq enum_from_to wit
' (FromTo expr1
' expr2
') }
1057 tcArithSeq witness
seq@(FromThenTo expr1 expr2 expr3
) res_ty
1058 = do { (wrap
, elt_ty
, wit
') <- arithSeqEltType witness res_ty
1059 ; expr1
' <- tcPolyExpr expr1 elt_ty
1060 ; expr2
' <- tcPolyExpr expr2 elt_ty
1061 ; expr3
' <- tcPolyExpr expr3 elt_ty
1062 ; eft
<- newMethodFromName
(ArithSeqOrigin
seq)
1063 enumFromThenToName elt_ty
1064 ; return $ mkHsWrap wrap
$
1065 ArithSeq eft wit
' (FromThenTo expr1
' expr2
' expr3
') }
1068 arithSeqEltType
:: Maybe (SyntaxExpr Name
) -> ExpRhoType
1069 -> TcM
(HsWrapper
, TcType
, Maybe (SyntaxExpr Id
))
1070 arithSeqEltType Nothing res_ty
1071 = do { res_ty
<- expTypeToType res_ty
1072 ; (coi
, elt_ty
) <- matchExpectedListTy res_ty
1073 ; return (mkWpCastN coi
, elt_ty
, Nothing
) }
1074 arithSeqEltType
(Just fl
) res_ty
1075 = do { (elt_ty
, fl
')
1076 <- tcSyntaxOp ListOrigin fl
[SynList
] res_ty
$
1077 \ [elt_ty
] -> return elt_ty
1078 ; return (idHsWrapper
, elt_ty
, Just fl
') }
1081 ************************************************************************
1085 ************************************************************************
1088 type LHsExprArgIn
= Either (LHsExpr Name
) (LHsWcType Name
)
1089 type LHsExprArgOut
= Either (LHsExpr TcId
) (LHsWcType Name
)
1090 -- Left e => argument expression
1091 -- Right ty => visible type application
1093 tcApp1
:: HsExpr Name
-- either HsApp or HsAppType
1094 -> ExpRhoType
-> TcM
(HsExpr TcId
)
1096 = do { (wrap
, fun
, args
) <- tcApp Nothing
(noLoc e
) [] res_ty
1097 ; return (mkHsWrap wrap
$ unLoc
$ foldl mk_hs_app fun args
) }
1099 mk_hs_app f
(Left a
) = mkHsApp f a
1100 mk_hs_app f
(Right a
) = mkHsAppTypeOut f a
1102 tcApp
:: Maybe SDoc
-- like "The function `f' is applied to"
1103 -- or leave out to get exactly that message
1104 -> LHsExpr Name
-> [LHsExprArgIn
] -- Function and args
1105 -> ExpRhoType
-> TcM
(HsWrapper
, LHsExpr TcId
, [LHsExprArgOut
])
1106 -- (wrap, fun, args). For an ordinary function application,
1107 -- these should be assembled as (wrap (fun args)).
1108 -- But OpApp is slightly different, so that's why the caller
1111 tcApp m_herald orig_fun orig_args res_ty
1112 = go orig_fun orig_args
1114 go
:: LHsExpr Name
-> [LHsExprArgIn
]
1115 -> TcM
(HsWrapper
, LHsExpr TcId
, [LHsExprArgOut
])
1116 go
(L _
(HsPar e
)) args
= go e args
1117 go
(L _
(HsApp e1 e2
)) args
= go e1
(Left e2
:args
)
1118 go
(L _
(HsAppType e t
)) args
= go e
(Right t
:args
)
1120 go
(L loc
(HsVar
(L _ fun
))) args
1121 | fun `hasKey` tagToEnumKey
1122 , count isLeft args
== 1
1123 = do { (wrap
, expr
, args
) <- tcTagToEnum loc fun args res_ty
1124 ; return (wrap
, expr
, args
) }
1126 | fun `hasKey` seqIdKey
1127 , count isLeft args
== 2
1128 = do { (wrap
, expr
, args
) <- tcSeq loc fun args res_ty
1129 ; return (wrap
, expr
, args
) }
1131 go
(L loc
(HsRecFld
(Ambiguous lbl _
))) args
@(Left
(L _ arg
) : _
)
1132 | Just sig_ty
<- obviousSig arg
1133 = do { sig_tc_ty
<- tcHsSigWcType ExprSigCtxt sig_ty
1134 ; sel_name
<- disambiguateSelector lbl sig_tc_ty
1135 ; go
(L loc
(HsRecFld
(Unambiguous lbl sel_name
))) args
}
1138 = do { -- Type-check the function
1139 ; (fun1
, fun_sigma
) <- tcInferFun fun
1140 ; let orig
= exprCtOrigin
(unLoc fun
)
1142 ; (wrap_fun
, args1
, actual_res_ty
)
1143 <- tcArgs fun fun_sigma orig args
1144 (m_herald `orElse` mk_app_msg fun
)
1146 -- this is just like tcWrapResult, but the types don't line
1147 -- up to call that function
1148 ; wrap_res
<- addFunResCtxt
True (unLoc fun
) actual_res_ty res_ty
$
1149 tcSubTypeDS_NC_O orig GenSigCtxt
1150 (Just
$ foldl mk_hs_app fun args
)
1151 actual_res_ty res_ty
1153 ; return (wrap_res
, mkLHsWrap wrap_fun fun1
, args1
) }
1155 mk_hs_app f
(Left a
) = mkHsApp f a
1156 mk_hs_app f
(Right a
) = mkHsAppType f a
1158 mk_app_msg
:: LHsExpr Name
-> SDoc
1159 mk_app_msg fun
= sep
[ text
"The function" <+> quotes
(ppr fun
)
1160 , text
"is applied to"]
1162 mk_op_msg
:: LHsExpr Name
-> SDoc
1163 mk_op_msg op
= text
"The operator" <+> quotes
(ppr op
) <+> text
"takes"
1166 tcInferFun
:: LHsExpr Name
-> TcM
(LHsExpr TcId
, TcSigmaType
)
1167 -- Infer type of a function
1168 tcInferFun
(L loc
(HsVar
(L _ name
)))
1169 = do { (fun
, ty
) <- setSrcSpan loc
(tcInferId name
)
1170 -- Don't wrap a context around a plain Id
1171 ; return (L loc fun
, ty
) }
1173 tcInferFun
(L loc
(HsRecFld f
))
1174 = do { (fun
, ty
) <- setSrcSpan loc
(tcInferRecSelId f
)
1175 -- Don't wrap a context around a plain Id
1176 ; return (L loc fun
, ty
) }
1180 -- NB: tcInferSigma; see TcUnify
1181 -- Note [Deep instantiation of InferResult]
1185 -- | Type-check the arguments to a function, possibly including visible type
1187 tcArgs
:: LHsExpr Name
-- ^ The function itself (for err msgs only)
1188 -> TcSigmaType
-- ^ the (uninstantiated) type of the function
1189 -> CtOrigin
-- ^ the origin for the function's type
1190 -> [LHsExprArgIn
] -- ^ the args
1191 -> SDoc
-- ^ the herald for matchActualFunTys
1192 -> TcM
(HsWrapper
, [LHsExprArgOut
], TcSigmaType
)
1193 -- ^ (a wrapper for the function, the tc'd args, result type)
1194 tcArgs fun orig_fun_ty fun_orig orig_args herald
1195 = go
[] 1 orig_fun_ty orig_args
1197 orig_arity
= length orig_args
1199 go _ _ fun_ty
[] = return (idHsWrapper
, [], fun_ty
)
1201 go acc_args n fun_ty
(Right hs_ty_arg
:args
)
1202 = do { (wrap1
, upsilon_ty
) <- topInstantiateInferred fun_orig fun_ty
1203 -- wrap1 :: fun_ty "->" upsilon_ty
1204 ; case tcSplitForAllTy_maybe upsilon_ty
of
1205 Just
(tvb
, inner_ty
) ->
1206 do { let tv
= binderVar tvb
1207 vis
= binderArgFlag tvb
1209 ; MASSERT2
( vis
== Specified
1210 , (vcat
[ ppr fun_ty
, ppr upsilon_ty
, ppr tvb
1211 , ppr inner_ty
, pprTyVar tv
1213 ; ty_arg
<- tcHsTypeApp hs_ty_arg kind
1214 ; let insted_ty
= substTyWithUnchecked
[tv
] [ty_arg
] inner_ty
1215 ; (inner_wrap
, args
', res_ty
)
1216 <- go acc_args
(n
+1) insted_ty args
1217 -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty
1218 ; let inst_wrap
= mkWpTyApps
[ty_arg
]
1219 ; return ( inner_wrap
<.> inst_wrap
<.> wrap1
1220 , Right hs_ty_arg
: args
'
1222 _
-> ty_app_err upsilon_ty hs_ty_arg
}
1224 go acc_args n fun_ty
(Left arg
: args
)
1225 = do { (wrap
, [arg_ty
], res_ty
)
1226 <- matchActualFunTysPart herald fun_orig
(Just fun
) 1 fun_ty
1228 -- wrap :: fun_ty "->" arg_ty -> res_ty
1229 ; arg
' <- tcArg fun arg arg_ty n
1230 ; (inner_wrap
, args
', inner_res_ty
)
1231 <- go
(arg_ty
: acc_args
) (n
+1) res_ty args
1232 -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty
1233 ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty
<.> wrap
1238 = do { (_
, ty
) <- zonkTidyTcType emptyTidyEnv ty
1240 text
"Cannot apply expression of type" <+> quotes
(ppr ty
) $$
1241 text
"to a visible type argument" <+> quotes
(ppr arg
) }
1244 tcArg
:: LHsExpr Name
-- The function (for error messages)
1245 -> LHsExpr Name
-- Actual arguments
1246 -> TcRhoType
-- expected arg type
1247 -> Int -- # of argument
1248 -> TcM
(LHsExpr TcId
) -- Resulting argument
1249 tcArg fun arg ty arg_no
= addErrCtxt
(funAppCtxt fun arg arg_no
) $
1253 tcTupArgs
:: [LHsTupArg Name
] -> [TcSigmaType
] -> TcM
[LHsTupArg TcId
]
1255 = ASSERT
( equalLength args tys
) mapM go
(args `
zip` tys
)
1257 go
(L l
(Missing
{}), arg_ty
) = return (L l
(Missing arg_ty
))
1258 go
(L l
(Present expr
), arg_ty
) = do { expr
' <- tcPolyExpr expr arg_ty
1259 ; return (L l
(Present expr
')) }
1261 ---------------------------
1262 -- See TcType.SyntaxOpType also for commentary
1263 tcSyntaxOp
:: CtOrigin
1265 -> [SyntaxOpType
] -- ^ shape of syntax operator arguments
1266 -> ExpRhoType
-- ^ overall result type
1267 -> ([TcSigmaType
] -> TcM a
) -- ^ Type check any arguments
1268 -> TcM
(a
, SyntaxExpr TcId
)
1269 -- ^ Typecheck a syntax operator
1270 -- The operator is always a variable at this stage (i.e. renamer output)
1271 tcSyntaxOp orig expr arg_tys res_ty
1272 = tcSyntaxOpGen orig expr arg_tys
(SynType res_ty
)
1274 -- | Slightly more general version of 'tcSyntaxOp' that allows the caller
1275 -- to specify the shape of the result of the syntax operator
1276 tcSyntaxOpGen
:: CtOrigin
1280 -> ([TcSigmaType
] -> TcM a
)
1281 -> TcM
(a
, SyntaxExpr TcId
)
1282 tcSyntaxOpGen orig
(SyntaxExpr
{ syn_expr
= HsVar
(L _ op
) })
1283 arg_tys res_ty thing_inside
1284 = do { (expr
, sigma
) <- tcInferId op
1285 ; (result
, expr_wrap
, arg_wraps
, res_wrap
)
1286 <- tcSynArgA orig sigma arg_tys res_ty
$
1288 ; return (result
, SyntaxExpr
{ syn_expr
= mkHsWrap expr_wrap expr
1289 , syn_arg_wraps
= arg_wraps
1290 , syn_res_wrap
= res_wrap
}) }
1292 tcSyntaxOpGen _ other _ _ _
= pprPanic
"tcSyntaxOp" (ppr other
)
1297 Because of the rich structure of SyntaxOpType, we must do the
1298 contra-/covariant thing when working down arrows, to get the
1299 instantiation vs. skolemisation decisions correct (and, more
1300 obviously, the orientation of the HsWrappers). We thus have
1304 -- works on "expected" types, skolemising where necessary
1305 -- See Note [tcSynArg]
1306 tcSynArgE
:: CtOrigin
1308 -> SyntaxOpType
-- ^ shape it is expected to have
1309 -> ([TcSigmaType
] -> TcM a
) -- ^ check the arguments
1310 -> TcM
(a
, HsWrapper
)
1311 -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
1312 tcSynArgE orig sigma_ty syn_ty thing_inside
1313 = do { (skol_wrap
, (result
, ty_wrapper
))
1314 <- tcSkolemise GenSigCtxt sigma_ty
$ \ _ rho_ty
->
1316 ; return (result
, skol_wrap
<.> ty_wrapper
) }
1319 = do { result
<- thing_inside
[rho_ty
]
1320 ; return (result
, idHsWrapper
) }
1322 go rho_ty SynRho
-- same as SynAny, because we skolemise eagerly
1323 = do { result
<- thing_inside
[rho_ty
]
1324 ; return (result
, idHsWrapper
) }
1327 = do { (list_co
, elt_ty
) <- matchExpectedListTy rho_ty
1328 ; result
<- thing_inside
[elt_ty
]
1329 ; return (result
, mkWpCastN list_co
) }
1331 go rho_ty
(SynFun arg_shape res_shape
)
1332 = do { ( ( ( (result
, arg_ty
, res_ty
)
1333 , res_wrapper
) -- :: res_ty_out "->" res_ty
1334 , arg_wrapper1
, [], arg_wrapper2
) -- :: arg_ty "->" arg_ty_out
1335 , match_wrapper
) -- :: (arg_ty -> res_ty) "->" rho_ty
1336 <- matchExpectedFunTys herald
1 (mkCheckExpType rho_ty
) $
1337 \ [arg_ty
] res_ty
->
1338 do { arg_tc_ty
<- expTypeToType arg_ty
1339 ; res_tc_ty
<- expTypeToType res_ty
1341 -- another nested arrow is too much for now,
1342 -- but I bet we'll never need this
1343 ; MASSERT2
( case arg_shape
of
1346 , text
"Too many nested arrows in SyntaxOpType" $$
1349 ; tcSynArgA orig arg_tc_ty
[] arg_shape
$
1351 tcSynArgE orig res_tc_ty res_shape
$
1353 do { result
<- thing_inside
(arg_results
++ res_results
)
1354 ; return (result
, arg_tc_ty
, res_tc_ty
) }}
1358 mkWpFun
(arg_wrapper2
<.> arg_wrapper1
) res_wrapper
1361 herald
= text
"This rebindable syntax expects a function with"
1363 go rho_ty
(SynType the_ty
)
1364 = do { wrap
<- tcSubTypeET orig GenSigCtxt the_ty rho_ty
1365 ; result
<- thing_inside
[]
1366 ; return (result
, wrap
) }
1368 -- works on "actual" types, instantiating where necessary
1369 -- See Note [tcSynArg]
1370 tcSynArgA
:: CtOrigin
1372 -> [SyntaxOpType
] -- ^ argument shapes
1373 -> SyntaxOpType
-- ^ result shape
1374 -> ([TcSigmaType
] -> TcM a
) -- ^ check the arguments
1375 -> TcM
(a
, HsWrapper
, [HsWrapper
], HsWrapper
)
1376 -- ^ returns a wrapper to be applied to the original function,
1377 -- wrappers to be applied to arguments
1378 -- and a wrapper to be applied to the overall expression
1379 tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
1380 = do { (match_wrapper
, arg_tys
, res_ty
)
1381 <- matchActualFunTys herald orig noThing
(length arg_shapes
) sigma_ty
1382 -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
1383 ; ((result
, res_wrapper
), arg_wrappers
)
1384 <- tc_syn_args_e arg_tys arg_shapes
$ \ arg_results
->
1385 tc_syn_arg res_ty res_shape
$ \ res_results
->
1386 thing_inside
(arg_results
++ res_results
)
1387 ; return (result
, match_wrapper
, arg_wrappers
, res_wrapper
) }
1389 herald
= text
"This rebindable syntax expects a function with"
1391 tc_syn_args_e
:: [TcSigmaType
] -> [SyntaxOpType
]
1392 -> ([TcSigmaType
] -> TcM a
)
1393 -> TcM
(a
, [HsWrapper
])
1394 -- the wrappers are for arguments
1395 tc_syn_args_e
(arg_ty
: arg_tys
) (arg_shape
: arg_shapes
) thing_inside
1396 = do { ((result
, arg_wraps
), arg_wrap
)
1397 <- tcSynArgE orig arg_ty arg_shape
$ \ arg1_results
->
1398 tc_syn_args_e arg_tys arg_shapes
$ \ args_results
->
1399 thing_inside
(arg1_results
++ args_results
)
1400 ; return (result
, arg_wrap
: arg_wraps
) }
1401 tc_syn_args_e _ _ thing_inside
= (, []) <$> thing_inside
[]
1403 tc_syn_arg
:: TcSigmaType
-> SyntaxOpType
1404 -> ([TcSigmaType
] -> TcM a
)
1405 -> TcM
(a
, HsWrapper
)
1406 -- the wrapper applies to the overall result
1407 tc_syn_arg res_ty SynAny thing_inside
1408 = do { result
<- thing_inside
[res_ty
]
1409 ; return (result
, idHsWrapper
) }
1410 tc_syn_arg res_ty SynRho thing_inside
1411 = do { (inst_wrap
, rho_ty
) <- deeplyInstantiate orig res_ty
1412 -- inst_wrap :: res_ty "->" rho_ty
1413 ; result
<- thing_inside
[rho_ty
]
1414 ; return (result
, inst_wrap
) }
1415 tc_syn_arg res_ty SynList thing_inside
1416 = do { (inst_wrap
, rho_ty
) <- topInstantiate orig res_ty
1417 -- inst_wrap :: res_ty "->" rho_ty
1418 ; (list_co
, elt_ty
) <- matchExpectedListTy rho_ty
1419 -- list_co :: [elt_ty] ~N rho_ty
1420 ; result
<- thing_inside
[elt_ty
]
1421 ; return (result
, mkWpCastN
(mkTcSymCo list_co
) <.> inst_wrap
) }
1422 tc_syn_arg _
(SynFun
{}) _
1423 = pprPanic
"tcSynArgA hits a SynFun" (ppr orig
)
1424 tc_syn_arg res_ty
(SynType the_ty
) thing_inside
1425 = do { wrap
<- tcSubTypeO orig GenSigCtxt res_ty the_ty
1426 ; result
<- thing_inside
[]
1427 ; return (result
, wrap
) }
1430 Note [Push result type in]
1431 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1432 Unify with expected result before type-checking the args so that the
1433 info from res_ty percolates to args. This is when we might detect a
1434 too-few args situation. (One can think of cases when the opposite
1435 order would give a better error message.)
1436 experimenting with putting this first.
1438 Here's an example where it actually makes a real difference
1440 class C t a b | t a -> b
1441 instance C Char a Bool
1443 data P t a = forall b. (C t a b) => MkP b
1444 data Q t = MkQ (forall a. P t a)
1448 f2 = MkQ (MkP True :: forall a. P Char a)
1450 With the change, f1 will type-check, because the 'Char' info from
1451 the signature is propagated into MkQ's argument. With the check
1452 in the other order, the extra signature in f2 is reqd.
1454 ************************************************************************
1456 Expressions with a type signature
1459 ********************************************************************* -}
1461 tcExprSig
:: LHsExpr Name
-> TcIdSigInfo
-> TcM
(LHsExpr TcId
, TcType
)
1462 tcExprSig expr
(CompleteSig
{ sig_bndr
= poly_id
, sig_loc
= loc
})
1463 = setSrcSpan loc
$ -- Sets the location for the implication constraint
1464 do { (tv_prs
, theta
, tau
) <- tcInstType
(tcInstSigTyVars loc
) poly_id
1465 ; given
<- newEvVars theta
1466 ; let skol_info
= SigSkol ExprSigCtxt
(mkPhiTy theta tau
)
1467 skol_tvs
= map snd tv_prs
1468 ; (ev_binds
, expr
') <- checkConstraints skol_info skol_tvs given
$
1469 tcExtendTyVarEnv2 tv_prs
$
1470 tcPolyExprNC expr tau
1472 ; let poly_wrap
= mkWpTyLams skol_tvs
1474 <.> mkWpLet ev_binds
1475 ; return (mkLHsWrap poly_wrap expr
', idType poly_id
) }
1477 tcExprSig expr sig
@(PartialSig
{ psig_name
= name
, sig_loc
= loc
})
1478 = setSrcSpan loc
$ -- Sets the location for the implication constraint
1479 do { (tclvl
, wanted
, (expr
', sig_inst
))
1480 <- pushLevelAndCaptureConstraints
$
1481 do { sig_inst
<- tcInstSig sig
1482 ; expr
' <- tcExtendTyVarEnv2
(sig_inst_skols sig_inst
) $
1483 tcExtendTyVarEnv2
(sig_inst_wcs sig_inst
) $
1484 tcPolyExprNC expr
(sig_inst_tau sig_inst
)
1485 ; return (expr
', sig_inst
) }
1486 -- See Note [Partial expression signatures]
1487 ; let tau
= sig_inst_tau sig_inst
1488 infer_mode |
null (sig_inst_theta sig_inst
)
1489 , isNothing (sig_inst_wcx sig_inst
)
1493 ; (qtvs
, givens
, ev_binds
)
1494 <- simplifyInfer tclvl infer_mode
[sig_inst
] [(name
, tau
)] wanted
1495 ; tau
<- zonkTcType tau
1496 ; let inferred_theta
= map evVarPred givens
1497 tau_tvs
= tyCoVarsOfType tau
1498 ; (binders
, my_theta
) <- chooseInferredQuantifiers inferred_theta
1499 tau_tvs qtvs
(Just sig_inst
)
1500 ; let inferred_sigma
= mkInfSigmaTy qtvs inferred_theta tau
1501 my_sigma
= mkForAllTys binders
(mkPhiTy my_theta tau
)
1502 ; wrap
<- if inferred_sigma `eqType` my_sigma
-- NB: eqType ignores vis.
1503 then return idHsWrapper
-- Fast path; also avoids complaint when we infer
1504 -- an ambiguouse type and have AllowAmbiguousType
1505 -- e..g infer x :: forall a. F a -> Int
1506 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma
1508 ; traceTc
"tcExpSig" (ppr qtvs
$$ ppr givens
$$ ppr inferred_sigma
$$ ppr my_sigma
)
1509 ; let poly_wrap
= wrap
1512 <.> mkWpLet ev_binds
1513 ; return (mkLHsWrap poly_wrap expr
', my_sigma
) }
1516 {- Note [Partial expression signatures]
1517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1518 Partial type signatures on expressions are easy to get wrong. But
1519 here is a guiding principile
1526 So for partial signatures we apply the MR if no context is given. So
1527 e :: IO _ apply the MR
1528 e :: _ => IO _ do not apply the MR
1529 just like in TcBinds.decideGeneralisationPlan
1531 This makes a difference (Trac #11670):
1532 peek :: Ptr a -> IO CLong
1533 peek ptr = peekElemOff undefined 0 :: _
1534 from (peekElemOff undefined 0) we get
1536 constraints: Storable w
1538 We must NOT try to generalise over 'w' because the signature specifies
1539 no constraints so we'll complain about not being able to solve
1540 Storable w. Instead, don't generalise; then _ gets instantiated to
1541 CLong, as it should.
1544 {- *********************************************************************
1548 ********************************************************************* -}
1550 tcCheckId
:: Name
-> ExpRhoType
-> TcM
(HsExpr TcId
)
1551 tcCheckId name res_ty
1552 = do { (expr
, actual_res_ty
) <- tcInferId name
1553 ; traceTc
"tcCheckId" (vcat
[ppr name
, ppr actual_res_ty
, ppr res_ty
])
1554 ; addFunResCtxt
False (HsVar
(noLoc name
)) actual_res_ty res_ty
$
1555 tcWrapResultO
(OccurrenceOf name
) expr actual_res_ty res_ty
}
1557 tcCheckRecSelId
:: AmbiguousFieldOcc Name
-> ExpRhoType
-> TcM
(HsExpr TcId
)
1558 tcCheckRecSelId f
@(Unambiguous
(L _ lbl
) _
) res_ty
1559 = do { (expr
, actual_res_ty
) <- tcInferRecSelId f
1560 ; addFunResCtxt
False (HsRecFld f
) actual_res_ty res_ty
$
1561 tcWrapResultO
(OccurrenceOfRecSel lbl
) expr actual_res_ty res_ty
}
1562 tcCheckRecSelId
(Ambiguous lbl _
) res_ty
1563 = case tcSplitFunTy_maybe
=<< checkingExpType_maybe res_ty
of
1564 Nothing
-> ambiguousSelector lbl
1565 Just
(arg
, _
) -> do { sel_name
<- disambiguateSelector lbl arg
1566 ; tcCheckRecSelId
(Unambiguous lbl sel_name
) res_ty
}
1568 ------------------------
1569 tcInferRecSelId
:: AmbiguousFieldOcc Name
-> TcM
(HsExpr TcId
, TcRhoType
)
1570 tcInferRecSelId
(Unambiguous
(L _ lbl
) sel
)
1571 = do { (expr
', ty
) <- tc_infer_id lbl sel
1572 ; return (expr
', ty
) }
1573 tcInferRecSelId
(Ambiguous lbl _
)
1574 = ambiguousSelector lbl
1576 ------------------------
1577 tcInferId
:: Name
-> TcM
(HsExpr TcId
, TcSigmaType
)
1578 -- Look up an occurrence of an Id
1579 -- Do not instantiate its type
1581 | id_name `hasKey` tagToEnumKey
1582 = failWithTc
(text
"tagToEnum# must appear applied to one argument")
1583 -- tcApp catches the case (tagToEnum# arg)
1585 | id_name `hasKey` assertIdKey
1586 = do { dflags
<- getDynFlags
1587 ; if gopt Opt_IgnoreAsserts dflags
1588 then tc_infer_id
(nameRdrName id_name
) id_name
1589 else tc_infer_assert id_name
}
1592 = do { (expr
, ty
) <- tc_infer_id
(nameRdrName id_name
) id_name
1593 ; traceTc
"tcInferId" (ppr id_name
<+> dcolon
<+> ppr ty
)
1594 ; return (expr
, ty
) }
1596 tc_infer_assert
:: Name
-> TcM
(HsExpr TcId
, TcSigmaType
)
1597 -- Deal with an occurrence of 'assert'
1598 -- See Note [Adding the implicit parameter to 'assert']
1599 tc_infer_assert assert_name
1600 = do { assert_error_id
<- tcLookupId assertErrorName
1601 ; (wrap
, id_rho
) <- topInstantiate
(OccurrenceOf assert_name
)
1602 (idType assert_error_id
)
1603 ; return (mkHsWrap wrap
(HsVar
(noLoc assert_error_id
)), id_rho
)
1606 tc_infer_id
:: RdrName
-> Name
-> TcM
(HsExpr TcId
, TcSigmaType
)
1607 tc_infer_id lbl id_name
1608 = do { thing
<- tcLookup id_name
1610 ATcId
{ tct_id
= id }
1611 -> do { check_naughty
id -- Note [Local record selectors]
1616 -> do { check_naughty
id
1618 -- A global cannot possibly be ill-staged
1619 -- nor does it need the 'lifting' treatment
1620 -- hence no checkTh stuff here
1622 AGlobal
(AConLike cl
) -> case cl
of
1623 RealDataCon con
-> return_data_con con
1624 PatSynCon ps
-> tcPatSynBuilderOcc ps
1627 ppr thing
<+> text
"used where a value identifier was expected" }
1629 return_id
id = return (HsVar
(noLoc
id), idType
id)
1632 -- For data constructors, must perform the stupid-theta check
1634 = return_id con_wrapper_id
1637 -- See Note [Instantiating stupid theta]
1638 = do { let (tvs
, theta
, rho
) = tcSplitSigmaTy
(idType con_wrapper_id
)
1639 ; (subst
, tvs
') <- newMetaTyVars tvs
1640 ; let tys
' = mkTyVarTys tvs
'
1641 theta
' = substTheta subst theta
1642 rho
' = substTy subst rho
1643 ; wrap
<- instCall
(OccurrenceOf id_name
) tys
' theta
'
1644 ; addDataConStupidTheta con tys
'
1645 ; return (mkHsWrap wrap
(HsVar
(noLoc con_wrapper_id
)), rho
') }
1648 con_wrapper_id
= dataConWrapId con
1649 stupid_theta
= dataConStupidTheta con
1652 | isNaughtyRecordSelector
id = failWithTc
(naughtyRecordSel lbl
)
1653 |
otherwise = return ()
1656 tcUnboundId
:: UnboundVar
-> ExpRhoType
-> TcM
(HsExpr TcId
)
1657 -- Typecheck an occurrence of an unbound Id
1659 -- Some of these started life as a true expression hole "_".
1660 -- Others might simply be variables that accidentally have no binding site
1662 -- We turn all of them into HsVar, since HsUnboundVar can't contain an
1663 -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
1664 -- not unbound any more!
1665 tcUnboundId unbound res_ty
1666 = do { ty
<- newOpenFlexiTyVarTy
-- Allow Int# etc (Trac #12531)
1667 ; let occ
= unboundVarOcc unbound
1668 ; name
<- newSysName occ
1669 ; let ev
= mkLocalId name ty
1670 ; loc
<- getCtLocM HoleOrigin Nothing
1671 ; let can
= CHoleCan
{ cc_ev
= CtWanted
{ ctev_pred
= ty
1672 , ctev_dest
= EvVarDest ev
1673 , ctev_nosh
= WDeriv
1675 , cc_hole
= ExprHole unbound
}
1677 ; tcWrapResultO
(UnboundOccurrenceOf occ
) (HsVar
(noLoc ev
)) ty res_ty
}
1681 Note [Adding the implicit parameter to 'assert']
1682 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1683 The typechecker transforms (assert e1 e2) to (assertError e1 e2).
1684 This isn't really the Right Thing because there's no way to "undo"
1685 if you want to see the original source code in the typechecker
1686 output. We'll have fix this in due course, when we care more about
1687 being able to reconstruct the exact original program.
1691 Nasty check to ensure that tagToEnum# is applied to a type that is an
1692 enumeration TyCon. Unification may refine the type later, but this
1693 check won't see that, alas. It's crude, because it relies on our
1694 knowing *now* that the type is ok, which in turn relies on the
1695 eager-unification part of the type checker pushing enough information
1696 here. In theory the Right Thing to do is to have a new form of
1697 constraint but I definitely cannot face that! And it works ok as-is.
1699 Here's are two cases that should fail
1701 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1704 g = tagToEnum# 0 -- Int is not an enumeration
1706 When data type families are involved it's a bit more complicated.
1708 data instance F [Int] = A | B | C
1709 Then we want to generate something like
1710 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1711 Usually that coercion is hidden inside the wrappers for
1712 constructors of F [Int] but here we have to do it explicitly.
1714 It's all grotesquely complicated.
1716 Note [Instantiating stupid theta]
1717 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1718 Normally, when we infer the type of an Id, we don't instantiate,
1719 because we wish to allow for visible type application later on.
1720 But if a datacon has a stupid theta, we're a bit stuck. We need
1721 to emit the stupid theta constraints with instantiated types. It's
1722 difficult to defer this to the lazy instantiation, because a stupid
1723 theta has no spot to put it in a type. So we just instantiate eagerly
1724 in this case. Thus, users cannot use visible type application with
1725 a data constructor sporting a stupid theta. I won't feel so bad for
1726 the users that complain.
1730 tcSeq
:: SrcSpan
-> Name
-> [LHsExprArgIn
]
1731 -> ExpRhoType
-> TcM
(HsWrapper
, LHsExpr TcId
, [LHsExprArgOut
])
1732 -- (seq e1 e2) :: res_ty
1733 -- We need a special typing rule because res_ty can be unboxed
1734 -- See Note [Typing rule for seq]
1735 tcSeq loc fun_name args res_ty
1736 = do { fun
<- tcLookupId fun_name
1737 ; (arg1_ty
, args1
) <- case args
of
1738 (Right hs_ty_arg1
: args1
)
1739 -> do { ty_arg1
<- tcHsTypeApp hs_ty_arg1 liftedTypeKind
1740 ; return (ty_arg1
, args1
) }
1742 _
-> do { arg_ty1
<- newFlexiTyVarTy liftedTypeKind
1743 ; return (arg_ty1
, args
) }
1745 ; (arg1
, arg2
, arg2_exp_ty
) <- case args1
of
1746 [Right hs_ty_arg2
, Left term_arg1
, Left term_arg2
]
1747 -> do { arg2_kind
<- newOpenTypeKind
1748 ; ty_arg2
<- tcHsTypeApp hs_ty_arg2 arg2_kind
1749 -- see Note [Typing rule for seq]
1750 ; _
<- tcSubTypeDS
(OccurrenceOf fun_name
) GenSigCtxt ty_arg2 res_ty
1751 ; return (term_arg1
, term_arg2
, mkCheckExpType ty_arg2
) }
1752 [Left term_arg1
, Left term_arg2
]
1753 -> return (term_arg1
, term_arg2
, res_ty
)
1754 _
-> too_many_args
"seq" args
1756 ; arg1
' <- tcMonoExpr arg1
(mkCheckExpType arg1_ty
)
1757 ; arg2
' <- tcMonoExpr arg2 arg2_exp_ty
1758 ; res_ty
<- readExpType res_ty
-- by now, it's surely filled in
1759 ; let fun
' = L loc
(HsWrap ty_args
(HsVar
(L loc fun
)))
1760 ty_args
= WpTyApp res_ty
<.> WpTyApp arg1_ty
1761 ; return (idHsWrapper
, fun
', [Left arg1
', Left arg2
']) }
1763 tcTagToEnum
:: SrcSpan
-> Name
-> [LHsExprArgIn
] -> ExpRhoType
1764 -> TcM
(HsWrapper
, LHsExpr TcId
, [LHsExprArgOut
])
1765 -- tagToEnum# :: forall a. Int# -> a
1766 -- See Note [tagToEnum#] Urgh!
1767 tcTagToEnum loc fun_name args res_ty
1768 = do { fun
<- tcLookupId fun_name
1770 ; arg
<- case args
of
1771 [Right hs_ty_arg
, Left term_arg
]
1772 -> do { ty_arg
<- tcHsTypeApp hs_ty_arg liftedTypeKind
1773 ; _
<- tcSubTypeDS
(OccurrenceOf fun_name
) GenSigCtxt ty_arg res_ty
1774 -- other than influencing res_ty, we just
1775 -- don't care about a type arg passed in.
1776 -- So drop the evidence.
1778 [Left term_arg
] -> do { _
<- expTypeToType res_ty
1780 _
-> too_many_args
"tagToEnum#" args
1782 ; res_ty
<- readExpType res_ty
1783 ; ty
' <- zonkTcType res_ty
1785 -- Check that the type is algebraic
1786 ; let mb_tc_app
= tcSplitTyConApp_maybe ty
'
1787 Just
(tc
, tc_args
) = mb_tc_app
1788 ; checkTc
(isJust mb_tc_app
)
1791 -- Look through any type family
1792 ; fam_envs
<- tcGetFamInstEnvs
1793 ; let (rep_tc
, rep_args
, coi
)
1794 = tcLookupDataFamInst fam_envs tc tc_args
1795 -- coi :: tc tc_args ~R rep_tc rep_args
1797 ; checkTc
(isEnumerationTyCon rep_tc
)
1800 ; arg
' <- tcMonoExpr arg
(mkCheckExpType intPrimTy
)
1801 ; let fun
' = L loc
(HsWrap
(WpTyApp rep_ty
) (HsVar
(L loc fun
)))
1802 rep_ty
= mkTyConApp rep_tc rep_args
1804 ; return (mkWpCastR
(mkTcSymCo coi
), fun
', [Left arg
']) }
1805 -- coi is a Representational coercion
1807 doc1
= vcat
[ text
"Specify the type by giving a type signature"
1808 , text
"e.g. (tagToEnum# x) :: Bool" ]
1809 doc2
= text
"Result type must be an enumeration type"
1811 mk_error
:: TcType
-> SDoc
-> SDoc
1813 = hang
(text
"Bad call to tagToEnum#"
1814 <+> text
"at type" <+> ppr ty
)
1817 too_many_args
:: String -> [LHsExprArgIn
] -> TcM a
1818 too_many_args fun args
1820 hang
(text
"Too many type arguments to" <+> text fun
<> colon
)
1821 2 (sep
(map pp args
))
1823 pp
(Left e
) = pprParendLExpr e
1824 pp
(Right
(HsWC
{ hswc_body
= L _ t
})) = pprParendHsType t
1828 ************************************************************************
1830 Template Haskell checks
1832 ************************************************************************
1835 checkThLocalId
:: Id
-> TcM
()
1837 = do { mb_local_use
<- getStageAndBindLevel
(idName
id)
1838 ; case mb_local_use
of
1839 Just
(top_lvl
, bind_lvl
, use_stage
)
1840 | thLevel use_stage
> bind_lvl
1841 , isNotTopLevel top_lvl
1842 -> checkCrossStageLifting
id use_stage
1843 _
-> return () -- Not a locally-bound thing, or
1844 -- no cross-stage link
1847 --------------------------------------
1848 checkCrossStageLifting
:: Id
-> ThStage
-> TcM
()
1849 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
1850 -- we must check whether there's a cross-stage lift to do
1851 -- Examples \x -> [|| x ||]
1853 -- There is no error-checking to do, because the renamer did that
1855 -- This is similar to checkCrossStageLifting in RnSplice, but
1856 -- this code is applied to *typed* brackets.
1858 checkCrossStageLifting
id (Brack _
(TcPending ps_var lie_var
))
1859 = -- Nested identifiers, such as 'x' in
1860 -- E.g. \x -> [|| h x ||]
1861 -- We must behave as if the reference to x was
1863 -- We use 'x' itself as the splice proxy, used by
1864 -- the desugarer to stitch it all back together.
1865 -- If 'x' occurs many times we may get many identical
1866 -- bindings of the same splice proxy, but that doesn't
1867 -- matter, although it's a mite untidy.
1868 do { let id_ty
= idType
id
1869 ; checkTc
(isTauTy id_ty
) (polySpliceErr
id)
1870 -- If x is polymorphic, its occurrence sites might
1871 -- have different instantiations, so we can't use plain
1872 -- 'x' as the splice proxy name. I don't know how to
1873 -- solve this, and it's probably unimportant, so I'm
1874 -- just going to flag an error for now
1876 ; lift
<- if isStringTy id_ty
then
1877 do { sid
<- tcLookupId THNames
.liftStringName
1878 -- See Note [Lifting strings]
1879 ; return (HsVar
(noLoc sid
)) }
1881 setConstraintVar lie_var
$
1882 -- Put the 'lift' constraint into the right LIE
1883 newMethodFromName
(OccurrenceOf
(idName
id))
1884 THNames
.liftName id_ty
1886 -- Update the pending splices
1887 ; ps
<- readMutVar ps_var
1888 ; let pending_splice
= PendingTcSplice
(idName
id) (nlHsApp
(noLoc lift
) (nlHsVar
id))
1889 ; writeMutVar ps_var
(pending_splice
: ps
)
1893 checkCrossStageLifting _ _
= return ()
1895 polySpliceErr
:: Id
-> SDoc
1897 = text
"Can't splice the polymorphic local variable" <+> quotes
(ppr
id)
1900 Note [Lifting strings]
1901 ~~~~~~~~~~~~~~~~~~~~~~
1902 If we see $(... [| s |] ...) where s::String, we don't want to
1903 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1904 So this conditional short-circuits the lifting mechanism to generate
1905 (liftString "xy") in that case. I didn't want to use overlapping instances
1906 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1907 errors in a polymorphic situation.
1909 If this check fails (which isn't impossible) we get another chance; see
1910 Note [Converting strings] in Convert.hs
1912 Local record selectors
1913 ~~~~~~~~~~~~~~~~~~~~~~
1914 Record selectors for TyCons in this module are ordinary local bindings,
1915 which show up as ATcIds rather than AGlobals. So we need to check for
1916 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1919 ************************************************************************
1921 \subsection{Record bindings}
1923 ************************************************************************
1926 getFixedTyVars
:: [FieldLabelString
] -> [TyVar
] -> [ConLike
] -> TyVarSet
1927 -- These tyvars must not change across the updates
1928 getFixedTyVars upd_fld_occs univ_tvs cons
1929 = mkVarSet
[tv1 | con
<- cons
1930 , let (u_tvs
, _
, eqspec
, prov_theta
1931 , req_theta
, arg_tys
, _
)
1932 = conLikeFullSig con
1933 theta
= eqSpecPreds eqspec
1936 flds
= conLikeFieldLabels con
1937 fixed_tvs
= exactTyCoVarsOfTypes fixed_tys
1938 -- fixed_tys: See Note [Type of a record update]
1939 `unionVarSet` tyCoVarsOfTypes theta
1940 -- Universally-quantified tyvars that
1941 -- appear in any of the *implicit*
1942 -- arguments to the constructor are fixed
1943 -- See Note [Implicit type sharing]
1945 fixed_tys
= [ty |
(fl
, ty
) <- zip flds arg_tys
1946 , not (flLabel fl `
elem` upd_fld_occs
)]
1947 , (tv1
,tv
) <- univ_tvs `
zip` u_tvs
1948 , tv `elemVarSet` fixed_tvs
]
1951 Note [Disambiguating record fields]
1952 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1953 When the -XDuplicateRecordFields extension is used, and the renamer
1954 encounters a record selector or update that it cannot immediately
1955 disambiguate (because it involves fields that belong to multiple
1956 datatypes), it will defer resolution of the ambiguity to the
1957 typechecker. In this case, the `Ambiguous` constructor of
1958 `AmbiguousFieldOcc` is used.
1960 Consider the following definitions:
1962 data S = MkS { foo :: Int }
1963 data T = MkT { foo :: Int, bar :: Int }
1964 data U = MkU { bar :: Int, baz :: Int }
1966 When the renamer sees `foo` as a selector or an update, it will not
1967 know which parent datatype is in use.
1969 For selectors, there are two possible ways to disambiguate:
1971 1. Check if the pushed-in type is a function whose domain is a
1972 datatype, for example:
1974 f s = (foo :: S -> Int) s
1979 This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.
1981 2. Check if the selector is applied to an argument that has a type
1982 signature, for example:
1986 This is checked by `tcApp`.
1989 Updates are slightly more complex. The `disambiguateRecordBinds`
1990 function tries to determine the parent datatype in three ways:
1992 1. Check for types that have all the fields being updated. For example:
1994 f x = x { foo = 3, bar = 2 }
1996 Here `f` must be updating `T` because neither `S` nor `U` have
1997 both fields. This may also discover that no possible type exists.
1998 For example the following will be rejected:
2000 f' x = x { foo = 3, baz = 3 }
2002 2. Use the type being pushed in, if it is already a TyConApp. The
2003 following are valid updates to `T`:
2008 g' x = x { foo = 3 } :: T
2010 3. Use the type signature of the record expression, if it exists and
2011 is a TyConApp. Thus this is valid update to `T`:
2013 h x = (x :: T) { foo = 3 }
2016 Note that we do not look up the types of variables being updated, and
2017 no constraint-solving is performed, so for example the following will
2018 be rejected as ambiguous:
2020 let bad (s :: S) = foo s
2026 \r. (r { foo = 3 }, r :: T )
2028 We could add further tests, of a more heuristic nature. For example,
2029 rather than looking for an explicit signature, we could try to infer
2030 the type of the argument to a selector or the record expression being
2031 updated, in case we are lucky enough to get a TyConApp straight
2032 away. However, it might be hard for programmers to predict whether a
2033 particular update is sufficiently obvious for the signature to be
2034 omitted. Moreover, this might change the behaviour of typechecker in
2037 See also Note [HsRecField and HsRecUpdField] in HsPat.
2040 -- Given a RdrName that refers to multiple record fields, and the type
2041 -- of its argument, try to determine the name of the selector that is
2043 disambiguateSelector
:: Located RdrName
-> Type
-> TcM Name
2044 disambiguateSelector lr
@(L _ rdr
) parent_type
2045 = do { fam_inst_envs
<- tcGetFamInstEnvs
2046 ; case tyConOf fam_inst_envs parent_type
of
2047 Nothing
-> ambiguousSelector lr
2049 do { xs
<- lookupParents rdr
2050 ; let parent
= RecSelData p
2051 ; case lookup parent xs
of
2052 Just gre
-> do { addUsedGRE
True gre
2053 ; return (gre_name gre
) }
2054 Nothing
-> failWithTc
(fieldNotInType parent rdr
) } }
2056 -- This field name really is ambiguous, so add a suitable "ambiguous
2057 -- occurrence" error, then give up.
2058 ambiguousSelector
:: Located RdrName
-> TcM a
2059 ambiguousSelector
(L _ rdr
)
2060 = do { env
<- getGlobalRdrEnv
2061 ; let gres
= lookupGRE_RdrName rdr env
2062 ; setErrCtxt
[] $ addNameClashErrRn rdr gres
2065 -- Disambiguate the fields in a record update.
2066 -- See Note [Disambiguating record fields]
2067 disambiguateRecordBinds
:: LHsExpr Name
-> TcRhoType
2068 -> [LHsRecUpdField Name
] -> ExpRhoType
2069 -> TcM
[LHsRecField
' (AmbiguousFieldOcc Id
) (LHsExpr Name
)]
2070 disambiguateRecordBinds record_expr record_rho rbnds res_ty
2071 -- Are all the fields unambiguous?
2072 = case mapM isUnambiguous rbnds
of
2073 -- If so, just skip to looking up the Ids
2074 -- Always the case if DuplicateRecordFields is off
2075 Just rbnds
' -> mapM lookupSelector rbnds
'
2076 Nothing
-> -- If not, try to identify a single parent
2077 do { fam_inst_envs
<- tcGetFamInstEnvs
2078 -- Look up the possible parents for each field
2079 ; rbnds_with_parents
<- getUpdFieldsParents
2080 ; let possible_parents
= map (map fst . snd) rbnds_with_parents
2081 -- Identify a single parent
2082 ; p
<- identifyParent fam_inst_envs possible_parents
2083 -- Pick the right selector with that parent for each field
2084 ; checkNoErrs
$ mapM (pickParent p
) rbnds_with_parents
}
2086 -- Extract the selector name of a field update if it is unambiguous
2087 isUnambiguous
:: LHsRecUpdField Name
-> Maybe (LHsRecUpdField Name
, Name
)
2088 isUnambiguous x
= case unLoc
(hsRecFieldLbl
(unLoc x
)) of
2089 Unambiguous _ sel_name
-> Just
(x
, sel_name
)
2090 Ambiguous
{} -> Nothing
2092 -- Look up the possible parents and selector GREs for each field
2093 getUpdFieldsParents
:: TcM
[(LHsRecUpdField Name
2094 , [(RecSelParent
, GlobalRdrElt
)])]
2096 = fmap (zip rbnds
) $ mapM
2097 (lookupParents
. unLoc
. hsRecUpdFieldRdr
. unLoc
)
2100 -- Given a the lists of possible parents for each field,
2101 -- identify a single parent
2102 identifyParent
:: FamInstEnvs
-> [[RecSelParent
]] -> TcM RecSelParent
2103 identifyParent fam_inst_envs possible_parents
2104 = case foldr1 intersect possible_parents
of
2105 -- No parents for all fields: record update is ill-typed
2106 [] -> failWithTc
(noPossibleParents rbnds
)
2108 -- Exactly one datatype with all the fields: use that
2111 -- Multiple possible parents: try harder to disambiguate
2112 -- Can we get a parent TyCon from the pushed-in type?
2113 _
:_ | Just p
<- tyConOfET fam_inst_envs res_ty
-> return (RecSelData p
)
2115 -- Does the expression being updated have a type signature?
2116 -- If so, try to extract a parent TyCon from it
2117 | Just
{} <- obviousSig
(unLoc record_expr
)
2118 , Just tc
<- tyConOf fam_inst_envs record_rho
2119 -> return (RecSelData tc
)
2121 -- Nothing else we can try...
2122 _
-> failWithTc badOverloadedUpdate
2124 -- Make a field unambiguous by choosing the given parent.
2125 -- Emits an error if the field cannot have that parent,
2126 -- e.g. if the user writes
2128 -- where T does not have field x.
2129 pickParent
:: RecSelParent
2130 -> (LHsRecUpdField Name
, [(RecSelParent
, GlobalRdrElt
)])
2131 -> TcM
(LHsRecField
' (AmbiguousFieldOcc Id
) (LHsExpr Name
))
2132 pickParent p
(upd
, xs
)
2133 = case lookup p xs
of
2134 -- Phew! The parent is valid for this field.
2135 -- Previously ambiguous fields must be marked as
2136 -- used now that we know which one is meant, but
2137 -- unambiguous ones shouldn't be recorded again
2138 -- (giving duplicate deprecation warnings).
2139 Just gre
-> do { unless (null (tail xs
)) $ do
2140 let L loc _
= hsRecFieldLbl
(unLoc upd
)
2141 setSrcSpan loc
$ addUsedGRE
True gre
2142 ; lookupSelector
(upd
, gre_name gre
) }
2143 -- The field doesn't belong to this parent, so report
2144 -- an error but keep going through all the fields
2145 Nothing
-> do { addErrTc
(fieldNotInType p
2146 (unLoc
(hsRecUpdFieldRdr
(unLoc upd
))))
2147 ; lookupSelector
(upd
, gre_name
(snd (head xs
))) }
2149 -- Given a (field update, selector name) pair, look up the
2150 -- selector to give a field update with an unambiguous Id
2151 lookupSelector
:: (LHsRecUpdField Name
, Name
)
2152 -> TcM
(LHsRecField
' (AmbiguousFieldOcc Id
) (LHsExpr Name
))
2153 lookupSelector
(L l upd
, n
)
2154 = do { i
<- tcLookupId n
2155 ; let L loc af
= hsRecFieldLbl upd
2156 lbl
= rdrNameAmbiguousFieldOcc af
2157 ; return $ L l upd
{ hsRecFieldLbl
2158 = L loc
(Unambiguous
(L loc lbl
) i
) } }
2161 -- Extract the outermost TyCon of a type, if there is one; for
2162 -- data families this is the representation tycon (because that's
2163 -- where the fields live).
2164 tyConOf
:: FamInstEnvs
-> TcSigmaType
-> Maybe TyCon
2165 tyConOf fam_inst_envs ty0
2166 = case tcSplitTyConApp_maybe ty
of
2167 Just
(tc
, tys
) -> Just
(fstOf3
(tcLookupDataFamInst fam_inst_envs tc tys
))
2170 (_
, _
, ty
) = tcSplitSigmaTy ty0
2172 -- Variant of tyConOf that works for ExpTypes
2173 tyConOfET
:: FamInstEnvs
-> ExpRhoType
-> Maybe TyCon
2174 tyConOfET fam_inst_envs ty0
= tyConOf fam_inst_envs
=<< checkingExpType_maybe ty0
2176 -- For an ambiguous record field, find all the candidate record
2177 -- selectors (as GlobalRdrElts) and their parents.
2178 lookupParents
:: RdrName
-> RnM
[(RecSelParent
, GlobalRdrElt
)]
2180 = do { env
<- getGlobalRdrEnv
2181 ; let gres
= lookupGRE_RdrName rdr env
2182 ; mapM lookupParent gres
}
2184 lookupParent
:: GlobalRdrElt
-> RnM
(RecSelParent
, GlobalRdrElt
)
2185 lookupParent gre
= do { id <- tcLookupId
(gre_name gre
)
2186 ; if isRecordSelector
id
2187 then return (recordSelectorTyCon
id, gre
)
2188 else failWithTc
(notSelector
(gre_name gre
)) }
2190 -- A type signature on the argument of an ambiguous record selector or
2191 -- the record expression in an update must be "obvious", i.e. the
2192 -- outermost constructor ignoring parentheses.
2193 obviousSig
:: HsExpr Name
-> Maybe (LHsSigWcType Name
)
2194 obviousSig
(ExprWithTySig _ ty
) = Just ty
2195 obviousSig
(HsPar p
) = obviousSig
(unLoc p
)
2196 obviousSig _
= Nothing
2200 Game plan for record bindings
2201 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2202 1. Find the TyCon for the bindings, from the first field label.
2204 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
2206 For each binding field = value
2208 3. Instantiate the field type (from the field label) using the type
2211 4 Type check the value using tcArg, passing the field type as
2212 the expected argument type.
2214 This extends OK when the field types are universally quantified.
2219 -> [TcType
] -- Expected type for each field
2220 -> HsRecordBinds Name
2221 -> TcM
(HsRecordBinds TcId
)
2223 tcRecordBinds con_like arg_tys
(HsRecFields rbinds dd
)
2224 = do { mb_binds
<- mapM do_bind rbinds
2225 ; return (HsRecFields
(catMaybes mb_binds
) dd
) }
2227 fields
= map flLabel
$ conLikeFieldLabels con_like
2228 flds_w_tys
= zipEqual
"tcRecordBinds" fields arg_tys
2230 do_bind
:: LHsRecField Name
(LHsExpr Name
)
2231 -> TcM
(Maybe (LHsRecField TcId
(LHsExpr TcId
)))
2232 do_bind
(L l fld
@(HsRecField
{ hsRecFieldLbl
= f
2233 , hsRecFieldArg
= rhs
}))
2235 = do { mb
<- tcRecordField con_like flds_w_tys f rhs
2237 Nothing
-> return Nothing
2238 Just
(f
', rhs
') -> return (Just
(L l
(fld
{ hsRecFieldLbl
= f
'
2239 , hsRecFieldArg
= rhs
' }))) }
2243 -> [TcType
] -- Expected type for each field
2244 -> [LHsRecField
' (AmbiguousFieldOcc Id
) (LHsExpr Name
)]
2245 -> TcM
[LHsRecUpdField TcId
]
2247 tcRecordUpd con_like arg_tys rbinds
= fmap catMaybes $ mapM do_bind rbinds
2249 flds_w_tys
= zipEqual
"tcRecordUpd" (map flLabel
$ conLikeFieldLabels con_like
) arg_tys
2251 do_bind
:: LHsRecField
' (AmbiguousFieldOcc Id
) (LHsExpr Name
) -> TcM
(Maybe (LHsRecUpdField TcId
))
2252 do_bind
(L l fld
@(HsRecField
{ hsRecFieldLbl
= L loc af
2253 , hsRecFieldArg
= rhs
}))
2254 = do { let lbl
= rdrNameAmbiguousFieldOcc af
2255 sel_id
= selectorAmbiguousFieldOcc af
2256 f
= L loc
(FieldOcc
(L loc lbl
) (idName sel_id
))
2257 ; mb
<- tcRecordField con_like flds_w_tys f rhs
2259 Nothing
-> return Nothing
2262 (L l
(fld
{ hsRecFieldLbl
2263 = L loc
(Unambiguous
(L loc lbl
)
2264 (selectorFieldOcc
(unLoc f
')))
2265 , hsRecFieldArg
= rhs
' }))) }
2267 tcRecordField
:: ConLike
-> Assoc FieldLabelString Type
-> LFieldOcc Name
-> LHsExpr Name
2268 -> TcM
(Maybe (LFieldOcc Id
, LHsExpr Id
))
2269 tcRecordField con_like flds_w_tys
(L loc
(FieldOcc lbl sel_name
)) rhs
2270 | Just field_ty
<- assocMaybe flds_w_tys field_lbl
2271 = addErrCtxt
(fieldCtxt field_lbl
) $
2272 do { rhs
' <- tcPolyExprNC rhs field_ty
2273 ; let field_id
= mkUserLocal
(nameOccName sel_name
)
2274 (nameUnique sel_name
)
2276 -- Yuk: the field_id has the *unique* of the selector Id
2277 -- (so we can find it easily)
2278 -- but is a LocalId with the appropriate type of the RHS
2279 -- (so the desugarer knows the type of local binder to make)
2280 ; return (Just
(L loc
(FieldOcc lbl field_id
), rhs
')) }
2282 = do { addErrTc
(badFieldCon con_like field_lbl
)
2285 field_lbl
= occNameFS
$ rdrNameOcc
(unLoc lbl
)
2288 checkMissingFields
:: ConLike
-> HsRecordBinds Name
-> TcM
()
2289 checkMissingFields con_like rbinds
2290 |
null field_labels
-- Not declared as a record;
2291 -- But C{} is still valid if no strict fields
2292 = if any isBanged field_strs
then
2293 -- Illegal if any arg is strict
2294 addErrTc
(missingStrictFields con_like
[])
2298 |
otherwise = do -- A record
2299 unless (null missing_s_fields
)
2300 (addErrTc
(missingStrictFields con_like missing_s_fields
))
2302 warn
<- woptM Opt_WarnMissingFields
2303 unless (not (warn
&& notNull missing_ns_fields
))
2304 (warnTc
(Reason Opt_WarnMissingFields
) True
2305 (missingFields con_like missing_ns_fields
))
2309 = [ flLabel fl |
(fl
, str
) <- field_info
,
2311 not (fl `elemField` field_names_used
)
2314 = [ flLabel fl |
(fl
, str
) <- field_info
,
2316 not (fl `elemField` field_names_used
)
2319 field_names_used
= hsRecFields rbinds
2320 field_labels
= conLikeFieldLabels con_like
2322 field_info
= zipEqual
"missingFields"
2326 field_strs
= conLikeImplBangs con_like
2328 fl `elemField` flds
= any (\ fl
' -> flSelector fl
== fl
') flds
2331 ************************************************************************
2333 \subsection{Errors and contexts}
2335 ************************************************************************
2337 Boring and alphabetical:
2340 addExprErrCtxt
:: LHsExpr Name
-> TcM a
-> TcM a
2341 addExprErrCtxt expr
= addErrCtxt
(exprCtxt expr
)
2343 exprCtxt
:: LHsExpr Name
-> SDoc
2345 = hang
(text
"In the expression:") 2 (ppr expr
)
2347 fieldCtxt
:: FieldLabelString
-> SDoc
2348 fieldCtxt field_name
2349 = text
"In the" <+> quotes
(ppr field_name
) <+> ptext
(sLit
"field of a record")
2351 addFunResCtxt
:: Bool -- There is at least one argument
2352 -> HsExpr Name
-> TcType
-> ExpRhoType
2354 -- When we have a mis-match in the return type of a function
2355 -- try to give a helpful message about too many/few arguments
2357 -- Used for naked variables too; but with has_args = False
2358 addFunResCtxt has_args fun fun_res_ty env_ty
2359 = addLandmarkErrCtxtM
(\env
-> (env
, ) <$> mk_msg
)
2360 -- NB: use a landmark error context, so that an empty context
2361 -- doesn't suppress some more useful context
2364 = do { mb_env_ty
<- readExpType_maybe env_ty
2365 -- by the time the message is rendered, the ExpType
2366 -- will be filled in (except if we're debugging)
2367 ; fun_res
' <- zonkTcType fun_res_ty
2368 ; env
' <- case mb_env_ty
of
2369 Just env_ty
-> zonkTcType env_ty
2371 do { dumping
<- doptM Opt_D_dump_tc_trace
2372 ; MASSERT
( dumping
)
2373 ; newFlexiTyVarTy liftedTypeKind
}
2374 ; let (_
, _
, fun_tau
) = tcSplitSigmaTy fun_res
'
2375 (_
, _
, env_tau
) = tcSplitSigmaTy env
'
2376 (args_fun
, res_fun
) = tcSplitFunTys fun_tau
2377 (args_env
, res_env
) = tcSplitFunTys env_tau
2378 n_fun
= length args_fun
2379 n_env
= length args_env
2380 info | n_fun
== n_env
= Outputable
.empty
2383 = text
"Probable cause:" <+> quotes
(ppr fun
)
2384 <+> text
"is applied to too few arguments"
2388 = text
"Possible cause:" <+> quotes
(ppr fun
)
2389 <+> text
"is applied to too many arguments"
2392 = Outputable
.empty -- Never suggest that a naked variable is -- applied to too many args!
2395 not_fun ty
-- ty is definitely not an arrow type,
2396 -- and cannot conceivably become one
2397 = case tcSplitTyConApp_maybe ty
of
2398 Just
(tc
, _
) -> isAlgTyCon tc
2401 badFieldTypes
:: [(FieldLabelString
,TcType
)] -> SDoc
2403 = hang
(text
"Record update for insufficiently polymorphic field"
2404 <> plural prs
<> colon
)
2405 2 (vcat
[ ppr f
<+> dcolon
<+> ppr ty |
(f
,ty
) <- prs
])
2408 :: [LHsRecField
' (AmbiguousFieldOcc Id
) (LHsExpr Name
)] -- Field names that don't belong to a single datacon
2409 -> [ConLike
] -- Data cons of the type which the first field name belongs to
2411 badFieldsUpd rbinds data_cons
2412 = hang
(text
"No constructor has all these fields:")
2413 2 (pprQuotedList conflictingFields
)
2414 -- See Note [Finding the conflicting fields]
2416 -- A (preferably small) set of fields such that no constructor contains
2417 -- all of them. See Note [Finding the conflicting fields]
2418 conflictingFields
= case nonMembers
of
2419 -- nonMember belongs to a different type.
2420 (nonMember
, _
) : _
-> [aMember
, nonMember
]
2422 -- All of rbinds belong to one type. In this case, repeatedly add
2423 -- a field to the set until no constructor contains the set.
2425 -- Each field, together with a list indicating which constructors
2426 -- have all the fields so far.
2427 growingSets
:: [(FieldLabelString
, [Bool])]
2428 growingSets
= scanl1 combine membership
2429 combine
(_
, setMem
) (field
, fldMem
)
2430 = (field
, zipWith (&&) setMem fldMem
)
2432 -- Fields that don't change the membership status of the set
2433 -- are redundant and can be dropped.
2434 map (fst . head) $ groupBy ((==) `on`
snd) growingSets
2436 aMember
= ASSERT
( not (null members
) ) fst (head members
)
2437 (members
, nonMembers
) = partition (or . snd) membership
2439 -- For each field, which constructors contain the field?
2440 membership
:: [(FieldLabelString
, [Bool])]
2441 membership
= sortMembership
$
2442 map (\fld
-> (fld
, map (Set
.member fld
) fieldLabelSets
)) $
2443 map (occNameFS
. rdrNameOcc
. rdrNameAmbiguousFieldOcc
. unLoc
. hsRecFieldLbl
. unLoc
) rbinds
2445 fieldLabelSets
:: [Set
.Set FieldLabelString
]
2446 fieldLabelSets
= map (Set
.fromList
. map flLabel
. conLikeFieldLabels
) data_cons
2448 -- Sort in order of increasing number of True, so that a smaller
2449 -- conflicting set can be found.
2452 sortBy (compare `on`
fst) .
2453 map (\ item@(_
, membershipRow
) -> (countTrue membershipRow
, item))
2455 countTrue
= count
id
2458 Note [Finding the conflicting fields]
2459 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2461 data A = A {a0, a1 :: Int}
2463 and we see a record update
2464 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
2465 Then we'd like to find the smallest subset of fields that no
2466 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
2467 We don't really want to report that no constructor has all of
2468 {a0,a1,b0,b1}, because when there are hundreds of fields it's
2469 hard to see what was really wrong.
2471 We may need more than two fields, though; eg
2472 data T = A { x,y :: Int, v::Int }
2473 | B { y,z :: Int, v::Int }
2474 | C { z,x :: Int, v::Int }
2476 r { x=e1, y=e2, z=e3 }, we
2478 Finding the smallest subset is hard, so the code here makes
2479 a decent stab, no more. See Trac #7989.
2482 naughtyRecordSel
:: RdrName
-> SDoc
2483 naughtyRecordSel sel_id
2484 = text
"Cannot use record selector" <+> quotes
(ppr sel_id
) <+>
2485 text
"as a function due to escaped type variables" $$
2486 text
"Probable fix: use pattern-matching syntax instead"
2488 notSelector
:: Name
-> SDoc
2490 = hsep
[quotes
(ppr field
), text
"is not a record selector"]
2492 mixedSelectors
:: [Id
] -> [Id
] -> SDoc
2493 mixedSelectors data_sels
@(dc_rep_id
:_
) pat_syn_sels
@(ps_rep_id
:_
)
2495 (sLit
"Cannot use a mixture of pattern synonym and record selectors") $$
2496 text
"Record selectors defined by"
2497 <+> quotes
(ppr
(tyConName rep_dc
))
2499 <+> pprWithCommas ppr data_sels
$$
2500 text
"Pattern synonym selectors defined by"
2501 <+> quotes
(ppr
(patSynName rep_ps
))
2503 <+> pprWithCommas ppr pat_syn_sels
2505 RecSelPatSyn rep_ps
= recordSelectorTyCon ps_rep_id
2506 RecSelData rep_dc
= recordSelectorTyCon dc_rep_id
2507 mixedSelectors _ _
= panic
"TcExpr: mixedSelectors emptylists"
2510 missingStrictFields
:: ConLike
-> [FieldLabelString
] -> SDoc
2511 missingStrictFields con fields
2514 rest |
null fields
= Outputable
.empty -- Happens for non-record constructors
2515 -- with strict fields
2516 |
otherwise = colon
<+> pprWithCommas ppr fields
2518 header
= text
"Constructor" <+> quotes
(ppr con
) <+>
2519 text
"does not have the required strict field(s)"
2521 missingFields
:: ConLike
-> [FieldLabelString
] -> SDoc
2522 missingFields con fields
2523 = text
"Fields of" <+> quotes
(ppr con
) <+> ptext
(sLit
"not initialised:")
2524 <+> pprWithCommas ppr fields
2526 -- callCtxt fun args = text "In the call" <+> parens (ppr (foldl mkHsApp fun args))
2528 noPossibleParents
:: [LHsRecUpdField Name
] -> SDoc
2529 noPossibleParents rbinds
2530 = hang
(text
"No type has all these fields:")
2531 2 (pprQuotedList fields
)
2533 fields
= map (hsRecFieldLbl
. unLoc
) rbinds
2535 badOverloadedUpdate
:: SDoc
2536 badOverloadedUpdate
= text
"Record update is ambiguous, and requires a type signature"
2538 fieldNotInType
:: RecSelParent
-> RdrName
-> SDoc
2539 fieldNotInType p rdr
2540 = unknownSubordinateErr
(text
"field of type" <+> quotes
(ppr p
)) rdr
2543 ************************************************************************
2545 \subsection{Static Pointers}
2547 ************************************************************************
2550 -- | A data type to describe why a variable is not closed.
2551 data NotClosedReason
= NotLetBoundReason
2552 | NotTypeClosed VarSet
2553 | NotClosed Name NotClosedReason
2555 -- | Checks if the given name is closed and emits an error if not.
2557 -- See Note [Not-closed error messages].
2558 checkClosedInStaticForm
:: Name
-> TcM
()
2559 checkClosedInStaticForm name
= do
2560 type_env
<- getLclTypeEnv
2561 case checkClosed type_env name
of
2562 Nothing
-> return ()
2563 Just reason
-> addErrTc
$ explain name reason
2565 -- See Note [Checking closedness].
2566 checkClosed
:: TcTypeEnv
-> Name
-> Maybe NotClosedReason
2567 checkClosed type_env n
= checkLoop type_env
(unitNameSet n
) n
2569 checkLoop
:: TcTypeEnv
-> NameSet
-> Name
-> Maybe NotClosedReason
2570 checkLoop type_env visited n
= do
2571 -- The @visited@ set is an accumulating parameter that contains the set of
2572 -- visited nodes, so we avoid repeating cycles in the traversal.
2573 case lookupNameEnv type_env n
of
2574 Just
(ATcId
{ tct_id
= tcid
, tct_info
= info
}) -> case info
of
2575 ClosedLet
-> Nothing
2576 NotLetBound
-> Just NotLetBoundReason
2577 NonClosedLet fvs type_closed
-> listToMaybe $
2578 -- Look for a non-closed variable in fvs
2579 [ NotClosed n
' reason
2580 | n
' <- nameSetElemsStable fvs
2581 , not (elemNameSet n
' visited
)
2582 , Just reason
<- [checkLoop type_env
(extendNameSet visited n
') n
']
2587 -- We consider non-let-bound variables easier to figure out than
2588 -- non-closed types, so we report non-closed types to the user
2589 -- only if we cannot spot the former.
2590 [ NotTypeClosed
$ tyCoVarsOfType
(idType tcid
) ]
2591 -- The binding is closed.
2594 -- Converts a reason into a human-readable sentence.
2596 -- @explain name reason@ starts with
2598 -- "<name> is used in a static form but it is not closed because it"
2600 -- and then follows a list of causes. For each id in the path, the text
2602 -- "uses <id> which"
2604 -- is appended, yielding something like
2606 -- "uses <id> which uses <id1> which uses <id2> which"
2608 -- until the end of the path is reached, which is reported as either
2610 -- "is not let-bound"
2612 -- when the final node is not let-bound, or
2614 -- "has a non-closed type because it contains the type variables:
2617 -- when the final node has a non-closed type.
2619 explain
:: Name
-> NotClosedReason
-> SDoc
2620 explain name reason
=
2621 quotes
(ppr name
) <+> text
"is used in a static form but it is not closed"
2622 <+> text
"because it"
2626 causes
:: NotClosedReason
-> [SDoc
]
2627 causes NotLetBoundReason
= [text
"is not let-bound."]
2628 causes
(NotTypeClosed vs
) =
2629 [ text
"has a non-closed type because it contains the"
2630 , text
"type variables:" <+>
2631 pprVarSet vs
(hsep
. punctuate comma
. map (quotes
. ppr
))
2633 causes
(NotClosed n reason
) =
2634 let msg
= text
"uses" <+> quotes
(ppr n
) <+> text
"which"
2636 NotClosed _ _
-> msg
: causes reason
2637 _
-> let (xs0
, xs1
) = splitAt 1 $ causes reason
2638 in fmap (msg
<+>) xs0
++ xs1
2640 -- Note [Not-closed error messages]
2641 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2643 -- When variables in a static form are not closed, we go through the trouble
2644 -- of explaining why they aren't.
2646 -- Thus, the following program
2648 -- > {-# LANGUAGE StaticPointers #-}
2656 -- produces the error
2658 -- 'g' is used in a static form but it is not closed because it
2659 -- uses 'h' which uses 'x' which is not let-bound.
2661 -- And a program like
2663 -- > {-# LANGUAGE StaticPointers #-}
2666 -- > import Data.Typeable
2667 -- > import GHC.StaticPtr
2669 -- > f :: Typeable a => a -> StaticPtr TypeRep
2670 -- > f x = const (static (g undefined)) (h x)
2675 -- produces the error
2677 -- 'g' is used in a static form but it is not closed because it
2678 -- uses 'h' which has a non-closed type because it contains the
2679 -- type variables: 'a'
2682 -- Note [Checking closedness]
2683 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
2685 -- @checkClosed@ checks if a binding is closed and returns a reason if it is
2688 -- The bindings define a graph where the nodes are ids, and there is an edge
2689 -- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
2692 -- When @n@ is not closed, it has to exist in the graph some node reachable
2693 -- from @n@ that it is not a let-bound variable or that it has a non-closed
2694 -- type. Thus, the "reason" is a path from @n@ to this offending node.
2696 -- When @n@ is not closed, we traverse the graph reachable from @n@ to build
git.haskell.org / ghc.git / blob