Some bugfixing
[ghc.git] / compiler / typecheck / TcExpr.hs
1 {-
2 c%
3 (c) The University of Glasgow 2006
4 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5
6 \section[TcExpr]{Typecheck an expression}
7 -}
8
9 {-# LANGUAGE CPP #-}
10
11 module TcExpr ( tcPolyExpr, tcPolyExprNC,
12 tcInferSigma, tcInferSigmaNC,
13 tcSyntaxOp, tcCheckId,
14 addExprErrCtxt, tcSkolemiseExpr ) where
15
16 #include "HsVersions.h"
17
18 import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
19 import THNames( liftStringName, liftName )
20
21 import HsSyn
22 import TcHsSyn
23 import TcRnMonad
24 import TcUnify
25 import BasicTypes
26 import Inst
27 import TcBinds
28 import FamInst ( tcGetFamInstEnvs, tcLookupDataFamInst )
29 import TcEnv
30 import TcArrows
31 import TcMatches
32 import TcHsType
33 import TcPatSyn( tcPatSynBuilderOcc )
34 import TcPat
35 import TcMType
36 import TcType
37 import DsMonad
38 import Id
39 import ConLike
40 import DataCon
41 import Name
42 import TyCon
43 import Type
44 import TcEvidence
45 import Var
46 import VarSet
47 import VarEnv
48 import TysWiredIn
49 import TysPrim( intPrimTy, addrPrimTy )
50 import PrimOp( tagToEnumKey )
51 import PrelNames
52 import DynFlags
53 import SrcLoc
54 import Util hiding ( Direction ) -- TODO (RAE): Remove "hiding"
55 import ListSetOps
56 import Maybes
57 import ErrUtils
58 import Outputable
59 import FastString
60 import Control.Monad
61 import Class(classTyCon)
62 import Data.Function
63 import Data.List
64 import qualified Data.Set as Set
65
66 {-
67 ************************************************************************
68 * *
69 \subsection{Main wrappers}
70 * *
71 ************************************************************************
72 -}
73
74 tcPolyExpr, tcPolyExprNC
75 :: LHsExpr Name -- Expression to type check
76 -> TcSigmaType -- Expected type (could be a polytype)
77 -> TcM (LHsExpr TcId) -- Generalised expr with expected type
78
79 -- tcPolyExpr is a convenient place (frequent but not too frequent)
80 -- place to add context information.
81 -- The NC version does not do so, usually because the caller wants
82 -- to do so himself.
83
84 tcPolyExpr expr res_ty
85 = addExprErrCtxt expr $
86 do { traceTc "tcPolyExpr" (ppr res_ty); tcPolyExprNC expr res_ty }
87
88 tcPolyExprNC (L loc expr) res_ty
89 = setSrcSpan loc $
90 do { traceTc "tcPolyExprNC" (ppr res_ty)
91 ; expr' <- tcExpr Down expr res_ty
92 ; return (L loc expr') }
93
94 ---------------
95 tcInferSigma, tcInferSigmaNC :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)
96 -- Infer an *sigma*-type. This is, in effect, a special case
97 -- for ids and partial applications, so that if
98 -- f :: Int -> forall b. (forall a. a -> a -> b) -> b
99 -- then we can infer
100 -- f 3 :: forall b. (forall a. a -> a -> b) -> b
101 -- And that in turn is useful
102 -- (a) for the function part of any application (see tcApp)
103 -- (b) for the special rule for '$'
104 tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)
105
106 tcInferSigmaNC (L loc expr)
107 = setSrcSpan loc $
108 do { (expr', sigma) <- tcInfer (tcExpr Up expr)
109 ; return (L loc expr', sigma) }
110
111 tcUnboundId :: OccName -> TcSigmaType -> TcM (HsExpr TcId)
112 -- Typechedk an occurrence of an unbound Id
113 --
114 -- Some of these started life as a true hole "_". Others might simply
115 -- be variables that accidentally have no binding site
116 --
117 -- We turn all of them into HsVar, since HsUnboundVar can't contain an
118 -- Id; and indeed the evidence for the CHoleCan does bind it, so it's
119 -- not unbound any more!
120 tcUnboundId occ res_ty
121 = do { ty <- newFlexiTyVarTy liftedTypeKind
122 ; name <- newSysName occ
123 ; let ev = mkLocalId name ty
124 ; loc <- getCtLocM HoleOrigin
125 ; let can = CHoleCan { cc_ev = CtWanted ty ev loc, cc_occ = occ
126 , cc_hole = ExprHole }
127 ; emitInsoluble can
128 ; tcWrapResult (HsVar ev) ty res_ty }
129
130 {-
131 ************************************************************************
132 * *
133 tcExpr: the main expression typechecker
134 * *
135 ************************************************************************
136 -}
137
138 -- | This controls the direction of type-checking, along the lines of
139 -- "Practical Type Inference for Arbitrary-Rank Types" (JFP'07)
140 data Direction = Down -- ^ check a type
141 | Up -- ^ infer a type; this means that res_ty is skolemised
142 -- and the result is checked against it
143
144 tcExpr :: Direction -> HsExpr Name -> TcSigmaType -> TcM (HsExpr TcId)
145 tcExpr Up (HsVar name) res_ty = tcCheckId name res_ty
146 tcExpr Up (HsUnboundVar v) res_ty = tcUnboundId v res_ty
147
148 tcExpr Up (HsApp e1 e2) res_ty
149 = do { (wrap, fun, args) <- tcApp Nothing AppOrigin e1 [e2] res_ty
150 ; return (mkHsWrap wrap $ unLoc $ foldl mkHsApp fun args) }
151
152 tcExpr Up (HsLit lit) res_ty = do { let lit_ty = hsLitType lit
153 ; tcWrapResult (HsLit lit) lit_ty res_ty }
154
155 tcExpr _ (HsPar expr) res_ty = do { expr' <- tcPolyExprNC expr res_ty
156 ; return (HsPar expr') }
157
158 tcExpr _ (HsSCC src lbl expr) res_ty
159 = do { expr' <- tcPolyExpr expr res_ty
160 ; return (HsSCC src lbl expr') }
161
162 tcExpr _ (HsTickPragma src info expr) res_ty
163 = do { expr' <- tcPolyExpr expr res_ty
164 ; return (HsTickPragma src info expr') }
165
166 tcExpr _ (HsCoreAnn src lbl expr) res_ty
167 = do { expr' <- tcPolyExpr expr res_ty
168 ; return (HsCoreAnn src lbl expr') }
169
170 tcExpr _ (HsOverLit lit) res_ty
171 = do { (wrap, lit') <- newOverloadedLit Expected lit res_ty
172 ; return (mkHsWrap wrap $ HsOverLit lit') }
173
174 tcExpr _ (NegApp expr neg_expr) res_ty
175 = do { neg_expr' <- tcSyntaxOp NegateOrigin neg_expr
176 (mkFunTy res_ty res_ty)
177 ; expr' <- tcPolyExpr expr res_ty
178 ; return (NegApp expr' neg_expr') }
179
180 tcExpr Up (HsIPVar x) res_ty
181 = do { let origin = IPOccOrigin x
182 ; ipClass <- tcLookupClass ipClassName
183 {- Implicit parameters must have a *tau-type* not a
184 type scheme. We enforce this by creating a fresh
185 type variable as its type. (Because res_ty may not
186 be a tau-type.) -}
187 ; ip_ty <- newFlexiTyVarTy openTypeKind
188 ; let ip_name = mkStrLitTy (hsIPNameFS x)
189 ; ip_var <- emitWanted origin (mkClassPred ipClass [ip_name, ip_ty])
190 ; tcWrapResult (fromDict ipClass ip_name ip_ty (HsVar ip_var)) ip_ty res_ty }
191 where
192 -- Coerces a dictionary for `IP "x" t` into `t`.
193 fromDict ipClass x ty = HsWrap $ mkWpCast $ TcCoercion $
194 unwrapIP $ mkClassPred ipClass [x,ty]
195
196 tcExpr _ (HsLam match) res_ty
197 = do { (co_fn, match') <- tcMatchLambda match res_ty
198 ; return (mkHsWrap co_fn (HsLam match')) }
199
200 tcExpr _ e@(HsLamCase _ matches) res_ty
201 -- the tcSkolemiseExpr call is necessary because matchExpectedFunTys
202 -- won't skolemise to uncover an arrow
203 = tcSkolemiseExpr SkolemiseTop res_ty $ \ res_ty ->
204 do {(wrap, [arg_ty], body_ty) <-
205 matchExpectedFunTys Expected msg 1 res_ty
206 ; matches' <- tcMatchesCase match_ctxt arg_ty matches body_ty
207 ; return $ mkHsWrap wrap $ HsLamCase arg_ty matches' }
208 where msg = sep [ ptext (sLit "The function") <+> quotes (ppr e)
209 , ptext (sLit "requires")]
210 match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
211
212 tcExpr Up (ExprWithTySig expr sig_ty wcs) res_ty
213 = do { nwc_tvs <- mapM newWildcardVarMetaKind wcs
214 ; tcExtendTyVarEnv nwc_tvs $ do {
215 sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
216 ; (gen_fn, expr')
217 <- tcSkolemise SkolemiseTop ExprSigCtxt sig_tc_ty $
218 \ skol_tvs res_ty ->
219
220 -- Remember to extend the lexical type-variable environment;
221 -- indeed, this is the only reason we skolemise here at all
222 tcExtendTyVarEnv2
223 [(n,tv) | (Just n, tv) <- findScopedTyVars sig_ty sig_tc_ty skol_tvs] $
224
225 tcPolyExprNC expr res_ty
226
227 ; let inner_expr = ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty
228
229 ; addErrCtxt (pprSigCtxt ExprSigCtxt empty (ppr sig_ty)) $
230 emitWildcardHoleConstraints (zip wcs nwc_tvs)
231 ; tcWrapResult inner_expr sig_tc_ty res_ty } }
232
233 tcExpr _ (HsType ty) _
234 = failWithTc (text "Can't handle type argument:" <+> ppr ty)
235 -- This is the syntax for type applications that I was planning
236 -- but there are difficulties (e.g. what order for type args)
237 -- so it's not enabled yet.
238 -- Can't eliminate it altogether from the parser, because the
239 -- same parser parses *patterns*.
240
241 {-
242 ************************************************************************
243 * *
244 Infix operators and sections
245 * *
246 ************************************************************************
247
248 Note [Left sections]
249 ~~~~~~~~~~~~~~~~~~~~
250 Left sections, like (4 *), are equivalent to
251 \ x -> (*) 4 x,
252 or, if PostfixOperators is enabled, just
253 (*) 4
254 With PostfixOperators we don't actually require the function to take
255 two arguments at all. For example, (x `not`) means (not x); you get
256 postfix operators! Not Haskell 98, but it's less work and kind of
257 useful.
258
259 Note [Typing rule for ($)]
260 ~~~~~~~~~~~~~~~~~~~~~~~~~~
261 People write
262 runST $ blah
263 so much, where
264 runST :: (forall s. ST s a) -> a
265 that I have finally given in and written a special type-checking
266 rule just for saturated appliations of ($).
267 * Infer the type of the first argument
268 * Decompose it; should be of form (arg2_ty -> res_ty),
269 where arg2_ty might be a polytype
270 * Use arg2_ty to typecheck arg2
271
272 Note [Typing rule for seq]
273 ~~~~~~~~~~~~~~~~~~~~~~~~~~
274 We want to allow
275 x `seq` (# p,q #)
276 which suggests this type for seq:
277 seq :: forall (a:*) (b:??). a -> b -> b,
278 with (b:??) meaning that be can be instantiated with an unboxed tuple.
279 But that's ill-kinded! Function arguments can't be unboxed tuples.
280 And indeed, you could not expect to do this with a partially-applied
281 'seq'; it's only going to work when it's fully applied. so it turns
282 into
283 case x of _ -> (# p,q #)
284
285 For a while I slid by by giving 'seq' an ill-kinded type, but then
286 the simplifier eta-reduced an application of seq and Lint blew up
287 with a kind error. It seems more uniform to treat 'seq' as if it
288 were a language construct.
289
290 See also Note [seqId magic] in MkId
291 -}
292
293 tcExpr _ (OpApp arg1 op fix arg2) res_ty
294 | (L loc (HsVar op_name)) <- op
295 , op_name `hasKey` seqIdKey -- Note [Typing rule for seq]
296 = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind
297 ; let arg2_ty = res_ty
298 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
299 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
300 ; op_id <- tcLookupId op_name
301 ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) (HsVar op_id))
302 ; return $ OpApp arg1' op' fix arg2' }
303
304 | (L loc (HsVar op_name)) <- op
305 , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)]
306 = do { traceTc "Application rule" (ppr op)
307 ; (arg1', arg1_ty) <- tcInferSigma arg1
308
309 ; let doc = ptext (sLit "The first argument of ($) takes")
310 ; (wrap_arg1, [arg2_sigma], op_res_ty) <-
311 matchExpectedFunTys (Actual AppOrigin) doc 1 arg1_ty
312
313 -- We have (arg1 $ arg2)
314 -- So: arg1_ty = arg2_ty -> op_res_ty
315 -- where arg2_sigma maybe polymorphic; that's the point
316
317 ; arg2' <- tcArg op (arg2, arg2_sigma, 2)
318
319 -- Make sure that the argument type has kind '*'
320 -- ($) :: forall (a2:*) (r:Open). (a2->r) -> a2 -> r
321 -- Eg we do not want to allow (D# $ 4.0#) Trac #5570
322 -- (which gives a seg fault)
323 -- We do this by unifying with a MetaTv; but of course
324 -- it must allow foralls in the type it unifies with (hence ReturnTv)!
325 --
326 -- The *result* type can have any kind (Trac #8739),
327 -- so we don't need to check anything for that
328 ; a2_tv <- newReturnTyVar liftedTypeKind
329 ; let a2_ty = mkTyVarTy a2_tv
330 ; co_a <- unifyType arg2_sigma a2_ty -- arg2_sigma ~N a2_ty
331
332 ; wrap_res <- tcSubTypeHR op_res_ty res_ty -- op_res -> res
333
334 ; op_id <- tcLookupId op_name
335 ; let op' = L loc (HsWrap (mkWpTyApps [a2_ty, res_ty]) (HsVar op_id))
336 -- arg1' :: arg1_ty
337 -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)
338 -- wrap_res :: op_res_ty "->" res_ty
339 -- co_a :: arg2_sigma ~N a2_ty
340 -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty
341
342 -- wrap1 :: arg1_ty "->" (a2_ty -> res_ty)
343 wrap1 = mkWpFun (coToHsWrapper (mkTcSymCo co_a))
344 wrap_res a2_ty res_ty <.> wrap_arg1
345
346 -- arg2' :: arg2_sigma
347 -- wrap_a :: a2_ty "->" arg2_sigma
348 ; return $
349 OpApp (mkLHsWrap wrap1 arg1')
350 op' fix
351 (mkLHsWrapCo co_a arg2') }
352
353 tcExpr Up (OpApp arg1 op fix arg2) res_ty
354 = do { traceTc "Non Application rule" (ppr op)
355 ; (wrap, op', [arg1', arg2']) <- tcApp (Just $ mk_op_msg op) AppOrigin
356 op [arg1, arg2] res_ty
357 ; return $ mkHsWrap wrap $ OpApp arg1' op' fix arg2' }
358
359 -- Right sections, equivalent to \ x -> x `op` expr, or
360 -- \ x -> op x expr
361
362 tcExpr Up (SectionR op arg2) res_ty
363 = do { (op', op_ty) <- tcInferFun op
364 ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty) <-
365 matchExpectedFunTys (Actual SectionOrigin) (mk_op_msg op) 2 op_ty
366 ; wrap_res <- tcSubTypeHR (mkFunTy arg1_ty op_res_ty) res_ty
367 ; arg2' <- tcArg op (arg2, arg2_ty, 2)
368 ; return $ mkHsWrap wrap_res $
369 SectionR (mkLHsWrap wrap_fun op') arg2' }
370
371 tcExpr Up (SectionL arg1 op) res_ty
372 = do { (op', op_ty) <- tcInferFun op
373 ; dflags <- getDynFlags -- Note [Left sections]
374 ; let n_reqd_args | xopt Opt_PostfixOperators dflags = 1
375 | otherwise = 2
376
377 ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)
378 <- matchExpectedFunTys (Actual SectionOrigin)
379 (mk_op_msg op) n_reqd_args op_ty
380 ; wrap_res <- tcSubTypeHR (mkFunTys arg_tys op_res_ty) res_ty
381 ; arg1' <- tcArg op (arg1, arg1_ty, 1)
382 ; return $ mkHsWrap wrap_res $
383 SectionL arg1' (mkLHsWrap wrap_fn op') }
384
385 tcExpr Up (ExplicitTuple tup_args boxity) res_ty
386 | all tupArgPresent tup_args
387 = do { let tup_tc = tupleTyCon boxity (length tup_args)
388 ; (wrap, arg_tys) <- matchExpectedTyConApp Expected tup_tc res_ty
389 ; tup_args1 <- tcTupArgs tup_args arg_tys
390 ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
391
392 | otherwise
393 = -- The tup_args are a mixture of Present and Missing (for tuple sections)
394 do { let kind = case boxity of { Boxed -> liftedTypeKind
395 ; Unboxed -> openTypeKind }
396 arity = length tup_args
397 tup_tc = tupleTyCon boxity arity
398
399 ; arg_tys <- newFlexiTyVarTys (tyConArity tup_tc) kind
400 ; let actual_res_ty
401 = mkFunTys [ty | (ty, L _ (Missing _)) <- arg_tys `zip` tup_args]
402 (mkTyConApp tup_tc arg_tys)
403
404 ; wrap <- tcSubTypeHR actual_res_ty res_ty
405
406 -- Handle tuple sections where
407 ; tup_args1 <- tcTupArgs tup_args arg_tys
408
409 ; return $ mkHsWrap wrap (ExplicitTuple tup_args1 boxity) }
410
411 tcExpr Up (ExplicitList _ witness exprs) res_ty
412 = case witness of
413 Nothing -> do { (wrap, elt_ty) <- matchExpectedListTy Expected res_ty
414 ; exprs' <- mapM (tc_elt elt_ty) exprs
415 ; return $ mkHsWrap wrap (ExplicitList elt_ty Nothing exprs') }
416
417 Just fln -> do { list_ty <- newFlexiTyVarTy liftedTypeKind
418 ; fln' <- tcSyntaxOp ListOrigin fln (mkFunTys [intTy, list_ty] res_ty)
419 ; (wrap, elt_ty) <- matchExpectedListTy Expected list_ty
420 ; exprs' <- mapM (tc_elt elt_ty) exprs
421 ; return $ mkHsWrap wrap (ExplicitList elt_ty (Just fln') exprs') }
422 where tc_elt elt_ty expr = tcPolyExpr expr elt_ty
423
424 tcExpr Up (ExplicitPArr _ exprs) res_ty -- maybe empty
425 = do { (wrap, elt_ty) <- matchExpectedPArrTy Expected res_ty
426 ; exprs' <- mapM (tc_elt elt_ty) exprs
427 ; return $ mkHsWrap wrap (ExplicitPArr elt_ty exprs') }
428 where
429 tc_elt elt_ty expr = tcPolyExpr expr elt_ty
430
431 {-
432 ************************************************************************
433 * *
434 Let, case, if, do
435 * *
436 ************************************************************************
437 -}
438
439 tcExpr _ (HsLet binds expr) res_ty
440 = do { (binds', expr') <- tcLocalBinds binds $
441 tcPolyExpr expr res_ty
442 ; return (HsLet binds' expr') }
443
444 tcExpr _ (HsCase scrut matches) exp_ty
445 = do { -- We used to typecheck the case alternatives first.
446 -- The case patterns tend to give good type info to use
447 -- when typechecking the scrutinee. For example
448 -- case (map f) of
449 -- (x:xs) -> ...
450 -- will report that map is applied to too few arguments
451 --
452 -- But now, in the GADT world, we need to typecheck the scrutinee
453 -- first, to get type info that may be refined in the case alternatives
454 (scrut', scrut_ty) <- tcInferSigma scrut
455
456 ; traceTc "HsCase" (ppr scrut_ty)
457 ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
458 ; return (HsCase scrut' matches') }
459 where
460 match_ctxt = MC { mc_what = CaseAlt,
461 mc_body = tcBody }
462
463 tcExpr Up (HsIf Nothing pred b1 b2) res_ty -- Ordinary 'if'
464 = do { pred' <- tcPolyExpr pred boolTy
465 ; b1' <- tcPolyExpr b1 res_ty
466 ; b2' <- tcPolyExpr b2 res_ty
467 ; return (HsIf Nothing pred' b1' b2') }
468
469 tcExpr _ (HsIf (Just fun) pred b1 b2) res_ty
470 -- Note [Rebindable syntax for if]
471 = do { (wrap, fun', [pred', b1', b2'])
472 <- tcApp (Just herald) IfOrigin (noLoc fun) [pred, b1, b2] res_ty
473 ; return $ mkHsWrap wrap $ (HsIf (Just (unLoc fun')) pred' b1' b2') }
474 where
475 herald = text "Rebindable" <+> quotes (text "if") <+> text "takes"
476
477 tcExpr _ (HsMultiIf _ alts) res_ty
478 = do { alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts
479 ; return $ HsMultiIf res_ty alts' }
480 where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
481
482 tcExpr Up (HsDo do_or_lc stmts _) res_ty
483 = tcDoStmts do_or_lc stmts res_ty
484
485 tcExpr Up (HsProc pat cmd) res_ty
486 = do { (pat', cmd', coi) <- tcProc pat cmd res_ty
487 ; return $ mkHsWrap coi (HsProc pat' cmd') }
488
489 tcExpr Up (HsStatic expr) res_ty
490 = do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName
491 ; (wrap, [expr_ty]) <-
492 matchExpectedTyConApp Expected staticPtrTyCon res_ty
493 ; (expr', lie) <- captureConstraints $
494 addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
495 2 (ppr expr)
496 ) $
497 tcPolyExprNC expr expr_ty
498 -- Require the type of the argument to be Typeable.
499 -- The evidence is not used, but asking the constraint ensures that
500 -- the current implementation is as restrictive as future versions
501 -- of the StaticPointers extension.
502 ; typeableClass <- tcLookupClass typeableClassName
503 ; _ <- emitWanted StaticOrigin $
504 mkTyConApp (classTyCon typeableClass)
505 [liftedTypeKind, expr_ty]
506 -- Insert the static form in a global list for later validation.
507 ; stWC <- tcg_static_wc <$> getGblEnv
508 ; updTcRef stWC (andWC lie)
509 ; return $ mkHsWrap wrap $ HsStatic expr'
510 }
511
512 {-
513 Note [Rebindable syntax for if]
514 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
515 The rebindable syntax for 'if' uses the most flexible possible type
516 for conditionals:
517 ifThenElse :: p -> b1 -> b2 -> res
518 to support expressions like this:
519
520 ifThenElse :: Maybe a -> (a -> b) -> b -> b
521 ifThenElse (Just a) f _ = f a
522 ifThenElse Nothing _ e = e
523
524 example :: String
525 example = if Just 2
526 then \v -> show v
527 else "No value"
528
529
530 ************************************************************************
531 * *
532 Record construction and update
533 * *
534 ************************************************************************
535 -}
536
537 tcExpr Up (RecordCon (L loc con_name) _ rbinds) res_ty
538 = do { data_con <- tcLookupDataCon con_name
539
540 -- Check for missing fields
541 ; checkMissingFields data_con rbinds
542
543 ; (con_expr, con_sigma) <- tcInferId con_name
544 ; (con_wrap, con_tau) <-
545 topInstantiate (OccurrenceOf con_name) con_sigma
546 -- a shallow instantiation should really be enough for
547 -- a data constructor.
548 ; let arity = dataConSourceArity data_con
549 (arg_tys, actual_res_ty) = tcSplitFunTysN con_tau arity
550 con_id = dataConWrapId data_con
551
552 ; res_wrap <- tcSubTypeHR actual_res_ty res_ty
553 ; rbinds' <- tcRecordBinds data_con arg_tys rbinds
554 ; return $ mkHsWrap res_wrap $
555 RecordCon (L loc con_id) (mkHsWrap con_wrap con_expr) rbinds' }
556
557 {-
558 Note [Type of a record update]
559 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
560 The main complication with RecordUpd is that we need to explicitly
561 handle the *non-updated* fields. Consider:
562
563 data T a b c = MkT1 { fa :: a, fb :: (b,c) }
564 | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
565 | MkT3 { fd :: a }
566
567 upd :: T a b c -> (b',c) -> T a b' c
568 upd t x = t { fb = x}
569
570 The result type should be (T a b' c)
571 not (T a b c), because 'b' *is not* mentioned in a non-updated field
572 not (T a b' c'), because 'c' *is* mentioned in a non-updated field
573 NB that it's not good enough to look at just one constructor; we must
574 look at them all; cf Trac #3219
575
576 After all, upd should be equivalent to:
577 upd t x = case t of
578 MkT1 p q -> MkT1 p x
579 MkT2 a b -> MkT2 p b
580 MkT3 d -> error ...
581
582 So we need to give a completely fresh type to the result record,
583 and then constrain it by the fields that are *not* updated ("p" above).
584 We call these the "fixed" type variables, and compute them in getFixedTyVars.
585
586 Note that because MkT3 doesn't contain all the fields being updated,
587 its RHS is simply an error, so it doesn't impose any type constraints.
588 Hence the use of 'relevant_cont'.
589
590 Note [Implicit type sharing]
591 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
592 We also take into account any "implicit" non-update fields. For example
593 data T a b where { MkT { f::a } :: T a a; ... }
594 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
595
596 Then consider
597 upd t x = t { f=x }
598 We infer the type
599 upd :: T a b -> a -> T a b
600 upd (t::T a b) (x::a)
601 = case t of { MkT (co:a~b) (_:a) -> MkT co x }
602 We can't give it the more general type
603 upd :: T a b -> c -> T c b
604
605 Note [Criteria for update]
606 ~~~~~~~~~~~~~~~~~~~~~~~~~~
607 We want to allow update for existentials etc, provided the updated
608 field isn't part of the existential. For example, this should be ok.
609 data T a where { MkT { f1::a, f2::b->b } :: T a }
610 f :: T a -> b -> T b
611 f t b = t { f1=b }
612
613 The criterion we use is this:
614
615 The types of the updated fields
616 mention only the universally-quantified type variables
617 of the data constructor
618
619 NB: this is not (quite) the same as being a "naughty" record selector
620 (See Note [Naughty record selectors]) in TcTyClsDecls), at least
621 in the case of GADTs. Consider
622 data T a where { MkT :: { f :: a } :: T [a] }
623 Then f is not "naughty" because it has a well-typed record selector.
624 But we don't allow updates for 'f'. (One could consider trying to
625 allow this, but it makes my head hurt. Badly. And no one has asked
626 for it.)
627
628 In principle one could go further, and allow
629 g :: T a -> T a
630 g t = t { f2 = \x -> x }
631 because the expression is polymorphic...but that seems a bridge too far.
632
633 Note [Data family example]
634 ~~~~~~~~~~~~~~~~~~~~~~~~~~
635 data instance T (a,b) = MkT { x::a, y::b }
636 --->
637 data :TP a b = MkT { a::a, y::b }
638 coTP a b :: T (a,b) ~ :TP a b
639
640 Suppose r :: T (t1,t2), e :: t3
641 Then r { x=e } :: T (t3,t1)
642 --->
643 case r |> co1 of
644 MkT x y -> MkT e y |> co2
645 where co1 :: T (t1,t2) ~ :TP t1 t2
646 co2 :: :TP t3 t2 ~ T (t3,t2)
647 The wrapping with co2 is done by the constructor wrapper for MkT
648
649 Outgoing invariants
650 ~~~~~~~~~~~~~~~~~~~
651 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
652
653 * cons are the data constructors to be updated
654
655 * in_inst_tys, out_inst_tys have same length, and instantiate the
656 *representation* tycon of the data cons. In Note [Data
657 family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
658 -}
659
660 tcExpr Up (RecordUpd record_expr rbinds _ _ _) res_ty
661 = ASSERT( notNull upd_fld_names )
662 do {
663 -- STEP 0
664 -- Check that the field names are really field names
665 ; sel_ids <- mapM tcLookupField upd_fld_names
666 -- The renamer has already checked that
667 -- selectors are all in scope
668 ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
669 | (fld, sel_id) <- rec_flds rbinds `zip` sel_ids,
670 not (isRecordSelector sel_id), -- Excludes class ops
671 let L loc fld_name = hsRecFieldId (unLoc fld) ]
672 ; unless (null bad_guys) (sequence bad_guys >> failM)
673
674 -- STEP 1
675 -- Figure out the tycon and data cons from the first field name
676 ; let -- It's OK to use the non-tc splitters here (for a selector)
677 sel_id : _ = sel_ids
678 (tycon, _) = recordSelectorFieldLabel sel_id -- We've failed already if
679 data_cons = tyConDataCons tycon -- it's not a field label
680 -- NB: for a data type family, the tycon is the instance tycon
681
682 relevant_cons = filter is_relevant data_cons
683 is_relevant con = all (`elem` dataConFieldLabels con) upd_fld_names
684 -- A constructor is only relevant to this process if
685 -- it contains *all* the fields that are being updated
686 -- Other ones will cause a runtime error if they occur
687
688 -- Take apart a representative constructor
689 con1 = ASSERT( not (null relevant_cons) ) head relevant_cons
690 (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1
691 con1_flds = dataConFieldLabels con1
692 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs)
693
694 -- Step 2
695 -- Check that at least one constructor has all the named fields
696 -- i.e. has an empty set of bad fields returned by badFields
697 ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds data_cons)
698
699 -- STEP 3 Note [Criteria for update]
700 -- Check that each updated field is polymorphic; that is, its type
701 -- mentions only the universally-quantified variables of the data con
702 ; let flds1_w_tys = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
703 upd_flds1_w_tys = filter is_updated flds1_w_tys
704 is_updated (fld,_) = fld `elem` upd_fld_names
705
706 bad_upd_flds = filter bad_fld upd_flds1_w_tys
707 con1_tv_set = mkVarSet con1_tvs
708 bad_fld (fld, ty) = fld `elem` upd_fld_names &&
709 not (tyVarsOfType ty `subVarSet` con1_tv_set)
710 ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)
711
712 -- STEP 4 Note [Type of a record update]
713 -- Figure out types for the scrutinee and result
714 -- Both are of form (T a b c), with fresh type variables, but with
715 -- common variables where the scrutinee and result must have the same type
716 -- These are variables that appear in *any* arg of *any* of the
717 -- relevant constructors *except* in the updated fields
718 --
719 ; let fixed_tvs = getFixedTyVars con1_tvs relevant_cons
720 is_fixed_tv tv = tv `elemVarSet` fixed_tvs
721
722 mk_inst_ty :: TvSubst -> (TKVar, TcType) -> TcM (TvSubst, TcType)
723 -- Deals with instantiation of kind variables
724 -- c.f. TcMType.tcInstTyVars
725 mk_inst_ty subst (tv, result_inst_ty)
726 | is_fixed_tv tv -- Same as result type
727 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
728 | otherwise -- Fresh type, of correct kind
729 = do { new_ty <- newFlexiTyVarTy (TcType.substTy subst (tyVarKind tv))
730 ; return (extendTvSubst subst tv new_ty, new_ty) }
731
732 ; (result_subst, con1_tvs') <- tcInstTyVars con1_tvs
733 ; let result_inst_tys = mkTyVarTys con1_tvs'
734
735 ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty emptyTvSubst
736 (con1_tvs `zip` result_inst_tys)
737
738 ; let rec_res_ty = TcType.substTy result_subst con1_res_ty
739 scrut_ty = TcType.substTy scrut_subst con1_res_ty
740 con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
741
742 ; wrap_res <- tcSubTypeHR rec_res_ty res_ty
743
744 -- STEP 5
745 -- Typecheck the thing to be updated, and the bindings
746 ; record_expr' <- tcPolyExpr record_expr scrut_ty
747 ; rbinds' <- tcRecordBinds con1 con1_arg_tys' rbinds
748
749 -- STEP 6: Deal with the stupid theta
750 ; let theta' = substTheta scrut_subst (dataConStupidTheta con1)
751 ; instStupidTheta RecordUpdOrigin theta'
752
753 -- Step 7: make a cast for the scrutinee, in the case that it's from a type family
754 ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon
755 = mkWpCast (mkTcUnbranchedAxInstCo Representational co_con scrut_inst_tys)
756 | otherwise
757 = idHsWrapper
758 -- Phew!
759 ; return $ mkHsWrap wrap_res $
760 RecordUpd (mkLHsWrap scrut_co record_expr') rbinds'
761 relevant_cons scrut_inst_tys result_inst_tys }
762 where
763 upd_fld_names = hsRecFields rbinds
764
765 getFixedTyVars :: [TyVar] -> [DataCon] -> TyVarSet
766 -- These tyvars must not change across the updates
767 getFixedTyVars tvs1 cons
768 = mkVarSet [tv1 | con <- cons
769 , let (tvs, theta, arg_tys, _) = dataConSig con
770 flds = dataConFieldLabels con
771 fixed_tvs = exactTyVarsOfTypes fixed_tys
772 -- fixed_tys: See Note [Type of a record update]
773 `unionVarSet` tyVarsOfTypes theta
774 -- Universally-quantified tyvars that
775 -- appear in any of the *implicit*
776 -- arguments to the constructor are fixed
777 -- See Note [Implicit type sharing]
778
779 fixed_tys = [ty | (fld,ty) <- zip flds arg_tys
780 , not (fld `elem` upd_fld_names)]
781 , (tv1,tv) <- tvs1 `zip` tvs -- Discards existentials in tvs
782 , tv `elemVarSet` fixed_tvs ]
783
784 {-
785 ************************************************************************
786 * *
787 Arithmetic sequences e.g. [a,b..]
788 and their parallel-array counterparts e.g. [: a,b.. :]
789
790 * *
791 ************************************************************************
792 -}
793
794 tcExpr Up (ArithSeq _ witness seq) res_ty
795 = tcArithSeq witness seq res_ty
796
797 tcExpr Up (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
798 = do { (wrap, elt_ty) <- matchExpectedPArrTy Expected res_ty
799 ; expr1' <- tcPolyExpr expr1 elt_ty
800 ; expr2' <- tcPolyExpr expr2 elt_ty
801 ; enumFromToP <- initDsTc $ dsDPHBuiltin enumFromToPVar
802 ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
803 (idName enumFromToP) elt_ty
804 ; return $ mkHsWrap wrap
805 (PArrSeq enum_from_to (FromTo expr1' expr2')) }
806
807 tcExpr Up (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
808 = do { (wrap, elt_ty) <- matchExpectedPArrTy Expected res_ty
809 ; expr1' <- tcPolyExpr expr1 elt_ty
810 ; expr2' <- tcPolyExpr expr2 elt_ty
811 ; expr3' <- tcPolyExpr expr3 elt_ty
812 ; enumFromThenToP <- initDsTc $ dsDPHBuiltin enumFromThenToPVar
813 ; eft <- newMethodFromName (PArrSeqOrigin seq)
814 (idName enumFromThenToP) elt_ty -- !!!FIXME: chak
815 ; return $ mkHsWrap wrap
816 (PArrSeq eft (FromThenTo expr1' expr2' expr3')) }
817
818 tcExpr _ (PArrSeq _ _) _
819 = panic "TcExpr.tcExpr: Infinite parallel array!"
820 -- the parser shouldn't have generated it and the renamer shouldn't have
821 -- let it through
822
823 {-
824 ************************************************************************
825 * *
826 Template Haskell
827 * *
828 ************************************************************************
829 -}
830
831 tcExpr Up (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
832 tcExpr Up (HsBracket brack) res_ty = tcTypedBracket brack res_ty
833 tcExpr Up (HsRnBracketOut brack ps) res_ty = tcUntypedBracket brack ps res_ty
834
835 {-
836 ************************************************************************
837 * *
838 Skolemising for all the "Up" cases
839 * *
840 ************************************************************************
841 -}
842
843 tcExpr Down e res_ty = tcSkolemiseExpr SkolemiseDeeply res_ty $ tcExpr Up e
844
845 {-
846 ************************************************************************
847 * *
848 Catch-all
849 * *
850 ************************************************************************
851 -}
852
853 tcExpr _ other _ = pprPanic "tcPolyExpr" (ppr other)
854 -- Include ArrForm, ArrApp, which shouldn't appear at all
855 -- Also HsTcBracketOut, HsQuasiQuoteE
856
857 {-
858 ************************************************************************
859 * *
860 Arithmetic sequences [a..b] etc
861 * *
862 ************************************************************************
863 -}
864
865 tcArithSeq :: Maybe (SyntaxExpr Name) -> ArithSeqInfo Name -> TcRhoType
866 -> TcM (HsExpr TcId)
867
868 tcArithSeq witness seq@(From expr) res_ty
869 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
870 ; expr' <- tcPolyExpr expr elt_ty
871 ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
872 enumFromName elt_ty
873 ; return $ mkHsWrap coi (ArithSeq enum_from wit' (From expr')) }
874
875 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
876 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
877 ; expr1' <- tcPolyExpr expr1 elt_ty
878 ; expr2' <- tcPolyExpr expr2 elt_ty
879 ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
880 enumFromThenName elt_ty
881 ; return $ mkHsWrap coi (ArithSeq enum_from_then wit' (FromThen expr1' expr2')) }
882
883 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
884 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
885 ; expr1' <- tcPolyExpr expr1 elt_ty
886 ; expr2' <- tcPolyExpr expr2 elt_ty
887 ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
888 enumFromToName elt_ty
889 ; return $ mkHsWrap coi (ArithSeq enum_from_to wit' (FromTo expr1' expr2')) }
890
891 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
892 = do { (coi, elt_ty, wit') <- arithSeqEltType witness res_ty
893 ; expr1' <- tcPolyExpr expr1 elt_ty
894 ; expr2' <- tcPolyExpr expr2 elt_ty
895 ; expr3' <- tcPolyExpr expr3 elt_ty
896 ; eft <- newMethodFromName (ArithSeqOrigin seq)
897 enumFromThenToName elt_ty
898 ; return $ mkHsWrap coi (ArithSeq eft wit' (FromThenTo expr1' expr2' expr3')) }
899
900 -----------------
901 arithSeqEltType :: Maybe (SyntaxExpr Name) -> TcRhoType
902 -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr Id))
903 arithSeqEltType Nothing res_ty
904 = do { (coi, elt_ty) <- matchExpectedListTy Expected res_ty
905 ; return (coi, elt_ty, Nothing) }
906 arithSeqEltType (Just fl) res_ty
907 = do { list_ty <- newFlexiTyVarTy liftedTypeKind
908 ; fl' <- tcSyntaxOp ListOrigin fl (mkFunTy list_ty res_ty)
909 ; (coi, elt_ty) <- matchExpectedListTy Expected list_ty
910 ; return (coi, elt_ty, Just fl') }
911
912 {-
913 ************************************************************************
914 * *
915 Applications
916 * *
917 ************************************************************************
918 -}
919
920 tcApp :: Maybe SDoc -- like "The function `f' is applied to"
921 -- or leave out to get exactly that message
922 -> CtOrigin
923 -> LHsExpr Name -> [LHsExpr Name] -- Function and args
924 -> TcRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
925 -- (wrap, fun, args). For an ordinary function application,
926 -- these should be assembled as (wrap (fun args)).
927 -- But OpApp is slightly different, so that's why the caller
928 -- must assemble
929
930 tcApp m_herald orig (L _ (HsPar e)) args res_ty
931 = tcApp m_herald orig e args res_ty
932
933 tcApp m_herald orig (L _ (HsApp e1 e2)) args res_ty
934 = tcApp m_herald orig e1 (e2:args) res_ty -- Accumulate the arguments
935
936 tcApp _ _ (L loc (HsVar fun)) args res_ty
937 | fun `hasKey` tagToEnumKey
938 , [arg] <- args
939 = tcTagToEnum loc fun arg res_ty
940
941 | fun `hasKey` seqIdKey
942 , [arg1,arg2] <- args
943 = tcSeq loc fun arg1 arg2 res_ty
944
945 tcApp m_herald orig fun args res_ty
946 = do { -- Type-check the function
947 ; (fun1, fun_sigma) <- tcInferFun fun
948
949 -- Extract its argument types
950 ; (wrap_fun, expected_arg_tys, actual_res_ty)
951 <- matchExpectedFunTys (Actual orig)
952 (m_herald `orElse` mk_app_msg fun)
953 (length args) fun_sigma
954
955 -- Typecheck the result, thereby propagating
956 -- info (if any) from result into the argument types
957 -- Both actual_res_ty and res_ty are deeply skolemised
958 -- Rather like tcWrapResult, but (perhaps for historical reasons)
959 -- we do this before typechecking the arguments
960 ; wrap_res <- addErrCtxtM (funResCtxt True (unLoc fun) actual_res_ty res_ty) $
961 tcSubTypeDS_NC GenSigCtxt actual_res_ty res_ty
962
963 -- Typecheck the arguments
964 ; args1 <- tcArgs fun args expected_arg_tys
965
966 -- Assemble the result
967 ; return (wrap_res, mkLHsWrap wrap_fun fun1, args1) }
968
969 mk_app_msg :: LHsExpr Name -> SDoc
970 mk_app_msg fun = sep [ ptext (sLit "The function") <+> quotes (ppr fun)
971 , ptext (sLit "is applied to")]
972
973 mk_op_msg :: LHsExpr Name -> SDoc
974 mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"
975
976 ----------------
977 tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType)
978 -- Infer type of a function
979 tcInferFun (L loc (HsVar name))
980 = do { (fun, ty) <- setSrcSpan loc (tcInferId name)
981 -- Don't wrap a context around a plain Id
982 ; return (L loc fun, ty) }
983
984 tcInferFun fun
985 = do { (fun, fun_ty) <- tcInfer (tcPolyExpr fun)
986
987 -- Zonk the function type carefully, to expose any polymorphism
988 -- E.g. (( \(x::forall a. a->a). blah ) e)
989 -- We can see the rank-2 type of the lambda in time to generalise e
990 ; fun_ty' <- zonkTcType fun_ty
991
992 ; return (fun, fun_ty') }
993
994 ----------------
995 tcArgs :: LHsExpr Name -- The function (for error messages)
996 -> [LHsExpr Name] -> [TcSigmaType] -- Actual arguments and expected arg types
997 -> TcM [LHsExpr TcId] -- Resulting args
998
999 tcArgs fun args expected_arg_tys
1000 = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
1001
1002 ----------------
1003 tcArg :: LHsExpr Name -- The function (for error messages)
1004 -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type
1005 -> TcM (LHsExpr TcId) -- Resulting argument
1006 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
1007 (tcPolyExprNC arg ty)
1008
1009 ----------------
1010 tcTupArgs :: [LHsTupArg Name] -> [TcSigmaType] -> TcM [LHsTupArg TcId]
1011 tcTupArgs args tys
1012 = ASSERT( equalLength args tys ) mapM go (args `zip` tys)
1013 where
1014 go (L l (Missing {}), arg_ty) = return (L l (Missing arg_ty))
1015 go (L l (Present expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty
1016 ; return (L l (Present expr')) }
1017
1018 ---------------------------
1019 tcSyntaxOp :: CtOrigin -> HsExpr Name -> TcSigmaType -> TcM (HsExpr TcId)
1020 -- Typecheck a syntax operator, checking that it has the specified type
1021 -- The operator is always a variable at this stage (i.e. renamer output)
1022 -- This version assumes res_ty is a monotype
1023 tcSyntaxOp orig (HsVar op) res_ty = do { (expr, ty) <- tcInferIdWithOrig orig op
1024 ; wrap <- tcSubType GenSigCtxt ty res_ty
1025 ; return (mkHsWrap wrap expr) }
1026 tcSyntaxOp _ other _ = pprPanic "tcSyntaxOp" (ppr other)
1027
1028 {-
1029 Note [Push result type in]
1030 ~~~~~~~~~~~~~~~~~~~~~~~~~~
1031 Unify with expected result before type-checking the args so that the
1032 info from res_ty percolates to args. This is when we might detect a
1033 too-few args situation. (One can think of cases when the opposite
1034 order would give a better error message.)
1035 experimenting with putting this first.
1036
1037 Here's an example where it actually makes a real difference
1038
1039 class C t a b | t a -> b
1040 instance C Char a Bool
1041
1042 data P t a = forall b. (C t a b) => MkP b
1043 data Q t = MkQ (forall a. P t a)
1044
1045 f1, f2 :: Q Char;
1046 f1 = MkQ (MkP True)
1047 f2 = MkQ (MkP True :: forall a. P Char a)
1048
1049 With the change, f1 will type-check, because the 'Char' info from
1050 the signature is propagated into MkQ's argument. With the check
1051 in the other order, the extra signature in f2 is reqd.
1052
1053 Note [Visible type application]
1054 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1055 TODO (RAE): Move Note?
1056
1057 GHC implements a generalisation of the algorithm described in the
1058 "Visible Type Application" paper (available from
1059 http://www.cis.upenn.edu/~sweirich/publications.html). A key part
1060 of that algorithm is to distinguish user-specified variables from inferred
1061 variables. For example, the following should typecheck:
1062
1063 f :: forall a b. a -> b -> b
1064 f = const id
1065
1066 g = const id
1067
1068 x = f @Int @Bool 5 False
1069 y = g 5 @Bool False
1070
1071 The idea is that we wish to allow visible type application when we are
1072 instantiating a specified, fixed variable. In practice, specified, fixed
1073 variables are either written in a type signature (or
1074 annotation), OR are imported from another module. (We could do better here,
1075 for example by doing SCC analysis on parts of a module and considering any
1076 type from outside one's SCC to be fully specified, but this is very confusing to
1077 users. The simple rule above is much more straightforward and predictable.)
1078
1079 So, both of f's quantified variables are specified and may be instantiated.
1080 But g has no type signature, so only id's variable is specified (because id
1081 is imported). We write the type of g as forall {a}. a -> forall b. b -> b.
1082 Note that the a is in braces, meaning it cannot be instantiated with
1083 visible type application.
1084
1085 Tracking specified vs. inferred variables is done conveniently by looking at
1086 Names. A System name (from mkSystemName or a variant) is an inferred
1087 variable; an Internal name is a specified one. Simple. This works out
1088 because skolemiseUnboundMetaTyVar always produces a System name.
1089
1090 The only wrinkle with this scheme is in tidying. If all inferred names
1091 are System names, then tidying will append lots of 0s. This pollutes
1092 interface files and Haddock output. So we convert System tyvars to
1093 Internal ones during the final zonk. This works because type-checking
1094 is fully complete, and therefore the distinction between specified and
1095 inferred is no longer relevant.
1096
1097 If using System vs. Internal to perform type-checking seems suspicious,
1098 the alternative approach would mean adding a field to ForAllTy to track
1099 specified vs. inferred. That seems considerably more painful. And, anyway,
1100 once the (* :: *) branch is merged, this will be redesigned somewhat
1101 to move away from using Names. That's because the (* :: *) branch already
1102 has more structure available in ForAllTy, and there, it's easy to squeeze
1103 in another specified-vs.-inferred bit.
1104
1105 TODO (RAE): Update this Note in the (* :: *) branch when merging.
1106
1107 ************************************************************************
1108 * *
1109 tcInferId
1110 * *
1111 ************************************************************************
1112 -}
1113
1114 tcCheckId :: Name -> TcRhoType -> TcM (HsExpr TcId)
1115 tcCheckId name res_ty
1116 = do { (expr, actual_res_ty) <- tcInferId name
1117 ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])
1118 ; addErrCtxtM (funResCtxt False (HsVar name) actual_res_ty res_ty) $
1119 tcWrapResult expr actual_res_ty res_ty }
1120
1121 ------------------------
1122 tcInferId :: Name -> TcM (HsExpr TcId, TcSigmaType)
1123 -- Infer type, and deeply instantiate
1124 tcInferId n = tcInferIdWithOrig (OccurrenceOf n) n
1125
1126 ------------------------
1127 tcInferIdWithOrig :: CtOrigin -> Name -> TcM (HsExpr TcId, TcSigmaType)
1128 -- Look up an occurrence of an Id
1129
1130 tcInferIdWithOrig orig id_name
1131 | id_name `hasKey` tagToEnumKey
1132 = failWithTc (ptext (sLit "tagToEnum# must appear applied to one argument"))
1133 -- tcApp catches the case (tagToEnum# arg)
1134
1135 | id_name `hasKey` assertIdKey
1136 = do { dflags <- getDynFlags
1137 ; if gopt Opt_IgnoreAsserts dflags
1138 then tc_infer_id orig id_name
1139 else tc_infer_assert dflags orig }
1140
1141 | otherwise
1142 = tc_infer_id orig id_name
1143
1144 tc_infer_assert :: DynFlags -> CtOrigin -> TcM (HsExpr TcId, TcSigmaType)
1145 -- Deal with an occurrence of 'assert'
1146 -- See Note [Adding the implicit parameter to 'assert']
1147 tc_infer_assert dflags orig
1148 = do { sloc <- getSrcSpanM
1149 ; assert_error_id <- tcLookupId assertErrorName
1150 ; (wrap, id_rho) <- topInstantiate orig (idType assert_error_id)
1151 ; let (arg_ty, res_ty) = case tcSplitFunTy_maybe id_rho of
1152 Nothing -> pprPanic "assert type" (ppr id_rho)
1153 Just arg_res -> arg_res
1154 ; ASSERT( arg_ty `tcEqType` addrPrimTy )
1155 return (HsApp (L sloc (mkHsWrap wrap (HsVar assert_error_id)))
1156 (L sloc (srcSpanPrimLit dflags sloc))
1157 , res_ty) }
1158
1159 tc_infer_id :: CtOrigin -> Name -> TcM (HsExpr TcId, TcSigmaType)
1160 -- Return type is deeply instantiated
1161 tc_infer_id orig id_name
1162 = do { thing <- tcLookup id_name
1163 ; case thing of
1164 ATcId { tct_id = id }
1165 -> do { check_naughty id -- Note [Local record selectors]
1166 ; checkThLocalId id
1167 ; return_id id }
1168
1169 AGlobal (AnId id)
1170 -> do { check_naughty id
1171 ; return_id id }
1172 -- A global cannot possibly be ill-staged
1173 -- nor does it need the 'lifting' treatment
1174 -- hence no checkTh stuff here
1175
1176 AGlobal (AConLike cl) -> case cl of
1177 RealDataCon con -> return_data_con con
1178 PatSynCon ps -> tcPatSynBuilderOcc orig ps
1179
1180 _ -> failWithTc $
1181 ppr thing <+> ptext (sLit "used where a value identifier was expected") }
1182 where
1183 return_id id = return (HsVar id, idType id)
1184
1185 return_data_con con
1186 -- For data constructors, must perform the stupid-theta check
1187 | null stupid_theta
1188 = return_id con_wrapper_id
1189
1190 | otherwise
1191 -- See Note [Instantiating stupid theta]
1192 = do { let (tvs, theta, rho) = tcSplitSigmaTy (idType con_wrapper_id)
1193 ; (subst, tvs') <- tcInstTyVars tvs
1194 ; let tys' = mkTyVarTys tvs'
1195 theta' = substTheta subst theta
1196 rho' = substTy subst rho
1197 ; wrap <- instCall orig tys' theta'
1198 ; addDataConStupidTheta con tys'
1199 ; return (mkHsWrap wrap (HsVar con_wrapper_id), rho') }
1200
1201 where
1202 con_wrapper_id = dataConWrapId con
1203 stupid_theta = dataConStupidTheta con
1204
1205 check_naughty id
1206 | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel id)
1207 | otherwise = return ()
1208
1209 srcSpanPrimLit :: DynFlags -> SrcSpan -> HsExpr TcId
1210 srcSpanPrimLit dflags span
1211 = HsLit (HsStringPrim "" (unsafeMkByteString
1212 (showSDocOneLine dflags (ppr span))))
1213
1214 {-
1215 Note [Adding the implicit parameter to 'assert']
1216 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1217 The typechecker transforms (assert e1 e2) to (assertError "Foo.hs:27"
1218 e1 e2). This isn't really the Right Thing because there's no way to
1219 "undo" if you want to see the original source code in the typechecker
1220 output. We'll have fix this in due course, when we care more about
1221 being able to reconstruct the exact original program.
1222
1223 Note [tagToEnum#]
1224 ~~~~~~~~~~~~~~~~~
1225 Nasty check to ensure that tagToEnum# is applied to a type that is an
1226 enumeration TyCon. Unification may refine the type later, but this
1227 check won't see that, alas. It's crude, because it relies on our
1228 knowing *now* that the type is ok, which in turn relies on the
1229 eager-unification part of the type checker pushing enough information
1230 here. In theory the Right Thing to do is to have a new form of
1231 constraint but I definitely cannot face that! And it works ok as-is.
1232
1233 Here's are two cases that should fail
1234 f :: forall a. a
1235 f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable
1236
1237 g :: Int
1238 g = tagToEnum# 0 -- Int is not an enumeration
1239
1240 When data type families are involved it's a bit more complicated.
1241 data family F a
1242 data instance F [Int] = A | B | C
1243 Then we want to generate something like
1244 tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]
1245 Usually that coercion is hidden inside the wrappers for
1246 constructors of F [Int] but here we have to do it explicitly.
1247
1248 It's all grotesquely complicated.
1249
1250 Note [Instantiating stupid theta]
1251 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1252 Normally, when we infer the type of an Id, we don't instantiate,
1253 because we wish to allow for visible type application later on.
1254 But if a datacon has a stupid theta, we're a bit stuck. We need
1255 to emit the stupid theta constraints with instantiated types. It's
1256 difficult to defer this to the lazy instantiation, because a stupid
1257 theta has no spot to put it in a type. So we just instantiate eagerly
1258 in this case. Thus, users cannot use visible type application with
1259 a data constructor sporting a stupid theta. I won't feel so bad for
1260 the users that complain.
1261
1262 -}
1263
1264 tcSeq :: SrcSpan -> Name -> LHsExpr Name -> LHsExpr Name
1265 -> TcRhoType -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
1266 -- (seq e1 e2) :: res_ty
1267 -- We need a special typing rule because res_ty can be unboxed
1268 tcSeq loc fun_name arg1 arg2 res_ty
1269 = do { fun <- tcLookupId fun_name
1270 ; (arg1', arg1_ty) <- tcInfer (tcPolyExpr arg1)
1271 ; arg2' <- tcPolyExpr arg2 res_ty
1272 ; let fun' = L loc (HsWrap ty_args (HsVar fun))
1273 ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty
1274 ; return (idHsWrapper, fun', [arg1', arg2']) }
1275
1276 tcTagToEnum :: SrcSpan -> Name -> LHsExpr Name -> TcRhoType
1277 -> TcM (HsWrapper, LHsExpr TcId, [LHsExpr TcId])
1278 -- tagToEnum# :: forall a. Int# -> a
1279 -- See Note [tagToEnum#] Urgh!
1280 tcTagToEnum loc fun_name arg res_ty
1281 = do { fun <- tcLookupId fun_name
1282 ; ty' <- zonkTcType res_ty
1283
1284 -- Check that the type is algebraic
1285 ; let mb_tc_app = tcSplitTyConApp_maybe ty'
1286 Just (tc, tc_args) = mb_tc_app
1287 ; checkTc (isJust mb_tc_app)
1288 (mk_error ty' doc1)
1289
1290 -- Look through any type family
1291 ; fam_envs <- tcGetFamInstEnvs
1292 ; let (rep_tc, rep_args, coi)
1293 = tcLookupDataFamInst fam_envs tc tc_args
1294 -- coi :: tc tc_args ~R rep_tc rep_args
1295
1296 ; checkTc (isEnumerationTyCon rep_tc)
1297 (mk_error ty' doc2)
1298
1299 ; arg' <- tcPolyExpr arg intPrimTy
1300 ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun))
1301 rep_ty = mkTyConApp rep_tc rep_args
1302
1303 ; return (coToHsWrapperR (mkTcSymCo $ TcCoercion coi), fun', [arg']) }
1304 -- coi is a Representational coercion
1305 where
1306 doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature")
1307 , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ]
1308 doc2 = ptext (sLit "Result type must be an enumeration type")
1309
1310 mk_error :: TcType -> SDoc -> SDoc
1311 mk_error ty what
1312 = hang (ptext (sLit "Bad call to tagToEnum#")
1313 <+> ptext (sLit "at type") <+> ppr ty)
1314 2 what
1315
1316 {-
1317 ************************************************************************
1318 * *
1319 Template Haskell checks
1320 * *
1321 ************************************************************************
1322 -}
1323
1324 checkThLocalId :: Id -> TcM ()
1325 checkThLocalId id
1326 = do { mb_local_use <- getStageAndBindLevel (idName id)
1327 ; case mb_local_use of
1328 Just (top_lvl, bind_lvl, use_stage)
1329 | thLevel use_stage > bind_lvl
1330 , isNotTopLevel top_lvl
1331 -> checkCrossStageLifting id use_stage
1332 _ -> return () -- Not a locally-bound thing, or
1333 -- no cross-stage link
1334 }
1335
1336 --------------------------------------
1337 checkCrossStageLifting :: Id -> ThStage -> TcM ()
1338 -- If we are inside typed brackets, and (use_lvl > bind_lvl)
1339 -- we must check whether there's a cross-stage lift to do
1340 -- Examples \x -> [|| x ||]
1341 -- [|| map ||]
1342 -- There is no error-checking to do, because the renamer did that
1343 --
1344 -- This is similar to checkCrossStageLifting in RnSplice, but
1345 -- this code is applied to *typed* brackets.
1346
1347 checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var))
1348 = -- Nested identifiers, such as 'x' in
1349 -- E.g. \x -> [|| h x ||]
1350 -- We must behave as if the reference to x was
1351 -- h $(lift x)
1352 -- We use 'x' itself as the splice proxy, used by
1353 -- the desugarer to stitch it all back together.
1354 -- If 'x' occurs many times we may get many identical
1355 -- bindings of the same splice proxy, but that doesn't
1356 -- matter, although it's a mite untidy.
1357 do { let id_ty = idType id
1358 ; checkTc (isTauTy id_ty) (polySpliceErr id)
1359 -- If x is polymorphic, its occurrence sites might
1360 -- have different instantiations, so we can't use plain
1361 -- 'x' as the splice proxy name. I don't know how to
1362 -- solve this, and it's probably unimportant, so I'm
1363 -- just going to flag an error for now
1364
1365 ; lift <- if isStringTy id_ty then
1366 do { sid <- tcLookupId THNames.liftStringName
1367 -- See Note [Lifting strings]
1368 ; return (HsVar sid) }
1369 else
1370 setConstraintVar lie_var $
1371 -- Put the 'lift' constraint into the right LIE
1372 newMethodFromName (OccurrenceOf (idName id))
1373 THNames.liftName id_ty
1374
1375 -- Update the pending splices
1376 ; ps <- readMutVar ps_var
1377 ; let pending_splice = PendingTcSplice (idName id) (nlHsApp (noLoc lift) (nlHsVar id))
1378 ; writeMutVar ps_var (pending_splice : ps)
1379
1380 ; return () }
1381
1382 checkCrossStageLifting _ _ = return ()
1383
1384 polySpliceErr :: Id -> SDoc
1385 polySpliceErr id
1386 = ptext (sLit "Can't splice the polymorphic local variable") <+> quotes (ppr id)
1387
1388 {-
1389 Note [Lifting strings]
1390 ~~~~~~~~~~~~~~~~~~~~~~
1391 If we see $(... [| s |] ...) where s::String, we don't want to
1392 generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.
1393 So this conditional short-circuits the lifting mechanism to generate
1394 (liftString "xy") in that case. I didn't want to use overlapping instances
1395 for the Lift class in TH.Syntax, because that can lead to overlapping-instance
1396 errors in a polymorphic situation.
1397
1398 If this check fails (which isn't impossible) we get another chance; see
1399 Note [Converting strings] in Convert.hs
1400
1401 Local record selectors
1402 ~~~~~~~~~~~~~~~~~~~~~~
1403 Record selectors for TyCons in this module are ordinary local bindings,
1404 which show up as ATcIds rather than AGlobals. So we need to check for
1405 naughtiness in both branches. c.f. TcTyClsBindings.mkAuxBinds.
1406
1407
1408 ************************************************************************
1409 * *
1410 \subsection{Record bindings}
1411 * *
1412 ************************************************************************
1413
1414 Game plan for record bindings
1415 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1416 1. Find the TyCon for the bindings, from the first field label.
1417
1418 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
1419
1420 For each binding field = value
1421
1422 3. Instantiate the field type (from the field label) using the type
1423 envt from step 2.
1424
1425 4 Type check the value using tcArg, passing the field type as
1426 the expected argument type.
1427
1428 This extends OK when the field types are universally quantified.
1429 -}
1430
1431 tcRecordBinds
1432 :: DataCon
1433 -> [TcType] -- Expected type for each field
1434 -> HsRecordBinds Name
1435 -> TcM (HsRecordBinds TcId)
1436
1437 tcRecordBinds data_con arg_tys (HsRecFields rbinds dd)
1438 = do { mb_binds <- mapM do_bind rbinds
1439 ; return (HsRecFields (catMaybes mb_binds) dd) }
1440 where
1441 flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1442 do_bind (L l fld@(HsRecField { hsRecFieldId = L loc field_lbl
1443 , hsRecFieldArg = rhs }))
1444 | Just field_ty <- assocMaybe flds_w_tys field_lbl
1445 = addErrCtxt (fieldCtxt field_lbl) $
1446 do { rhs' <- tcPolyExprNC rhs field_ty
1447 ; let field_id = mkUserLocal (nameOccName field_lbl)
1448 (nameUnique field_lbl)
1449 field_ty loc
1450 -- Yuk: the field_id has the *unique* of the selector Id
1451 -- (so we can find it easily)
1452 -- but is a LocalId with the appropriate type of the RHS
1453 -- (so the desugarer knows the type of local binder to make)
1454 ; return (Just (L l (fld { hsRecFieldId = L loc field_id
1455 , hsRecFieldArg = rhs' }))) }
1456 | otherwise
1457 = do { addErrTc (badFieldCon (RealDataCon data_con) field_lbl)
1458 ; return Nothing }
1459
1460 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1461 checkMissingFields data_con rbinds
1462 | null field_labels -- Not declared as a record;
1463 -- But C{} is still valid if no strict fields
1464 = if any isBanged field_strs then
1465 -- Illegal if any arg is strict
1466 addErrTc (missingStrictFields data_con [])
1467 else
1468 return ()
1469
1470 | otherwise = do -- A record
1471 unless (null missing_s_fields)
1472 (addErrTc (missingStrictFields data_con missing_s_fields))
1473
1474 warn <- woptM Opt_WarnMissingFields
1475 unless (not (warn && notNull missing_ns_fields))
1476 (warnTc True (missingFields data_con missing_ns_fields))
1477
1478 where
1479 missing_s_fields
1480 = [ fl | (fl, str) <- field_info,
1481 isBanged str,
1482 not (fl `elem` field_names_used)
1483 ]
1484 missing_ns_fields
1485 = [ fl | (fl, str) <- field_info,
1486 not (isBanged str),
1487 not (fl `elem` field_names_used)
1488 ]
1489
1490 field_names_used = hsRecFields rbinds
1491 field_labels = dataConFieldLabels data_con
1492
1493 field_info = zipEqual "missingFields"
1494 field_labels
1495 field_strs
1496
1497 field_strs = dataConSrcBangs data_con
1498
1499 {-
1500 ************************************************************************
1501 * *
1502 Skolemisation
1503 * *
1504 ************************************************************************
1505 -}
1506
1507 -- | Convenient wrapper for skolemising a type during typechecking an expression.
1508 -- Always does uses a 'GenSigCtxt'.
1509 tcSkolemiseExpr :: SkolemiseMode
1510 -> TcSigmaType
1511 -> (TcRhoType -> TcM (HsExpr TcId))
1512 -> (TcM (HsExpr TcId))
1513 tcSkolemiseExpr mode res_ty thing_inside
1514 = do { (wrap, expr) <- tcSkolemise mode GenSigCtxt res_ty $
1515 \_ rho -> thing_inside rho
1516 ; return (mkHsWrap wrap expr) }
1517
1518 {-
1519 ************************************************************************
1520 * *
1521 \subsection{Errors and contexts}
1522 * *
1523 ************************************************************************
1524
1525 Boring and alphabetical:
1526 -}
1527
1528 addExprErrCtxt :: LHsExpr Name -> TcM a -> TcM a
1529 addExprErrCtxt expr = addErrCtxt (exprCtxt expr)
1530
1531 exprCtxt :: LHsExpr Name -> SDoc
1532 exprCtxt expr
1533 = hang (ptext (sLit "In the expression:")) 2 (ppr expr)
1534
1535 fieldCtxt :: Name -> SDoc
1536 fieldCtxt field_name
1537 = ptext (sLit "In the") <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")
1538
1539 funAppCtxt :: LHsExpr Name -> LHsExpr Name -> Int -> SDoc
1540 funAppCtxt fun arg arg_no
1541 = hang (hsep [ ptext (sLit "In the"), speakNth arg_no, ptext (sLit "argument of"),
1542 quotes (ppr fun) <> text ", namely"])
1543 2 (quotes (ppr arg))
1544
1545 funResCtxt :: Bool -- There is at least one argument
1546 -> HsExpr Name -> TcType -> TcType
1547 -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1548 -- When we have a mis-match in the return type of a function
1549 -- try to give a helpful message about too many/few arguments
1550 --
1551 -- Used for naked variables too; but with has_args = False
1552 funResCtxt has_args fun fun_res_ty env_ty tidy_env
1553 = do { fun_res' <- zonkTcType fun_res_ty
1554 ; env' <- zonkTcType env_ty
1555 ; let (args_fun, res_fun) = tcSplitFunTys fun_res'
1556 (args_env, res_env) = tcSplitFunTys env'
1557 n_fun = length args_fun
1558 n_env = length args_env
1559 info | n_fun == n_env = Outputable.empty
1560 | n_fun > n_env
1561 , not_fun res_env = ptext (sLit "Probable cause:") <+> quotes (ppr fun)
1562 <+> ptext (sLit "is applied to too few arguments")
1563 | has_args
1564 , not_fun res_fun = ptext (sLit "Possible cause:") <+> quotes (ppr fun)
1565 <+> ptext (sLit "is applied to too many arguments")
1566 | otherwise = Outputable.empty -- Never suggest that a naked variable is
1567 -- applied to too many args!
1568 ; return (tidy_env, info) }
1569 where
1570 not_fun ty -- ty is definitely not an arrow type,
1571 -- and cannot conceivably become one
1572 = case tcSplitTyConApp_maybe ty of
1573 Just (tc, _) -> isAlgTyCon tc
1574 Nothing -> False
1575
1576 badFieldTypes :: [(Name,TcType)] -> SDoc
1577 badFieldTypes prs
1578 = hang (ptext (sLit "Record update for insufficiently polymorphic field")
1579 <> plural prs <> colon)
1580 2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])
1581
1582 badFieldsUpd
1583 :: HsRecFields Name a -- Field names that don't belong to a single datacon
1584 -> [DataCon] -- Data cons of the type which the first field name belongs to
1585 -> SDoc
1586 badFieldsUpd rbinds data_cons
1587 = hang (ptext (sLit "No constructor has all these fields:"))
1588 2 (pprQuotedList conflictingFields)
1589 -- See Note [Finding the conflicting fields]
1590 where
1591 -- A (preferably small) set of fields such that no constructor contains
1592 -- all of them. See Note [Finding the conflicting fields]
1593 conflictingFields = case nonMembers of
1594 -- nonMember belongs to a different type.
1595 (nonMember, _) : _ -> [aMember, nonMember]
1596 [] -> let
1597 -- All of rbinds belong to one type. In this case, repeatedly add
1598 -- a field to the set until no constructor contains the set.
1599
1600 -- Each field, together with a list indicating which constructors
1601 -- have all the fields so far.
1602 growingSets :: [(Name, [Bool])]
1603 growingSets = scanl1 combine membership
1604 combine (_, setMem) (field, fldMem)
1605 = (field, zipWith (&&) setMem fldMem)
1606 in
1607 -- Fields that don't change the membership status of the set
1608 -- are redundant and can be dropped.
1609 map (fst . head) $ groupBy ((==) `on` snd) growingSets
1610
1611 aMember = ASSERT( not (null members) ) fst (head members)
1612 (members, nonMembers) = partition (or . snd) membership
1613
1614 -- For each field, which constructors contain the field?
1615 membership :: [(Name, [Bool])]
1616 membership = sortMembership $
1617 map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $
1618 hsRecFields rbinds
1619
1620 fieldLabelSets :: [Set.Set Name]
1621 fieldLabelSets = map (Set.fromList . dataConFieldLabels) data_cons
1622
1623 -- Sort in order of increasing number of True, so that a smaller
1624 -- conflicting set can be found.
1625 sortMembership =
1626 map snd .
1627 sortBy (compare `on` fst) .
1628 map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
1629
1630 countTrue = length . filter id
1631
1632 {-
1633 Note [Finding the conflicting fields]
1634 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1635 Suppose we have
1636 data A = A {a0, a1 :: Int}
1637 | B {b0, b1 :: Int}
1638 and we see a record update
1639 x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
1640 Then we'd like to find the smallest subset of fields that no
1641 constructor has all of. Here, say, {a0,b0}, or {a0,b1}, etc.
1642 We don't really want to report that no constructor has all of
1643 {a0,a1,b0,b1}, because when there are hundreds of fields it's
1644 hard to see what was really wrong.
1645
1646 We may need more than two fields, though; eg
1647 data T = A { x,y :: Int, v::Int }
1648 | B { y,z :: Int, v::Int }
1649 | C { z,x :: Int, v::Int }
1650 with update
1651 r { x=e1, y=e2, z=e3 }, we
1652
1653 Finding the smallest subset is hard, so the code here makes
1654 a decent stab, no more. See Trac #7989.
1655 -}
1656
1657 naughtyRecordSel :: TcId -> SDoc
1658 naughtyRecordSel sel_id
1659 = ptext (sLit "Cannot use record selector") <+> quotes (ppr sel_id) <+>
1660 ptext (sLit "as a function due to escaped type variables") $$
1661 ptext (sLit "Probable fix: use pattern-matching syntax instead")
1662
1663 notSelector :: Name -> SDoc
1664 notSelector field
1665 = hsep [quotes (ppr field), ptext (sLit "is not a record selector")]
1666
1667 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1668 missingStrictFields con fields
1669 = header <> rest
1670 where
1671 rest | null fields = Outputable.empty -- Happens for non-record constructors
1672 -- with strict fields
1673 | otherwise = colon <+> pprWithCommas ppr fields
1674
1675 header = ptext (sLit "Constructor") <+> quotes (ppr con) <+>
1676 ptext (sLit "does not have the required strict field(s)")
1677
1678 missingFields :: DataCon -> [FieldLabel] -> SDoc
1679 missingFields con fields
1680 = ptext (sLit "Fields of") <+> quotes (ppr con) <+> ptext (sLit "not initialised:")
1681 <+> pprWithCommas ppr fields
1682
1683 -- callCtxt fun args = ptext (sLit "In the call") <+> parens (ppr (foldl mkHsApp fun args))