never executed always true always false
1
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE ScopedTypeVariables #-}
5 {-# LANGUAGE TupleSections #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
8 -- in module Language.Haskell.Syntax.Extension
9 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
10
11 {-
12 %
13 (c) The University of Glasgow 2006
14 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
15
16 -}
17
18 module GHC.Tc.Gen.Expr
19 ( tcCheckPolyExpr, tcCheckPolyExprNC,
20 tcCheckMonoExpr, tcCheckMonoExprNC,
21 tcMonoExpr, tcMonoExprNC,
22 tcInferRho, tcInferRhoNC,
23 tcPolyExpr, tcExpr,
24 tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
25 tcCheckId,
26 getFixedTyVars ) where
27
28 import GHC.Prelude
29
30 import {-# SOURCE #-} GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
31
32 import GHC.Hs
33 import GHC.Hs.Syn.Type
34 import GHC.Rename.Utils
35 import GHC.Tc.Utils.Zonk
36 import GHC.Tc.Utils.Monad
37 import GHC.Tc.Utils.Unify
38 import GHC.Types.Basic
39 import GHC.Types.Error
40 import GHC.Core.Multiplicity
41 import GHC.Core.UsageEnv
42 import GHC.Tc.Errors.Types
43 import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, mkWpFun )
44 import GHC.Tc.Utils.Instantiate
45 import GHC.Tc.Gen.App
46 import GHC.Tc.Gen.Head
47 import GHC.Tc.Gen.Bind ( tcLocalBinds )
48 import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
49 import GHC.Core.FamInstEnv ( FamInstEnvs )
50 import GHC.Rename.Env ( addUsedGRE )
51 import GHC.Tc.Utils.Env
52 import GHC.Tc.Gen.Arrow
53 import GHC.Tc.Gen.Match
54 import GHC.Tc.Gen.HsType
55 import GHC.Tc.Gen.Pat
56 import GHC.Tc.Utils.TcMType
57 import GHC.Tc.Types.Origin
58 import GHC.Tc.Utils.TcType as TcType
59 import GHC.Types.Id
60 import GHC.Types.Id.Info
61 import GHC.Core.ConLike
62 import GHC.Core.DataCon
63 import GHC.Core.PatSyn
64 import GHC.Types.Name
65 import GHC.Types.Name.Env
66 import GHC.Types.Name.Set
67 import GHC.Types.Name.Reader
68 import GHC.Core.TyCon
69 import GHC.Core.Type
70 import GHC.Tc.Types.Evidence
71 import GHC.Types.Var.Set
72 import GHC.Builtin.Types
73 import GHC.Builtin.Names
74 import GHC.Driver.Session
75 import GHC.Types.SrcLoc
76 import GHC.Utils.Misc
77 import GHC.Data.List.SetOps
78 import GHC.Data.Maybe
79 import GHC.Utils.Outputable as Outputable
80 import GHC.Utils.Panic
81 import GHC.Utils.Panic.Plain
82 import Control.Monad
83 import GHC.Core.Class(classTyCon)
84 import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
85
86 import Data.Function
87 import Data.List (partition, sortBy, groupBy, intersect)
88
89 {-
90 ************************************************************************
91 * *
92 \subsection{Main wrappers}
93 * *
94 ************************************************************************
95 -}
96
97
98 tcCheckPolyExpr, tcCheckPolyExprNC
99 :: LHsExpr GhcRn -- Expression to type check
100 -> TcSigmaType -- Expected type (could be a polytype)
101 -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type
102
103 -- tcCheckPolyExpr is a convenient place (frequent but not too frequent)
104 -- place to add context information.
105 -- The NC version does not do so, usually because the caller wants
106 -- to do so themselves.
107
108 tcCheckPolyExpr expr res_ty = tcPolyLExpr expr (mkCheckExpType res_ty)
109 tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty)
110
111 -- These versions take an ExpType
112 tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
113 -> TcM (LHsExpr GhcTc)
114
115 tcPolyLExpr (L loc expr) res_ty
116 = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
117 addExprCtxt expr $ -- Note [Error contexts in generated code]
118 do { expr' <- tcPolyExpr expr res_ty
119 ; return (L loc expr') }
120
121 tcPolyLExprNC (L loc expr) res_ty
122 = setSrcSpanA loc $
123 do { expr' <- tcPolyExpr expr res_ty
124 ; return (L loc expr') }
125
126 ---------------
127 tcCheckMonoExpr, tcCheckMonoExprNC
128 :: LHsExpr GhcRn -- Expression to type check
129 -> TcRhoType -- Expected type
130 -- Definitely no foralls at the top
131 -> TcM (LHsExpr GhcTc)
132 tcCheckMonoExpr expr res_ty = tcMonoExpr expr (mkCheckExpType res_ty)
133 tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty)
134
135 tcMonoExpr, tcMonoExprNC
136 :: LHsExpr GhcRn -- Expression to type check
137 -> ExpRhoType -- Expected type
138 -- Definitely no foralls at the top
139 -> TcM (LHsExpr GhcTc)
140
141 tcMonoExpr (L loc expr) res_ty
142 = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
143 addExprCtxt expr $ -- Note [Error contexts in generated code]
144 do { expr' <- tcExpr expr res_ty
145 ; return (L loc expr') }
146
147 tcMonoExprNC (L loc expr) res_ty
148 = setSrcSpanA loc $
149 do { expr' <- tcExpr expr res_ty
150 ; return (L loc expr') }
151
152 ---------------
153 tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
154 -- Infer a *rho*-type. The return type is always instantiated.
155 tcInferRho (L loc expr)
156 = setSrcSpanA loc $ -- Set location /first/; see GHC.Tc.Utils.Monad
157 addExprCtxt expr $ -- Note [Error contexts in generated code]
158 do { (expr', rho) <- tcInfer (tcExpr expr)
159 ; return (L loc expr', rho) }
160
161 tcInferRhoNC (L loc expr)
162 = setSrcSpanA loc $
163 do { (expr', rho) <- tcInfer (tcExpr expr)
164 ; return (L loc expr', rho) }
165
166
167 {- *********************************************************************
168 * *
169 tcExpr: the main expression typechecker
170 * *
171 ********************************************************************* -}
172
173 tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
174 tcPolyExpr expr res_ty
175 = do { traceTc "tcPolyExpr" (ppr res_ty)
176 ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
177 tcExpr expr res_ty
178 ; return $ mkHsWrap wrap expr' }
179
180 tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
181
182 -- Use tcApp to typecheck appplications, which are treated specially
183 -- by Quick Look. Specifically:
184 -- - HsVar lone variables, to ensure that they can get an
185 -- impredicative instantiation (via Quick Look
186 -- driven by res_ty (in checking mode)).
187 -- - HsApp value applications
188 -- - HsAppType type applications
189 -- - ExprWithTySig (e :: type)
190 -- - HsRecSel overloaded record fields
191 -- - HsExpanded renamer expansions
192 -- - HsOpApp operator applications
193 -- - HsOverLit overloaded literals
194 -- These constructors are the union of
195 -- - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
196 -- - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
197 -- See Note [Application chains and heads] in GHC.Tc.Gen.App
198 tcExpr e@(HsVar {}) res_ty = tcApp e res_ty
199 tcExpr e@(HsApp {}) res_ty = tcApp e res_ty
200 tcExpr e@(OpApp {}) res_ty = tcApp e res_ty
201 tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
202 tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
203 tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
204 tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
205
206 tcExpr e@(HsOverLit _ lit) res_ty
207 = do { mb_res <- tcShortCutLit lit res_ty
208 -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk
209 ; case mb_res of
210 Just lit' -> return (HsOverLit noAnn lit')
211 Nothing -> tcApp e res_ty }
212
213 -- Typecheck an occurrence of an unbound Id
214 --
215 -- Some of these started life as a true expression hole "_".
216 -- Others might simply be variables that accidentally have no binding site
217 tcExpr (HsUnboundVar _ occ) res_ty
218 = do { ty <- expTypeToType res_ty -- Allow Int# etc (#12531)
219 ; her <- emitNewExprHole occ ty
220 ; tcEmitBindingUsage bottomUE -- Holes fit any usage environment
221 -- (#18491)
222 ; return (HsUnboundVar her occ) }
223
224 tcExpr e@(HsLit x lit) res_ty
225 = do { let lit_ty = hsLitType lit
226 ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
227
228 tcExpr (HsPar x lpar expr rpar) res_ty
229 = do { expr' <- tcMonoExprNC expr res_ty
230 ; return (HsPar x lpar expr' rpar) }
231
232 tcExpr (HsPragE x prag expr) res_ty
233 = do { expr' <- tcMonoExpr expr res_ty
234 ; return (HsPragE x (tcExprPrag prag) expr') }
235
236 tcExpr (NegApp x expr neg_expr) res_ty
237 = do { (expr', neg_expr')
238 <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
239 \[arg_ty] [arg_mult] ->
240 tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty
241 ; return (NegApp x expr' neg_expr') }
242
243 tcExpr e@(HsIPVar _ x) res_ty
244 = do { {- Implicit parameters must have a *tau-type* not a
245 type scheme. We enforce this by creating a fresh
246 type variable as its type. (Because res_ty may not
247 be a tau-type.) -}
248 ip_ty <- newOpenFlexiTyVarTy
249 ; let ip_name = mkStrLitTy (hsIPNameFS x)
250 ; ipClass <- tcLookupClass ipClassName
251 ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
252 ; tcWrapResult e
253 (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))
254 ip_ty res_ty }
255 where
256 -- Coerces a dictionary for `IP "x" t` into `t`.
257 fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
258 unwrapIP $ mkClassPred ipClass [x,ty]
259 origin = IPOccOrigin x
260
261 tcExpr (HsLam _ match) res_ty
262 = do { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty
263 ; return (mkHsWrap wrap (HsLam noExtField match')) }
264 where
265 match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
266 herald = sep [ text "The lambda expression" <+>
267 quotes (pprSetDepth (PartWay 1) $
268 pprMatches match),
269 -- The pprSetDepth makes the abstraction print briefly
270 text "has"]
271
272 tcExpr e@(HsLamCase x matches) res_ty
273 = do { (wrap, matches')
274 <- tcMatchLambda msg match_ctxt matches res_ty
275 -- The laziness annotation is because we don't want to fail here
276 -- if there are multiple arguments
277 ; return (mkHsWrap wrap $ HsLamCase x matches') }
278 where
279 msg = sep [ text "The function" <+> quotes (ppr e)
280 , text "requires"]
281 match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
282
283
284
285 {-
286 ************************************************************************
287 * *
288 Explicit lists
289 * *
290 ************************************************************************
291 -}
292
293 -- Explict lists [e1,e2,e3] have been expanded already in the renamer
294 -- The expansion includes an ExplicitList, but it is always the built-in
295 -- list type, so that's all we need concern ourselves with here. See
296 -- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]
297 tcExpr (ExplicitList _ exprs) res_ty
298 = do { res_ty <- expTypeToType res_ty
299 ; (coi, elt_ty) <- matchExpectedListTy res_ty
300 ; let tc_elt expr = tcCheckPolyExpr expr elt_ty
301 ; exprs' <- mapM tc_elt exprs
302 ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }
303
304 tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
305 | all tupArgPresent tup_args
306 = do { let arity = length tup_args
307 tup_tc = tupleTyCon boxity arity
308 -- NB: tupleTyCon doesn't flatten 1-tuples
309 -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
310 ; res_ty <- expTypeToType res_ty
311 ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
312 -- Unboxed tuples have RuntimeRep vars, which we
313 -- don't care about here
314 -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
315 ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
316 Boxed -> arg_tys
317 ; tup_args1 <- tcTupArgs tup_args arg_tys'
318 ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
319
320 | otherwise
321 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
322 do { let arity = length tup_args
323
324 ; arg_tys <- case boxity of
325 { Boxed -> newFlexiTyVarTys arity liftedTypeKind
326 ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
327
328 -- Handle tuple sections where
329 ; tup_args1 <- tcTupArgs tup_args arg_tys
330
331 ; let expr' = ExplicitTuple x tup_args1 boxity
332 missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys]
333
334 -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
335 -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
336 act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)
337
338 ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)
339
340 ; tcWrapResultMono expr expr' act_res_ty res_ty }
341
342 tcExpr (ExplicitSum _ alt arity expr) res_ty
343 = do { let sum_tc = sumTyCon arity
344 ; res_ty <- expTypeToType res_ty
345 ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
346 ; -- Drop levity vars, we don't care about them here
347 let arg_tys' = drop arity arg_tys
348 arg_ty = arg_tys' `getNth` (alt - 1)
349 ; expr' <- tcCheckPolyExpr expr arg_ty
350 -- Check the whole res_ty, not just the arg_ty, to avoid #20277.
351 -- Example:
352 -- a :: TYPE rep (representation-polymorphic)
353 -- (# 17# | #) :: (# Int# | a #)
354 -- This should cause an error, even though (17# :: Int#)
355 -- is not representation-polymorphic: we don't know how
356 -- wide the concrete representation of the sum type will be.
357 ; _concrete_ev <- hasFixedRuntimeRep FRRUnboxedSum res_ty
358 ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
359
360
361 {-
362 ************************************************************************
363 * *
364 Let, case, if, do
365 * *
366 ************************************************************************
367 -}
368
369 tcExpr (HsLet x tkLet binds tkIn expr) res_ty
370 = do { (binds', expr') <- tcLocalBinds binds $
371 tcMonoExpr expr res_ty
372 ; return (HsLet x tkLet binds' tkIn expr') }
373
374 tcExpr (HsCase x scrut matches) res_ty
375 = do { -- We used to typecheck the case alternatives first.
376 -- The case patterns tend to give good type info to use
377 -- when typechecking the scrutinee. For example
378 -- case (map f) of
379 -- (x:xs) -> ...
380 -- will report that map is applied to too few arguments
381 --
382 -- But now, in the GADT world, we need to typecheck the scrutinee
383 -- first, to get type info that may be refined in the case alternatives
384 mult <- newFlexiTyVarTy multiplicityTy
385
386 -- Typecheck the scrutinee. We use tcInferRho but tcInferSigma
387 -- would also be possible (tcMatchesCase accepts sigma-types)
388 -- Interesting litmus test: do these two behave the same?
389 -- case id of {..}
390 -- case (\v -> v) of {..}
391 -- This design choice is discussed in #17790
392 ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
393
394 ; traceTc "HsCase" (ppr scrut_ty)
395 ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
396 ; return (HsCase x scrut' matches') }
397 where
398 match_ctxt = MC { mc_what = CaseAlt,
399 mc_body = tcBody }
400
401 tcExpr (HsIf x pred b1 b2) res_ty
402 = do { pred' <- tcCheckMonoExpr pred boolTy
403 ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty
404 ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty
405 ; tcEmitBindingUsage (supUE u1 u2)
406 ; return (HsIf x pred' b1' b2') }
407
408 tcExpr (HsMultiIf _ alts) res_ty
409 = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts
410 ; res_ty <- readExpType res_ty
411 ; return (HsMultiIf res_ty alts') }
412 where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
413
414 tcExpr (HsDo _ do_or_lc stmts) res_ty
415 = tcDoStmts do_or_lc stmts res_ty
416
417 tcExpr (HsProc x pat cmd) res_ty
418 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
419 ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
420
421 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
422 -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
423 -- To type check
424 -- (static e) :: p a
425 -- we want to check (e :: a),
426 -- and wrap (static e) in a call to
427 -- fromStaticPtr :: IsStatic p => StaticPtr a -> p a
428
429 tcExpr (HsStatic fvs expr) res_ty
430 = do { res_ty <- expTypeToType res_ty
431 ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
432 ; (expr', lie) <- captureConstraints $
433 addErrCtxt (hang (text "In the body of a static form:")
434 2 (ppr expr)
435 ) $
436 tcCheckPolyExprNC expr expr_ty
437
438 -- Check that the free variables of the static form are closed.
439 -- It's OK to use nonDetEltsUniqSet here as the only side effects of
440 -- checkClosedInStaticForm are error messages.
441 ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
442
443 -- Require the type of the argument to be Typeable.
444 ; typeableClass <- tcLookupClass typeableClassName
445 ; typeable_ev <- emitWantedEvVar StaticOrigin $
446 mkTyConApp (classTyCon typeableClass)
447 [liftedTypeKind, expr_ty]
448
449 -- Insert the constraints of the static form in a global list for later
450 -- validation.
451 ; emitStaticConstraints lie
452
453 -- Wrap the static form with the 'fromStaticPtr' call.
454 ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
455 [p_ty]
456 ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty]
457 ; loc <- getSrcSpanM
458 ; return $ mkHsWrapCo co $ HsApp noComments
459 (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)
460 (L (noAnnSrcSpan loc) (HsStatic fvs expr'))
461 }
462
463 {-
464 ************************************************************************
465 * *
466 Record construction and update
467 * *
468 ************************************************************************
469 -}
470
471 tcExpr expr@(RecordCon { rcon_con = L loc con_name
472 , rcon_flds = rbinds }) res_ty
473 = do { con_like <- tcLookupConLike con_name
474
475 ; (con_expr, con_sigma) <- tcInferId con_name
476 ; (con_wrap, con_tau) <- topInstantiate orig con_sigma
477 -- a shallow instantiation should really be enough for
478 -- a data constructor.
479 ; let arity = conLikeArity con_like
480 Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
481
482 ; checkTc (conLikeHasBuilder con_like) $
483 nonBidirectionalErr (conLikeName con_like)
484
485 ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
486 -- It is currently not possible for a record to have
487 -- multiplicities. When they do, `tcRecordBinds` will take
488 -- scaled types instead. Meanwhile, it's safe to take
489 -- `scaledThing` above, as we know all the multiplicities are
490 -- Many.
491
492 ; let rcon_tc = mkHsWrap con_wrap con_expr
493 expr' = RecordCon { rcon_ext = rcon_tc
494 , rcon_con = L loc con_like
495 , rcon_flds = rbinds' }
496
497 ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty
498
499 -- Check for missing fields. We do this after type-checking to get
500 -- better types in error messages (cf #18869). For example:
501 -- data T a = MkT { x :: a, y :: a }
502 -- r = MkT { y = True }
503 -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`.
504 --
505 -- NB: to do this really properly we should delay reporting until typechecking is complete,
506 -- via a new `HoleSort`. But that seems too much work.
507 ; checkMissingFields con_like rbinds arg_tys
508
509 ; return ret }
510 where
511 orig = OccurrenceOf con_name
512
513 {-
514 Note [Type of a record update]
515 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
516 The main complication with RecordUpd is that we need to explicitly
517 handle the *non-updated* fields. Consider:
518
519 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
520 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
521 | MkT3 { fd :: a }
522
523 upd :: T a b c -> (b',c) -> T a b' c
524 upd t x = t { fb = x}
525
526 The result type should be (T a b' c)
527 not (T a b c), because 'b' *is not* mentioned in a non-updated field
528 not (T a b' c'), because 'c' *is* mentioned in a non-updated field
529 NB that it's not good enough to look at just one constructor; we must
530 look at them all; cf #3219
531
532 After all, upd should be equivalent to:
533 upd t x = case t of
534 MkT1 p q -> MkT1 p x
535 MkT2 a b -> MkT2 p b
536 MkT3 d -> error ...
537
538 So we need to give a completely fresh type to the result record,
539 and then constrain it by the fields that are *not* updated ("p" above).
540 We call these the "fixed" type variables, and compute them in getFixedTyVars.
541
542 Note that because MkT3 doesn't contain all the fields being updated,
543 its RHS is simply an error, so it doesn't impose any type constraints.
544 Hence the use of 'relevant_cont'.
545
546 Note [Implicit type sharing]
547 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
548 We also take into account any "implicit" non-update fields. For example
549 data T a b where { MkT { f::a } :: T a a; ... }
550 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
551
552 Then consider
553 upd t x = t { f=x }
554 We infer the type
555 upd :: T a b -> a -> T a b
556 upd (t::T a b) (x::a)
557 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
558 We can't give it the more general type
559 upd :: T a b -> c -> T c b
560
561 Note [Criteria for update]
562 ~~~~~~~~~~~~~~~~~~~~~~~~~~
563 We want to allow update for existentials etc, provided the updated
564 field isn't part of the existential. For example, this should be ok.
565 data T a where { MkT { f1::a, f2::b->b } :: T a }
566 f :: T a -> b -> T b
567 f t b = t { f1=b }
568
569 The criterion we use is this:
570
571 The types of the updated fields
572 mention only the universally-quantified type variables
573 of the data constructor
574
575 NB: this is not (quite) the same as being a "naughty" record selector
576 (See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least
577 in the case of GADTs. Consider
578 data T a where { MkT :: { f :: a } :: T [a] }
579 Then f is not "naughty" because it has a well-typed record selector.
580 But we don't allow updates for 'f'. (One could consider trying to
581 allow this, but it makes my head hurt. Badly. And no one has asked
582 for it.)
583
584 In principle one could go further, and allow
585 g :: T a -> T a
586 g t = t { f2 = \x -> x }
587 because the expression is polymorphic...but that seems a bridge too far.
588
589 Note [Data family example]
590 ~~~~~~~~~~~~~~~~~~~~~~~~~~
591 data instance T (a,b) = MkT { x::a, y::b }
592 --->
593 data :TP a b = MkT { a::a, y::b }
594 coTP a b :: T (a,b) ~ :TP a b
595
596 Suppose r :: T (t1,t2), e :: t3
597 Then r { x=e } :: T (t3,t1)
598 --->
599 case r |> co1 of
600 MkT x y -> MkT e y |> co2
601 where co1 :: T (t1,t2) ~ :TP t1 t2
602 co2 :: :TP t3 t2 ~ T (t3,t2)
603 The wrapping with co2 is done by the constructor wrapper for MkT
604
605 Outgoing invariants
606 ~~~~~~~~~~~~~~~~~~~
607 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
608
609 * cons are the data constructors to be updated
610
611 * in_inst_tys, out_inst_tys have same length, and instantiate the
612 *representation* tycon of the data cons. In Note [Data
613 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
614
615 Note [Mixed Record Field Updates]
616 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
617 Consider the following pattern synonym.
618
619 data MyRec = MyRec { foo :: Int, qux :: String }
620
621 pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
622
623 This allows updates such as the following
624
625 updater :: MyRec -> MyRec
626 updater a = a {f1 = 1 }
627
628 It would also make sense to allow the following update (which we reject).
629
630 updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
631
632 This leads to confusing behaviour when the selectors in fact refer the same
633 field.
634
635 updater a = a {f1 = 1, foo = 2} ==? ???
636
637 For this reason, we reject a mixture of pattern synonym and normal record
638 selectors in the same update block. Although of course we still allow the
639 following.
640
641 updater a = (a {f1 = 1}) {foo = 2}
642
643 > updater (MyRec 0 "str")
644 MyRec 2 "str"
645
646 -}
647
648 -- Record updates via dot syntax are replaced by desugared expressions
649 -- in the renamer. See Note [Overview of record dot syntax] in
650 -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
651 -- and panic otherwise.
652 tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty
653 = assert (notNull rbnds) $
654 do { -- STEP -2: typecheck the record_expr, the record to be updated
655 (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr
656 -- Record update drops some of the content of the record (namely the
657 -- content of the field being updated). As a consequence, unless the
658 -- field being updated is unrestricted in the record, or we need an
659 -- unrestricted record. Currently, we simply always require an
660 -- unrestricted record.
661 --
662 -- Consider the following example:
663 --
664 -- data R a = R { self :: a }
665 -- bad :: a ⊸ ()
666 -- bad x = let r = R x in case r { self = () } of { R x' -> x' }
667 --
668 -- This should definitely *not* typecheck.
669
670 -- STEP -1 See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
671 -- After this we know that rbinds is unambiguous
672 ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
673 ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
674 upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
675 sel_ids = map selectorAmbiguousFieldOcc upd_flds
676 -- STEP 0
677 -- Check that the field names are really field names
678 -- and they are all field names for proper records or
679 -- all field names for pattern synonyms.
680 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
681 | fld <- rbinds,
682 -- Excludes class ops
683 let L loc sel_id = hsRecUpdFieldId (unLoc fld),
684 not (isRecordSelector sel_id),
685 let fld_name = idName sel_id ]
686 ; unless (null bad_guys) (sequence bad_guys >> failM)
687 -- See note [Mixed Record Selectors]
688 ; let (data_sels, pat_syn_sels) =
689 partition isDataConRecordSelector sel_ids
690 ; massert (all isPatSynRecordSelector pat_syn_sels)
691 ; checkTc ( null data_sels || null pat_syn_sels )
692 ( mixedSelectors data_sels pat_syn_sels )
693
694 -- STEP 1
695 -- Figure out the tycon and data cons from the first field name
696 ; let -- It's OK to use the non-tc splitters here (for a selector)
697 sel_id : _ = sel_ids
698
699 mtycon :: Maybe TyCon
700 mtycon = case idDetails sel_id of
701 RecSelId (RecSelData tycon) _ -> Just tycon
702 _ -> Nothing
703
704 con_likes :: [ConLike]
705 con_likes = case idDetails sel_id of
706 RecSelId (RecSelData tc) _
707 -> map RealDataCon (tyConDataCons tc)
708 RecSelId (RecSelPatSyn ps) _
709 -> [PatSynCon ps]
710 _ -> panic "tcRecordUpd"
711 -- NB: for a data type family, the tycon is the instance tycon
712
713 relevant_cons = conLikesWithFields con_likes upd_fld_occs
714 -- A constructor is only relevant to this process if
715 -- it contains *all* the fields that are being updated
716 -- Other ones will cause a runtime error if they occur
717
718 -- Step 2
719 -- Check that at least one constructor has all the named fields
720 -- i.e. has an empty set of bad fields returned by badFields
721 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
722
723 -- Take apart a representative constructor
724 ; let con1 = assert (not (null relevant_cons) ) head relevant_cons
725 (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)
726 = conLikeFullSig con1
727 con1_arg_tys = map scaledThing scaled_con1_arg_tys
728 -- We can safely drop the fields' multiplicities because
729 -- they are currently always 1: there is no syntax for record
730 -- fields with other multiplicities yet. This way we don't need
731 -- to handle it in the rest of the function
732 con1_flds = map flLabel $ conLikeFieldLabels con1
733 con1_tv_tys = mkTyVarTys con1_tvs
734 con1_res_ty = case mtycon of
735 Just tc -> mkFamilyTyConApp tc con1_tv_tys
736 Nothing -> conLikeResTy con1 con1_tv_tys
737
738 -- Check that we're not dealing with a unidirectional pattern
739 -- synonym
740 ; checkTc (conLikeHasBuilder con1) $
741 nonBidirectionalErr (conLikeName con1)
742
743 -- STEP 3 Note [Criteria for update]
744 -- Check that each updated field is polymorphic; that is, its type
745 -- mentions only the universally-quantified variables of the data con
746 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
747 bad_upd_flds = filter bad_fld flds1_w_tys
748 con1_tv_set = mkVarSet con1_tvs
749 bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
750 not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
751 ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds)
752
753 -- STEP 4 Note [Type of a record update]
754 -- Figure out types for the scrutinee and result
755 -- Both are of form (T a b c), with fresh type variables, but with
756 -- common variables where the scrutinee and result must have the same type
757 -- These are variables that appear in *any* arg of *any* of the
758 -- relevant constructors *except* in the updated fields
759 --
760 ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
761 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
762
763 mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
764 -- Deals with instantiation of kind variables
765 -- c.f. GHC.Tc.Utils.TcMType.newMetaTyVars
766 mk_inst_ty subst (tv, result_inst_ty)
767 | is_fixed_tv tv -- Same as result type
768 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
769 | otherwise -- Fresh type, of correct kind
770 = do { (subst', new_tv) <- newMetaTyVarX subst tv
771 ; return (subst', mkTyVarTy new_tv) }
772
773 ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
774 ; let result_inst_tys = mkTyVarTys con1_tvs'
775 init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
776
777 ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
778 (con1_tvs `zip` result_inst_tys)
779
780 ; let rec_res_ty = TcType.substTy result_subst con1_res_ty
781 scrut_ty = TcType.substTy scrut_subst con1_res_ty
782 con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
783
784 ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty
785 -- NB: normal unification is OK here (as opposed to subsumption),
786 -- because for this to work out, both record_rho and scrut_ty have
787 -- to be normal datatypes -- no contravariant stuff can go on
788
789 -- STEP 5
790 -- Typecheck the bindings
791 ; rbinds' <- tcRecordUpd con1 con1_arg_tys' rbinds
792
793 -- STEP 6: Deal with the stupid theta
794 ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)
795 ; instStupidTheta RecordUpdOrigin theta'
796
797 -- Step 7: make a cast for the scrutinee, in the
798 -- case that it's from a data family
799 ; let fam_co :: HsWrapper -- RepT t1 .. tn ~R scrut_ty
800 fam_co | Just tycon <- mtycon
801 , Just co_con <- tyConFamilyCoercion_maybe tycon
802 = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])
803 | otherwise
804 = idHsWrapper
805
806 -- Step 8: Check that the req constraints are satisfied
807 -- For normal data constructors req_theta is empty but we must do
808 -- this check for pattern synonyms.
809 ; let req_theta' = substThetaUnchecked scrut_subst req_theta
810 ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
811
812 -- Phew!
813 ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons
814 , rupd_in_tys = scrut_inst_tys
815 , rupd_out_tys = result_inst_tys
816 , rupd_wrap = req_wrap }
817 expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $
818 mkLHsWrapCo co_scrut record_expr'
819 , rupd_flds = Left rbinds'
820 , rupd_ext = upd_tc }
821
822 ; tcWrapResult expr expr' rec_res_ty res_ty }
823 tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"
824
825
826 {-
827 ************************************************************************
828 * *
829 Arithmetic sequences e.g. [a,b..]
830 and their parallel-array counterparts e.g. [: a,b.. :]
831
832 * *
833 ************************************************************************
834 -}
835
836 tcExpr (ArithSeq _ witness seq) res_ty
837 = tcArithSeq witness seq res_ty
838
839 {-
840 ************************************************************************
841 * *
842 Record dot syntax
843 * *
844 ************************************************************************
845 -}
846
847 -- These terms have been replaced by desugaring in the renamer. See
848 -- Note [Overview of record dot syntax].
849 tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
850 tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
851
852 {-
853 ************************************************************************
854 * *
855 Template Haskell
856 * *
857 ************************************************************************
858 -}
859
860 -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'.
861 -- Here we get rid of it and add the finalizers to the global environment.
862 --
863 -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
864 tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
865 res_ty
866 = do addModFinalizersWithLclEnv mod_finalizers
867 tcExpr expr res_ty
868 tcExpr (HsSpliceE _ splice) res_ty = tcSpliceExpr splice res_ty
869 tcExpr e@(HsBracket _ brack) res_ty = tcTypedBracket e brack res_ty
870 tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty
871
872 {-
873 ************************************************************************
874 * *
875 Catch-all
876 * *
877 ************************************************************************
878 -}
879
880 tcExpr (HsOverLabel {}) ty = pprPanic "tcExpr:HsOverLabel" (ppr ty)
881 tcExpr (SectionL {}) ty = pprPanic "tcExpr:SectionL" (ppr ty)
882 tcExpr (SectionR {}) ty = pprPanic "tcExpr:SectionR" (ppr ty)
883 tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut" (ppr ty)
884
885
886 {-
887 ************************************************************************
888 * *
889 Arithmetic sequences [a..b] etc
890 * *
891 ************************************************************************
892 -}
893
894 tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
895 -> TcM (HsExpr GhcTc)
896
897 tcArithSeq witness seq@(From expr) res_ty
898 = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
899 ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty
900 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
901 enumFromName [elt_ty]
902 ; return $ mkHsWrap wrap $
903 ArithSeq enum_from wit' (From expr') }
904
905 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
906 = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
907 ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
908 ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
909 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
910 enumFromThenName [elt_ty]
911 ; return $ mkHsWrap wrap $
912 ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
913
914 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
915 = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
916 ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
917 ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
918 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
919 enumFromToName [elt_ty]
920 ; return $ mkHsWrap wrap $
921 ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
922
923 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
924 = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
925 ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
926 ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
927 ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty
928 ; eft <- newMethodFromName (ArithSeqOrigin seq)
929 enumFromThenToName [elt_ty]
930 ; return $ mkHsWrap wrap $
931 ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
932
933 -----------------
934 arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
935 -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
936 arithSeqEltType Nothing res_ty
937 = do { res_ty <- expTypeToType res_ty
938 ; (coi, elt_ty) <- matchExpectedListTy res_ty
939 ; return (mkWpCastN coi, One, elt_ty, Nothing) }
940 arithSeqEltType (Just fl) res_ty
941 = do { ((elt_mult, elt_ty), fl')
942 <- tcSyntaxOp ListOrigin fl [SynList] res_ty $
943 \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty)
944 ; return (idHsWrapper, elt_mult, elt_ty, Just fl') }
945
946 ----------------
947 tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
948 tcTupArgs args tys
949 = do massert (equalLength args tys)
950 checkTupSize (length args)
951 zipWith3M go [1,2..] args tys
952 where
953 go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
954 go i (Missing {}) arg_ty
955 = do { mult <- newFlexiTyVarTy multiplicityTy
956 ; _concrete_ev <- hasFixedRuntimeRep (FRRTupleSection i) arg_ty
957 ; return (Missing (Scaled mult arg_ty)) }
958 go i (Present x expr) arg_ty
959 = do { expr' <- tcCheckPolyExpr expr arg_ty
960 ; _concrete_ev <- hasFixedRuntimeRep (FRRTupleArg i) arg_ty
961 ; return (Present x expr') }
962
963 ---------------------------
964 -- See TcType.SyntaxOpType also for commentary
965 tcSyntaxOp :: CtOrigin
966 -> SyntaxExprRn
967 -> [SyntaxOpType] -- ^ shape of syntax operator arguments
968 -> ExpRhoType -- ^ overall result type
969 -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,
970 -- takes a type per hole and a
971 -- multiplicity per arrow in
972 -- the shape.
973 -> TcM (a, SyntaxExprTc)
974 -- ^ Typecheck a syntax operator
975 -- The operator is a variable or a lambda at this stage (i.e. renamer
976 -- output)t
977 tcSyntaxOp orig expr arg_tys res_ty
978 = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
979
980 -- | Slightly more general version of 'tcSyntaxOp' that allows the caller
981 -- to specify the shape of the result of the syntax operator
982 tcSyntaxOpGen :: CtOrigin
983 -> SyntaxExprRn
984 -> [SyntaxOpType]
985 -> SyntaxOpType
986 -> ([TcSigmaType] -> [Mult] -> TcM a)
987 -> TcM (a, SyntaxExprTc)
988 tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside
989 = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []
990 -- Ugh!! But all this code is scheduled for demolition anyway
991 ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
992 ; (result, expr_wrap, arg_wraps, res_wrap)
993 <- tcSynArgA orig sigma arg_tys res_ty $
994 thing_inside
995 ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )
996 ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr
997 , syn_arg_wraps = arg_wraps
998 , syn_res_wrap = res_wrap }) }
999 tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"
1000
1001 {-
1002 Note [tcSynArg]
1003 ~~~~~~~~~~~~~~~
1004 Because of the rich structure of SyntaxOpType, we must do the
1005 contra-/covariant thing when working down arrows, to get the
1006 instantiation vs. skolemisation decisions correct (and, more
1007 obviously, the orientation of the HsWrappers). We thus have
1008 two tcSynArgs.
1009 -}
1010
1011 -- works on "expected" types, skolemising where necessary
1012 -- See Note [tcSynArg]
1013 tcSynArgE :: CtOrigin
1014 -> TcSigmaType
1015 -> SyntaxOpType -- ^ shape it is expected to have
1016 -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments
1017 -> TcM (a, HsWrapper)
1018 -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
1019 tcSynArgE orig sigma_ty syn_ty thing_inside
1020 = do { (skol_wrap, (result, ty_wrapper))
1021 <- tcSkolemise GenSigCtxt sigma_ty
1022 (\ rho_ty -> go rho_ty syn_ty)
1023 ; return (result, skol_wrap <.> ty_wrapper) }
1024 where
1025 go rho_ty SynAny
1026 = do { result <- thing_inside [rho_ty] []
1027 ; return (result, idHsWrapper) }
1028
1029 go rho_ty SynRho -- same as SynAny, because we skolemise eagerly
1030 = do { result <- thing_inside [rho_ty] []
1031 ; return (result, idHsWrapper) }
1032
1033 go rho_ty SynList
1034 = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
1035 ; result <- thing_inside [elt_ty] []
1036 ; return (result, mkWpCastN list_co) }
1037
1038 go rho_ty (SynFun arg_shape res_shape)
1039 = do { ( match_wrapper -- :: (arg_ty -> res_ty) "->" rho_ty
1040 , ( ( (result, arg_ty, res_ty, op_mult)
1041 , res_wrapper ) -- :: res_ty_out "->" res_ty
1042 , arg_wrapper1, [], arg_wrapper2 ) ) -- :: arg_ty "->" arg_ty_out
1043 <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
1044 \ [arg_ty] res_ty ->
1045 do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
1046 ; res_tc_ty <- expTypeToType res_ty
1047
1048 -- another nested arrow is too much for now,
1049 -- but I bet we'll never need this
1050 ; massertPpr (case arg_shape of
1051 SynFun {} -> False;
1052 _ -> True)
1053 (text "Too many nested arrows in SyntaxOpType" $$
1054 pprCtOrigin orig)
1055
1056 ; let arg_mult = scaledMult arg_ty
1057 ; tcSynArgA orig arg_tc_ty [] arg_shape $
1058 \ arg_results arg_res_mults ->
1059 tcSynArgE orig res_tc_ty res_shape $
1060 \ res_results res_res_mults ->
1061 do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)
1062 ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }}
1063
1064 ; fun_wrap <- mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
1065 (Scaled op_mult arg_ty) res_ty (WpFunSyntaxOp orig)
1066 ; return (result, match_wrapper <.> fun_wrap) }
1067 where
1068 herald = text "This rebindable syntax expects a function with"
1069
1070 go rho_ty (SynType the_ty)
1071 = do { wrap <- tcSubTypePat orig GenSigCtxt the_ty rho_ty
1072 ; result <- thing_inside [] []
1073 ; return (result, wrap) }
1074
1075 -- works on "actual" types, instantiating where necessary
1076 -- See Note [tcSynArg]
1077 tcSynArgA :: CtOrigin
1078 -> TcSigmaType
1079 -> [SyntaxOpType] -- ^ argument shapes
1080 -> SyntaxOpType -- ^ result shape
1081 -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments
1082 -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
1083 -- ^ returns a wrapper to be applied to the original function,
1084 -- wrappers to be applied to arguments
1085 -- and a wrapper to be applied to the overall expression
1086 tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
1087 = do { (match_wrapper, arg_tys, res_ty)
1088 <- matchActualFunTysRho herald orig Nothing
1089 (length arg_shapes) sigma_ty
1090 -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
1091 ; ((result, res_wrapper), arg_wrappers)
1092 <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
1093 tc_syn_arg res_ty res_shape $ \ res_results ->
1094 thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)
1095 ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
1096 where
1097 herald = text "This rebindable syntax expects a function with"
1098
1099 tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
1100 -> ([TcSigmaType] -> [Mult] -> TcM a)
1101 -> TcM (a, [HsWrapper])
1102 -- the wrappers are for arguments
1103 tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
1104 = do { ((result, arg_wraps), arg_wrap)
1105 <- tcSynArgE orig arg_ty arg_shape $ \ arg1_results arg1_mults ->
1106 tc_syn_args_e arg_tys arg_shapes $ \ args_results args_mults ->
1107 thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)
1108 ; return (result, arg_wrap : arg_wraps) }
1109 tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] []
1110
1111 tc_syn_arg :: TcSigmaType -> SyntaxOpType
1112 -> ([TcSigmaType] -> TcM a)
1113 -> TcM (a, HsWrapper)
1114 -- the wrapper applies to the overall result
1115 tc_syn_arg res_ty SynAny thing_inside
1116 = do { result <- thing_inside [res_ty]
1117 ; return (result, idHsWrapper) }
1118 tc_syn_arg res_ty SynRho thing_inside
1119 = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
1120 -- inst_wrap :: res_ty "->" rho_ty
1121 ; result <- thing_inside [rho_ty]
1122 ; return (result, inst_wrap) }
1123 tc_syn_arg res_ty SynList thing_inside
1124 = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
1125 -- inst_wrap :: res_ty "->" rho_ty
1126 ; (list_co, elt_ty) <- matchExpectedListTy rho_ty
1127 -- list_co :: [elt_ty] ~N rho_ty
1128 ; result <- thing_inside [elt_ty]
1129 ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
1130 tc_syn_arg _ (SynFun {}) _
1131 = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
1132 tc_syn_arg res_ty (SynType the_ty) thing_inside
1133 = do { wrap <- tcSubType orig GenSigCtxt res_ty the_ty
1134 ; result <- thing_inside []
1135 ; return (result, wrap) }
1136
1137 {-
1138 Note [Push result type in]
1139 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1140 Unify with expected result before type-checking the args so that the
1141 info from res_ty percolates to args. This is when we might detect a
1142 too-few args situation. (One can think of cases when the opposite
1143 order would give a better error message.)
1144 experimenting with putting this first.
1145
1146 Here's an example where it actually makes a real difference
1147
1148 class C t a b | t a -> b
1149 instance C Char a Bool
1150
1151 data P t a = forall b. (C t a b) => MkP b
1152 data Q t = MkQ (forall a. P t a)
1153
1154 f1, f2 :: Q Char;
1155 f1 = MkQ (MkP True)
1156 f2 = MkQ (MkP True :: forall a. P Char a)
1157
1158 With the change, f1 will type-check, because the 'Char' info from
1159 the signature is propagated into MkQ's argument. With the check
1160 in the other order, the extra signature in f2 is reqd.
1161 -}
1162
1163 {- *********************************************************************
1164 * *
1165 Record bindings
1166 * *
1167 ********************************************************************* -}
1168
1169 getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
1170 -- These tyvars must not change across the updates
1171 getFixedTyVars upd_fld_occs univ_tvs cons
1172 = mkVarSet [tv1 | con <- cons
1173 , let (u_tvs, _, eqspec, prov_theta
1174 , req_theta, arg_tys, _)
1175 = conLikeFullSig con
1176 theta = eqSpecPreds eqspec
1177 ++ prov_theta
1178 ++ req_theta
1179 flds = conLikeFieldLabels con
1180 fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys)
1181 -- fixed_tys: See Note [Type of a record update]
1182 `unionVarSet` tyCoVarsOfTypes theta
1183 -- Universally-quantified tyvars that
1184 -- appear in any of the *implicit*
1185 -- arguments to the constructor are fixed
1186 -- See Note [Implicit type sharing]
1187
1188 fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
1189 , not (flLabel fl `elem` upd_fld_occs)]
1190 , (tv1,tv) <- univ_tvs `zip` u_tvs
1191 , tv `elemVarSet` fixed_tvs ]
1192
1193 -- Disambiguate the fields in a record update.
1194 -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
1195 disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
1196 -> [LHsRecUpdField GhcRn] -> ExpRhoType
1197 -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
1198 disambiguateRecordBinds record_expr record_rho rbnds res_ty
1199 -- Are all the fields unambiguous?
1200 = case mapM isUnambiguous rbnds of
1201 -- If so, just skip to looking up the Ids
1202 -- Always the case if DuplicateRecordFields is off
1203 Just rbnds' -> mapM lookupSelector rbnds'
1204 Nothing -> -- If not, try to identify a single parent
1205 do { fam_inst_envs <- tcGetFamInstEnvs
1206 -- Look up the possible parents for each field
1207 ; rbnds_with_parents <- getUpdFieldsParents
1208 ; let possible_parents = map (map fst . snd) rbnds_with_parents
1209 -- Identify a single parent
1210 ; p <- identifyParent fam_inst_envs possible_parents
1211 -- Pick the right selector with that parent for each field
1212 ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
1213 where
1214 -- Extract the selector name of a field update if it is unambiguous
1215 isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
1216 isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of
1217 Unambiguous sel_name _ -> Just (x, sel_name)
1218 Ambiguous{} -> Nothing
1219
1220 -- Look up the possible parents and selector GREs for each field
1221 getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
1222 , [(RecSelParent, GlobalRdrElt)])]
1223 getUpdFieldsParents
1224 = fmap (zip rbnds) $ mapM
1225 (lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc)
1226 rbnds
1227
1228 -- Given a the lists of possible parents for each field,
1229 -- identify a single parent
1230 identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
1231 identifyParent fam_inst_envs possible_parents
1232 = case foldr1 intersect possible_parents of
1233 -- No parents for all fields: record update is ill-typed
1234 [] -> failWithTc (TcRnNoPossibleParentForFields rbnds)
1235
1236 -- Exactly one datatype with all the fields: use that
1237 [p] -> return p
1238
1239 -- Multiple possible parents: try harder to disambiguate
1240 -- Can we get a parent TyCon from the pushed-in type?
1241 _:_ | Just p <- tyConOfET fam_inst_envs res_ty ->
1242 do { reportAmbiguousField p
1243 ; return (RecSelData p) }
1244
1245 -- Does the expression being updated have a type signature?
1246 -- If so, try to extract a parent TyCon from it
1247 | Just {} <- obviousSig (unLoc record_expr)
1248 , Just tc <- tyConOf fam_inst_envs record_rho
1249 -> do { reportAmbiguousField tc
1250 ; return (RecSelData tc) }
1251
1252 -- Nothing else we can try...
1253 _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds)
1254
1255 -- Make a field unambiguous by choosing the given parent.
1256 -- Emits an error if the field cannot have that parent,
1257 -- e.g. if the user writes
1258 -- r { x = e } :: T
1259 -- where T does not have field x.
1260 pickParent :: RecSelParent
1261 -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
1262 -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
1263 pickParent p (upd, xs)
1264 = case lookup p xs of
1265 -- Phew! The parent is valid for this field.
1266 -- Previously ambiguous fields must be marked as
1267 -- used now that we know which one is meant, but
1268 -- unambiguous ones shouldn't be recorded again
1269 -- (giving duplicate deprecation warnings).
1270 Just gre -> do { unless (null (tail xs)) $ do
1271 let L loc _ = hfbLHS (unLoc upd)
1272 setSrcSpanA loc $ addUsedGRE True gre
1273 ; lookupSelector (upd, greMangledName gre) }
1274 -- The field doesn't belong to this parent, so report
1275 -- an error but keep going through all the fields
1276 Nothing -> do { addErrTc (fieldNotInType p
1277 (unLoc (hsRecUpdFieldRdr (unLoc upd))))
1278 ; lookupSelector (upd, greMangledName (snd (head xs))) }
1279
1280 -- Given a (field update, selector name) pair, look up the
1281 -- selector to give a field update with an unambiguous Id
1282 lookupSelector :: (LHsRecUpdField GhcRn, Name)
1283 -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
1284 lookupSelector (L l upd, n)
1285 = do { i <- tcLookupId n
1286 ; let L loc af = hfbLHS upd
1287 lbl = rdrNameAmbiguousFieldOcc af
1288 ; return $ L l HsFieldBind
1289 { hfbAnn = hfbAnn upd
1290 , hfbLHS
1291 = L (l2l loc) (Unambiguous i (L (l2l loc) lbl))
1292 , hfbRHS = hfbRHS upd
1293 , hfbPun = hfbPun upd
1294 }
1295 }
1296
1297 -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head
1298 reportAmbiguousField :: TyCon -> TcM ()
1299 reportAmbiguousField parent_type =
1300 setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type
1301 where
1302 rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }
1303 loc = getLocA (head rbnds)
1304
1305 {-
1306 Game plan for record bindings
1307 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1308 1. Find the TyCon for the bindings, from the first field label.
1309
1310 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1311
1312 For each binding field = value
1313
1314 3. Instantiate the field type (from the field label) using the type
1315 envt from step 2.
1316
1317 4 Type check the value using tcCheckPolyExprNC (in tcRecordField),
1318 passing the field type as the expected argument type.
1319
1320 This extends OK when the field types are universally quantified.
1321 -}
1322
1323 tcRecordBinds
1324 :: ConLike
1325 -> [TcType] -- Expected type for each field
1326 -> HsRecordBinds GhcRn
1327 -> TcM (HsRecordBinds GhcTc)
1328
1329 tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
1330 = do { mb_binds <- mapM do_bind rbinds
1331 ; return (HsRecFields (catMaybes mb_binds) dd) }
1332 where
1333 fields = map flSelector $ conLikeFieldLabels con_like
1334 flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
1335
1336 do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
1337 -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
1338 do_bind (L l fld@(HsFieldBind { hfbLHS = f
1339 , hfbRHS = rhs }))
1340
1341 = do { mb <- tcRecordField con_like flds_w_tys f rhs
1342 ; case mb of
1343 Nothing -> return Nothing
1344 -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f'
1345 -- , hfbRHS = rhs' }))) }
1346 Just (f', rhs') -> return (Just (L l (HsFieldBind
1347 { hfbAnn = hfbAnn fld
1348 , hfbLHS = f'
1349 , hfbRHS = rhs'
1350 , hfbPun = hfbPun fld}))) }
1351
1352 tcRecordUpd
1353 :: ConLike
1354 -> [TcType] -- Expected type for each field
1355 -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
1356 -> TcM [LHsRecUpdField GhcTc]
1357
1358 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
1359 where
1360 fields = map flSelector $ conLikeFieldLabels con_like
1361 flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys
1362
1363 do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
1364 -> TcM (Maybe (LHsRecUpdField GhcTc))
1365 do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af
1366 , hfbRHS = rhs }))
1367 = do { let lbl = rdrNameAmbiguousFieldOcc af
1368 sel_id = selectorAmbiguousFieldOcc af
1369 f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl))
1370 ; mb <- tcRecordField con_like flds_w_tys f rhs
1371 ; case mb of
1372 Nothing -> return Nothing
1373 Just (f', rhs') ->
1374 return (Just
1375 (L l (fld { hfbLHS
1376 = L loc (Unambiguous
1377 (foExt (unLoc f'))
1378 (L (l2l loc) lbl))
1379 , hfbRHS = rhs' }))) }
1380
1381 tcRecordField :: ConLike -> Assoc Name Type
1382 -> LFieldOcc GhcRn -> LHsExpr GhcRn
1383 -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
1384 tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
1385 | Just field_ty <- assocMaybe flds_w_tys sel_name
1386 = addErrCtxt (fieldCtxt field_lbl) $
1387 do { rhs' <- tcCheckPolyExprNC rhs field_ty
1388 ; _concrete_ev <-
1389 hasFixedRuntimeRep (FRRRecordUpdate (unLoc lbl) (unLoc rhs))
1390 field_ty
1391 ; let field_id = mkUserLocal (nameOccName sel_name)
1392 (nameUnique sel_name)
1393 Many field_ty (locA loc)
1394 -- Yuk: the field_id has the *unique* of the selector Id
1395 -- (so we can find it easily)
1396 -- but is a LocalId with the appropriate type of the RHS
1397 -- (so the desugarer knows the type of local binder to make)
1398 ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
1399 | otherwise
1400 = do { addErrTc (badFieldCon con_like field_lbl)
1401 ; return Nothing }
1402 where
1403 field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
1404
1405
1406 checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
1407 checkMissingFields con_like rbinds arg_tys
1408 | null field_labels -- Not declared as a record;
1409 -- But C{} is still valid if no strict fields
1410 = if any isBanged field_strs then
1411 -- Illegal if any arg is strict
1412 addErrTc (TcRnMissingStrictFields con_like [])
1413 else do
1414 when (notNull field_strs && null field_labels) $ do
1415 let msg = TcRnMissingFields con_like []
1416 (diagnosticTc True msg)
1417
1418 | otherwise = do -- A record
1419 unless (null missing_s_fields) $ do
1420 fs <- zonk_fields missing_s_fields
1421 -- It is an error to omit a strict field, because
1422 -- we can't substitute it with (error "Missing field f")
1423 addErrTc (TcRnMissingStrictFields con_like fs)
1424
1425 warn <- woptM Opt_WarnMissingFields
1426 when (warn && notNull missing_ns_fields) $ do
1427 fs <- zonk_fields missing_ns_fields
1428 -- It is not an error (though we may want) to omit a
1429 -- lazy field, because we can always use
1430 -- (error "Missing field f") instead.
1431 let msg = TcRnMissingFields con_like fs
1432 diagnosticTc True msg
1433
1434 where
1435 -- we zonk the fields to get better types in error messages (#18869)
1436 zonk_fields fs = forM fs $ \(str,ty) -> do
1437 ty' <- zonkTcType ty
1438 return (str,ty')
1439 missing_s_fields
1440 = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
1441 isBanged str,
1442 not (fl `elemField` field_names_used)
1443 ]
1444 missing_ns_fields
1445 = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
1446 not (isBanged str),
1447 not (fl `elemField` field_names_used)
1448 ]
1449
1450 field_names_used = hsRecFields rbinds
1451 field_labels = conLikeFieldLabels con_like
1452
1453 field_info = zip3 field_labels field_strs arg_tys
1454
1455 field_strs = conLikeImplBangs con_like
1456
1457 fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
1458
1459 {-
1460 ************************************************************************
1461 * *
1462 \subsection{Errors and contexts}
1463 * *
1464 ************************************************************************
1465
1466 Boring and alphabetical:
1467 -}
1468
1469 fieldCtxt :: FieldLabelString -> SDoc
1470 fieldCtxt field_name
1471 = text "In the" <+> quotes (ppr field_name) <+> text "field of a record"
1472
1473 badFieldsUpd
1474 :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
1475 -- Field names that don't belong to a single datacon
1476 -> [ConLike] -- Data cons of the type which the first field name belongs to
1477 -> TcRnMessage
1478 badFieldsUpd rbinds data_cons
1479 = TcRnNoConstructorHasAllFields conflictingFields
1480 -- See Note [Finding the conflicting fields]
1481 where
1482 -- A (preferably small) set of fields such that no constructor contains
1483 -- all of them. See Note [Finding the conflicting fields]
1484 conflictingFields = case nonMembers of
1485 -- nonMember belongs to a different type.
1486 (nonMember, _) : _ -> [aMember, nonMember]
1487 [] -> let
1488 -- All of rbinds belong to one type. In this case, repeatedly add
1489 -- a field to the set until no constructor contains the set.
1490
1491 -- Each field, together with a list indicating which constructors
1492 -- have all the fields so far.
1493 growingSets :: [(FieldLabelString, [Bool])]
1494 growingSets = scanl1 combine membership
1495 combine (_, setMem) (field, fldMem)
1496 = (field, zipWith (&&) setMem fldMem)
1497 in
1498 -- Fields that don't change the membership status of the set
1499 -- are redundant and can be dropped.
1500 map (fst . head) $ groupBy ((==) `on` snd) growingSets
1501
1502 aMember = assert (not (null members) ) fst (head members)
1503 (members, nonMembers) = partition (or . snd) membership
1504
1505 -- For each field, which constructors contain the field?
1506 membership :: [(FieldLabelString, [Bool])]
1507 membership = sortMembership $
1508 map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $
1509 map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds
1510
1511 fieldLabelSets :: [UniqSet FieldLabelString]
1512 fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons
1513
1514 -- Sort in order of increasing number of True, so that a smaller
1515 -- conflicting set can be found.
1516 sortMembership =
1517 map snd .
1518 sortBy (compare `on` fst) .
1519 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
1520
1521 countTrue = count id
1522
1523 {-
1524 Note [Finding the conflicting fields]
1525 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1526 Suppose we have
1527 data A = A {a0, a1 :: Int}
1528 | B {b0, b1 :: Int}
1529 and we see a record update
1530 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
1531 Then we'd like to find the smallest subset of fields that no
1532 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
1533 We don't really want to report that no constructor has all of
1534 {a0,a1,b0,b1}, because when there are hundreds of fields it's
1535 hard to see what was really wrong.
1536
1537 We may need more than two fields, though; eg
1538 data T = A { x,y :: Int, v::Int }
1539 | B { y,z :: Int, v::Int }
1540 | C { z,x :: Int, v::Int }
1541 with update
1542 r { x=e1, y=e2, z=e3 }, we
1543
1544 Finding the smallest subset is hard, so the code here makes
1545 a decent stab, no more. See #7989.
1546 -}
1547
1548 mixedSelectors :: [Id] -> [Id] -> TcRnMessage
1549 mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
1550 = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels
1551 where
1552 RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
1553 RecSelData rep_dc = recordSelectorTyCon dc_rep_id
1554 mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists"
1555
1556 {-
1557 ************************************************************************
1558 * *
1559 \subsection{Static Pointers}
1560 * *
1561 ************************************************************************
1562 -}
1563
1564 -- | Checks if the given name is closed and emits an error if not.
1565 --
1566 -- See Note [Not-closed error messages].
1567 checkClosedInStaticForm :: Name -> TcM ()
1568 checkClosedInStaticForm name = do
1569 type_env <- getLclTypeEnv
1570 case checkClosed type_env name of
1571 Nothing -> return ()
1572 Just reason -> addErrTc $ explain name reason
1573 where
1574 -- See Note [Checking closedness].
1575 checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
1576 checkClosed type_env n = checkLoop type_env (unitNameSet n) n
1577
1578 checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
1579 checkLoop type_env visited n =
1580 -- The @visited@ set is an accumulating parameter that contains the set of
1581 -- visited nodes, so we avoid repeating cycles in the traversal.
1582 case lookupNameEnv type_env n of
1583 Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
1584 ClosedLet -> Nothing
1585 NotLetBound -> Just NotLetBoundReason
1586 NonClosedLet fvs type_closed -> listToMaybe $
1587 -- Look for a non-closed variable in fvs
1588 [ NotClosed n' reason
1589 | n' <- nameSetElemsStable fvs
1590 , not (elemNameSet n' visited)
1591 , Just reason <- [checkLoop type_env (extendNameSet visited n') n']
1592 ] ++
1593 if type_closed then
1594 []
1595 else
1596 -- We consider non-let-bound variables easier to figure out than
1597 -- non-closed types, so we report non-closed types to the user
1598 -- only if we cannot spot the former.
1599 [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
1600 -- The binding is closed.
1601 _ -> Nothing
1602
1603 -- Converts a reason into a human-readable sentence.
1604 --
1605 -- @explain name reason@ starts with
1606 --
1607 -- "<name> is used in a static form but it is not closed because it"
1608 --
1609 -- and then follows a list of causes. For each id in the path, the text
1610 --
1611 -- "uses <id> which"
1612 --
1613 -- is appended, yielding something like
1614 --
1615 -- "uses <id> which uses <id1> which uses <id2> which"
1616 --
1617 -- until the end of the path is reached, which is reported as either
1618 --
1619 -- "is not let-bound"
1620 --
1621 -- when the final node is not let-bound, or
1622 --
1623 -- "has a non-closed type because it contains the type variables:
1624 -- v1, v2, v3"
1625 --
1626 -- when the final node has a non-closed type.
1627 --
1628 explain :: Name -> NotClosedReason -> TcRnMessage
1629 explain = TcRnStaticFormNotClosed
1630
1631 -- Note [Not-closed error messages]
1632 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1633 --
1634 -- When variables in a static form are not closed, we go through the trouble
1635 -- of explaining why they aren't.
1636 --
1637 -- Thus, the following program
1638 --
1639 -- > {-# LANGUAGE StaticPointers #-}
1640 -- > module M where
1641 -- >
1642 -- > f x = static g
1643 -- > where
1644 -- > g = h
1645 -- > h = x
1646 --
1647 -- produces the error
1648 --
1649 -- 'g' is used in a static form but it is not closed because it
1650 -- uses 'h' which uses 'x' which is not let-bound.
1651 --
1652 -- And a program like
1653 --
1654 -- > {-# LANGUAGE StaticPointers #-}
1655 -- > module M where
1656 -- >
1657 -- > import Data.Typeable
1658 -- > import GHC.StaticPtr
1659 -- >
1660 -- > f :: Typeable a => a -> StaticPtr TypeRep
1661 -- > f x = const (static (g undefined)) (h x)
1662 -- > where
1663 -- > g = h
1664 -- > h = typeOf
1665 --
1666 -- produces the error
1667 --
1668 -- 'g' is used in a static form but it is not closed because it
1669 -- uses 'h' which has a non-closed type because it contains the
1670 -- type variables: 'a'
1671 --
1672
1673 -- Note [Checking closedness]
1674 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
1675 --
1676 -- @checkClosed@ checks if a binding is closed and returns a reason if it is
1677 -- not.
1678 --
1679 -- The bindings define a graph where the nodes are ids, and there is an edge
1680 -- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
1681 -- variables.
1682 --
1683 -- When @n@ is not closed, it has to exist in the graph some node reachable
1684 -- from @n@ that it is not a let-bound variable or that it has a non-closed
1685 -- type. Thus, the "reason" is a path from @n@ to this offending node.
1686 --
1687 -- When @n@ is not closed, we traverse the graph reachable from @n@ to build
1688 -- the reason.
1689 --