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