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