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