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