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