compiler/typecheck/TcExpr.lhs

   1 %
   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,
   9                 tcMonoExpr, tcInferRho, tcSyntaxOp ) where
  10
  11 #include "HsVersions.h"
  12
  13 #ifdef GHCI     /* Only if bootstrapped */
  14 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  15 import qualified DsMeta
  16 #endif
  17
  18 import HsSyn
  19 import TcHsSyn
  20 import TcRnMonad
  21 import TcUnify
  22 import BasicTypes
  23 import Inst
  24 import TcBinds
  25 import TcEnv
  26 import TcArrows
  27 import TcMatches
  28 import TcHsType
  29 import TcPat
  30 import TcMType
  31 import TcType
  32 import Id
  33 import DataCon
  34 import Name
  35 import TyCon
  36 import Type
  37 import Var
  38 import VarSet
  39 import TysWiredIn
  40 import PrelNames
  41 import PrimOp
  42 import DynFlags
  43 import StaticFlags
  44 import HscTypes
  45 import SrcLoc
  46 import Util
  47 import ListSetOps
  48 import Maybes
  49 import Outputable
  50 import FastString
  51 \end{code}
  52
  53 %************************************************************************
  54 %*                                                                      *
  55 \subsection{Main wrappers}
  56 %*                                                                      *
  57 %************************************************************************
  58
  59 \begin{code}
  60 tcPolyExpr, tcPolyExprNC
  61          :: LHsExpr Name                -- Expession to type check
  62          -> BoxySigmaType               -- Expected type (could be a polytpye)
  63          -> TcM (LHsExpr TcId)  -- Generalised expr with expected type
  64
  65 -- tcPolyExpr is a convenient place (frequent but not too frequent) place
  66 -- to add context information.
  67 -- The NC version does not do so, usually because the caller wants
  68 -- to do so himself.
  69
  70 tcPolyExpr expr res_ty
  71   = addErrCtxt (exprCtxt (unLoc expr)) $
  72     tcPolyExprNC expr res_ty
  73
  74 tcPolyExprNC expr res_ty
  75   | isSigmaTy res_ty
  76   = do  { (gen_fn, expr') <- tcGen res_ty emptyVarSet (\_ -> tcPolyExprNC expr)
  77                 -- Note the recursive call to tcPolyExpr, because the
  78                 -- type may have multiple layers of for-alls
  79         ; return (mkLHsWrap gen_fn expr') }
  80
  81   | otherwise
  82   = tcMonoExpr expr res_ty
  83
  84 ---------------
  85 tcPolyExprs :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
  86 tcPolyExprs [] [] = returnM []
  87 tcPolyExprs (expr:exprs) (ty:tys)
  88  = do   { expr'  <- tcPolyExpr  expr  ty
  89         ; exprs' <- tcPolyExprs exprs tys
  90         ; returnM (expr':exprs') }
  91 tcPolyExprs exprs tys = pprPanic "tcPolyExprs" (ppr exprs $$ ppr tys)
  92
  93 ---------------
  94 tcMonoExpr :: LHsExpr Name      -- Expression to type check
  95            -> BoxyRhoType       -- Expected type (could be a type variable)
  96                                 -- Definitely no foralls at the top
  97                                 -- Can contain boxes, which will be filled in
  98            -> TcM (LHsExpr TcId)
  99
 100 tcMonoExpr (L loc expr) res_ty
 101   = ASSERT( not (isSigmaTy res_ty) )
 102     setSrcSpan loc $
 103     do  { expr' <- tcExpr expr res_ty
 104         ; return (L loc expr') }
 105
 106 ---------------
 107 tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 108 tcInferRho expr = tcInfer (tcMonoExpr expr)
 109 \end{code}
 110
 111
 112
 113 %************************************************************************
 114 %*                                                                      *
 115         tcExpr: the main expression typechecker
 116 %*                                                                      *
 117 %************************************************************************
 118
 119 \begin{code}
 120 tcExpr :: HsExpr Name -> BoxyRhoType -> TcM (HsExpr TcId)
 121 tcExpr (HsVar name)     res_ty = tcId (OccurrenceOf name) name res_ty
 122
 123 tcExpr (HsLit lit)      res_ty = do { boxyUnify (hsLitType lit) res_ty
 124                                     ; return (HsLit lit) }
 125
 126 tcExpr (HsPar expr)     res_ty = do { expr' <- tcMonoExpr expr res_ty
 127                                     ; return (HsPar expr') }
 128
 129 tcExpr (HsSCC lbl expr) res_ty = do { expr' <- tcMonoExpr expr res_ty
 130                                     ; returnM (HsSCC lbl expr') }
 131
 132 tcExpr (HsCoreAnn lbl expr) res_ty       -- hdaume: core annotation
 133   = do  { expr' <- tcMonoExpr expr res_ty
 134         ; return (HsCoreAnn lbl expr') }
 135
 136 tcExpr (HsOverLit lit) res_ty
 137   = do  { lit' <- tcOverloadedLit (LiteralOrigin lit) lit res_ty
 138         ; return (HsOverLit lit') }
 139
 140 tcExpr (NegApp expr neg_expr) res_ty
 141   = do  { neg_expr' <- tcSyntaxOp (OccurrenceOf negateName) neg_expr
 142                                   (mkFunTy res_ty res_ty)
 143         ; expr' <- tcMonoExpr expr res_ty
 144         ; return (NegApp expr' neg_expr') }
 145
 146 tcExpr (HsIPVar ip) res_ty
 147   = do  {       -- Implicit parameters must have a *tau-type* not a
 148                 -- type scheme.  We enforce this by creating a fresh
 149                 -- type variable as its type.  (Because res_ty may not
 150                 -- be a tau-type.)
 151           ip_ty <- newFlexiTyVarTy argTypeKind  -- argTypeKind: it can't be an unboxed tuple
 152         ; co_fn <- tcSubExp ip_ty res_ty
 153         ; (ip', inst) <- newIPDict (IPOccOrigin ip) ip ip_ty
 154         ; extendLIE inst
 155         ; return (mkHsWrap co_fn (HsIPVar ip')) }
 156
 157 tcExpr (HsApp e1 e2) res_ty
 158   = go e1 [e2]
 159   where
 160     go :: LHsExpr Name -> [LHsExpr Name] -> TcM (HsExpr TcId)
 161     go (L _ (HsApp e1 e2)) args = go e1 (e2:args)
 162     go lfun@(L loc fun) args
 163         = do { (fun', args') <- -- addErrCtxt (callCtxt lfun args) $
 164                                 tcApp fun (length args) (tcArgs lfun args) res_ty
 165              ; return (unLoc (foldl mkHsApp (L loc fun') args')) }
 166
 167 tcExpr (HsLam match) res_ty
 168   = do  { (co_fn, match') <- tcMatchLambda match res_ty
 169         ; return (mkHsWrap co_fn (HsLam match')) }
 170
 171 tcExpr in_expr@(ExprWithTySig expr sig_ty) res_ty
 172  = do   { sig_tc_ty <- tcHsSigType ExprSigCtxt sig_ty
 173
 174         -- Remember to extend the lexical type-variable environment
 175         ; (gen_fn, expr') <- tcGen sig_tc_ty emptyVarSet (\ skol_tvs res_ty ->
 176                              tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
 177                              tcPolyExprNC expr res_ty)
 178
 179         ; co_fn <- tcSubExp sig_tc_ty res_ty
 180         ; return (mkHsWrap co_fn (ExprWithTySigOut (mkLHsWrap gen_fn expr') sig_ty)) }
 181
 182 tcExpr (HsType ty) res_ty
 183   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 184         -- This is the syntax for type applications that I was planning
 185         -- but there are difficulties (e.g. what order for type args)
 186         -- so it's not enabled yet.
 187         -- Can't eliminate it altogether from the parser, because the
 188         -- same parser parses *patterns*.
 189 \end{code}
 190
 191
 192 %************************************************************************
 193 %*                                                                      *
 194                 Infix operators and sections
 195 %*                                                                      *
 196 %************************************************************************
 197
 198 \begin{code}
 199 tcExpr in_expr@(OpApp arg1 lop@(L loc op) fix arg2) res_ty
 200   = do  { (op', [arg1', arg2']) <- tcApp op 2 (tcArgs lop [arg1,arg2]) res_ty
 201         ; return (OpApp arg1' (L loc op') fix arg2') }
 202
 203 -- Left sections, equivalent to
 204 --      \ x -> e op x,
 205 -- or
 206 --      \ x -> op e x,
 207 -- or just
 208 --      op e
 209 --
 210 -- We treat it as similar to the latter, so we don't
 211 -- actually require the function to take two arguments
 212 -- at all.  For example, (x `not`) means (not x);
 213 -- you get postfix operators!  Not really Haskell 98
 214 -- I suppose, but it's less work and kind of useful.
 215
 216 tcExpr in_expr@(SectionL arg1 lop@(L loc op)) res_ty
 217   = do  { (op', [arg1']) <- tcApp op 1 (tcArgs lop [arg1]) res_ty
 218         ; return (SectionL arg1' (L loc op')) }
 219
 220 -- Right sections, equivalent to \ x -> x `op` expr, or
 221 --      \ x -> op x expr
 222
 223 tcExpr in_expr@(SectionR lop@(L loc op) arg2) res_ty
 224   = do  { (co_fn, (op', arg2')) <- subFunTys doc 1 res_ty $ \ [arg1_ty'] res_ty' ->
 225                                    tcApp op 2 (tc_args arg1_ty') res_ty'
 226         ; return (mkHsWrap co_fn (SectionR (L loc op') arg2')) }
 227   where
 228     doc = ptext SLIT("The section") <+> quotes (ppr in_expr)
 229                 <+> ptext SLIT("takes one argument")
 230     tc_args arg1_ty' [arg1_ty, arg2_ty]
 231         = do { boxyUnify arg1_ty' arg1_ty
 232              ; tcArg lop (arg2, arg2_ty, 2) }
 233     tc_args arg1_ty' other = panic "tcExpr SectionR"
 234 \end{code}
 235
 236 \begin{code}
 237 tcExpr (HsLet binds expr) res_ty
 238   = do  { (binds', expr') <- tcLocalBinds binds $
 239                              tcMonoExpr expr res_ty
 240         ; return (HsLet binds' expr') }
 241
 242 tcExpr (HsCase scrut matches) exp_ty
 243   = do  {  -- We used to typecheck the case alternatives first.
 244            -- The case patterns tend to give good type info to use
 245            -- when typechecking the scrutinee.  For example
 246            --   case (map f) of
 247            --     (x:xs) -> ...
 248            -- will report that map is applied to too few arguments
 249            --
 250            -- But now, in the GADT world, we need to typecheck the scrutinee
 251            -- first, to get type info that may be refined in the case alternatives
 252           (scrut', scrut_ty) <- addErrCtxt (caseScrutCtxt scrut)
 253                                            (tcInferRho scrut)
 254
 255         ; traceTc (text "HsCase" <+> ppr scrut_ty)
 256         ; matches' <- tcMatchesCase match_ctxt scrut_ty matches exp_ty
 257         ; return (HsCase scrut' matches') }
 258  where
 259     match_ctxt = MC { mc_what = CaseAlt,
 260                       mc_body = tcBody }
 261
 262 tcExpr (HsIf pred b1 b2) res_ty
 263   = do  { pred' <- addErrCtxt (predCtxt pred) $
 264                    tcMonoExpr pred boolTy
 265         ; b1' <- tcMonoExpr b1 res_ty
 266         ; b2' <- tcMonoExpr b2 res_ty
 267         ; return (HsIf pred' b1' b2') }
 268
 269 tcExpr (HsDo do_or_lc stmts body _) res_ty
 270   = tcDoStmts do_or_lc stmts body res_ty
 271
 272 tcExpr in_expr@(ExplicitList _ exprs) res_ty    -- Non-empty list
 273   = do  { elt_ty <- boxySplitListTy res_ty
 274         ; exprs' <- mappM (tc_elt elt_ty) exprs
 275         ; return (ExplicitList elt_ty exprs') }
 276   where
 277     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 278
 279 tcExpr in_expr@(ExplicitPArr _ exprs) res_ty    -- maybe empty
 280   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 281         ; exprs' <- mappM (tc_elt elt_ty) exprs
 282         ; ifM (null exprs) (zapToMonotype elt_ty)
 283                 -- If there are no expressions in the comprehension
 284                 -- we must still fill in the box
 285                 -- (Not needed for [] and () becuase they happen
 286                 --  to parse as data constructors.)
 287         ; return (ExplicitPArr elt_ty exprs') }
 288   where
 289     tc_elt elt_ty expr = tcPolyExpr expr elt_ty
 290
 291 tcExpr (ExplicitTuple exprs boxity) res_ty
 292   = do  { arg_tys <- boxySplitTyConApp (tupleTyCon boxity (length exprs)) res_ty
 293         ; exprs' <-  tcPolyExprs exprs arg_tys
 294         ; return (ExplicitTuple exprs' boxity) }
 295
 296 tcExpr (HsProc pat cmd) res_ty
 297   = do  { (pat', cmd') <- tcProc pat cmd res_ty
 298         ; return (HsProc pat' cmd') }
 299
 300 tcExpr e@(HsArrApp _ _ _ _ _) _
 301   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 302                       ptext SLIT("was found where an expression was expected")])
 303
 304 tcExpr e@(HsArrForm _ _ _) _
 305   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 306                       ptext SLIT("was found where an expression was expected")])
 307 \end{code}
 308
 309 %************************************************************************
 310 %*                                                                      *
 311                 Record construction and update
 312 %*                                                                      *
 313 %************************************************************************
 314
 315 \begin{code}
 316 tcExpr expr@(RecordCon (L loc con_name) _ rbinds) res_ty
 317   = do  { data_con <- tcLookupDataCon con_name
 318
 319         -- Check for missing fields
 320         ; checkMissingFields data_con rbinds
 321
 322         ; let arity = dataConSourceArity data_con
 323               check_fields arg_tys
 324                   = do  { rbinds' <- tcRecordBinds data_con arg_tys rbinds
 325                         ; mapM unBox arg_tys
 326                         ; return rbinds' }
 327                 -- The unBox ensures that all the boxes in arg_tys are indeed
 328                 -- filled, which is the invariant expected by tcIdApp
 329
 330         ; (con_expr, rbinds') <- tcIdApp con_name arity check_fields res_ty
 331
 332         ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
 333
 334 -- The main complication with RecordUpd is that we need to explicitly
 335 -- handle the *non-updated* fields.  Consider:
 336 --
 337 --      data T a b = MkT1 { fa :: a, fb :: b }
 338 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 339 --                 | MkT3 { fd :: a }
 340 --
 341 --      upd :: T a b -> c -> T a c
 342 --      upd t x = t { fb = x}
 343 --
 344 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 345 -- because upd should be equivalent to:
 346 --
 347 --      upd t x = case t of
 348 --                      MkT1 p q -> MkT1 p x
 349 --                      MkT2 a b -> MkT2 p b
 350 --                      MkT3 d   -> error ...
 351 --
 352 -- So we need to give a completely fresh type to the result record,
 353 -- and then constrain it by the fields that are *not* updated ("p" above).
 354 --
 355 -- Note that because MkT3 doesn't contain all the fields being updated,
 356 -- its RHS is simply an error, so it doesn't impose any type constraints
 357 --
 358 -- All this is done in STEP 4 below.
 359 --
 360 -- Note about GADTs
 361 -- ~~~~~~~~~~~~~~~~
 362 -- For record update we require that every constructor involved in the
 363 -- update (i.e. that has all the specified fields) is "vanilla".  I
 364 -- don't know how to do the update otherwise.
 365
 366
 367 tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 368   =     -- STEP 0
 369         -- Check that the field names are really field names
 370     ASSERT( notNull rbinds )
 371     let
 372         field_names = map fst rbinds
 373     in
 374     mappM (tcLookupField . unLoc) field_names   `thenM` \ sel_ids ->
 375         -- The renamer has already checked that they
 376         -- are all in scope
 377     let
 378         bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
 379                    | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
 380                      not (isRecordSelector sel_id)      -- Excludes class ops
 381                    ]
 382     in
 383     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 384
 385         -- STEP 1
 386         -- Figure out the tycon and data cons from the first field name
 387     let
 388                 -- It's OK to use the non-tc splitters here (for a selector)
 389         upd_field_lbls  = recBindFields rbinds
 390         sel_id : _      = sel_ids
 391         (tycon, _)      = recordSelectorFieldLabel sel_id       -- We've failed already if
 392         data_cons       = tyConDataCons tycon           -- it's not a field label
 393         relevant_cons   = filter is_relevant data_cons
 394         is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
 395     in
 396
 397         -- STEP 2
 398         -- Check that at least one constructor has all the named fields
 399         -- i.e. has an empty set of bad fields returned by badFields
 400     checkTc (not (null relevant_cons))
 401             (badFieldsUpd rbinds)       `thenM_`
 402
 403         -- Check that all relevant data cons are vanilla.  Doing record updates on
 404         -- GADTs and/or existentials is more than my tiny brain can cope with today
 405     checkTc (all isVanillaDataCon relevant_cons)
 406             (nonVanillaUpd tycon)       `thenM_`
 407
 408         -- STEP 4
 409         -- Use the un-updated fields to find a vector of booleans saying
 410         -- which type arguments must be the same in updatee and result.
 411         --
 412         -- WARNING: this code assumes that all data_cons in a common tycon
 413         -- have FieldLabels abstracted over the same tyvars.
 414     let
 415                 -- A constructor is only relevant to this process if
 416                 -- it contains *all* the fields that are being updated
 417         con1            = head relevant_cons    -- A representative constructor
 418         con1_tyvars     = dataConUnivTyVars con1
 419         con1_flds       = dataConFieldLabels con1
 420         con1_arg_tys    = dataConOrigArgTys con1
 421         common_tyvars   = exactTyVarsOfTypes [ty | (fld,ty) <- con1_flds `zip` con1_arg_tys
 422                                                  , not (fld `elem` upd_field_lbls) ]
 423
 424         is_common_tv tv = tv `elemVarSet` common_tyvars
 425
 426         mk_inst_ty tv result_inst_ty
 427           | is_common_tv tv = returnM result_inst_ty            -- Same as result type
 428           | otherwise       = newFlexiTyVarTy (tyVarKind tv)    -- Fresh type, of correct kind
 429     in
 430     tcInstTyVars con1_tyvars                            `thenM` \ (_, result_inst_tys, inst_env) ->
 431     zipWithM mk_inst_ty con1_tyvars result_inst_tys     `thenM` \ inst_tys ->
 432
 433         -- STEP 3
 434         -- Typecheck the update bindings.
 435         -- (Do this after checking for bad fields in case there's a field that
 436         --  doesn't match the constructor.)
 437     let
 438         result_record_ty = mkTyConApp tycon result_inst_tys
 439         con1_arg_tys'    = map (substTy inst_env) con1_arg_tys
 440     in
 441     tcSubExp result_record_ty res_ty            `thenM` \ co_fn ->
 442     tcRecordBinds con1 con1_arg_tys' rbinds     `thenM` \ rbinds' ->
 443
 444         -- STEP 5
 445         -- Typecheck the expression to be updated
 446     let
 447         record_ty = ASSERT( length inst_tys == tyConArity tycon )
 448                     mkTyConApp tycon inst_tys
 449         -- This is one place where the isVanilla check is important
 450         -- So that inst_tys matches the tycon
 451     in
 452     tcMonoExpr record_expr record_ty            `thenM` \ record_expr' ->
 453
 454         -- STEP 6
 455         -- Figure out the LIE we need.  We have to generate some
 456         -- dictionaries for the data type context, since we are going to
 457         -- do pattern matching over the data cons.
 458         --
 459         -- What dictionaries do we need?  The tyConStupidTheta tells us.
 460     let
 461         theta' = substTheta inst_env (tyConStupidTheta tycon)
 462     in
 463     instStupidTheta RecordUpdOrigin theta'      `thenM_`
 464
 465         -- Phew!
 466     returnM (mkHsWrap co_fn (RecordUpd record_expr' rbinds' record_ty result_record_ty))
 467 \end{code}
 468
 469
 470 %************************************************************************
 471 %*                                                                      *
 472         Arithmetic sequences                    e.g. [a,b..]
 473         and their parallel-array counterparts   e.g. [: a,b.. :]
 474
 475 %*                                                                      *
 476 %************************************************************************
 477
 478 \begin{code}
 479 tcExpr (ArithSeq _ seq@(From expr)) res_ty
 480   = do  { elt_ty <- boxySplitListTy res_ty
 481         ; expr' <- tcPolyExpr expr elt_ty
 482         ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
 483                               elt_ty enumFromName
 484         ; return (ArithSeq (HsVar enum_from) (From expr')) }
 485
 486 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
 487   = do  { elt_ty <- boxySplitListTy res_ty
 488         ; expr1' <- tcPolyExpr expr1 elt_ty
 489         ; expr2' <- tcPolyExpr expr2 elt_ty
 490         ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
 491                               elt_ty enumFromThenName
 492         ; return (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2')) }
 493
 494
 495 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
 496   = do  { elt_ty <- boxySplitListTy res_ty
 497         ; expr1' <- tcPolyExpr expr1 elt_ty
 498         ; expr2' <- tcPolyExpr expr2 elt_ty
 499         ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
 500                               elt_ty enumFromToName
 501         ; return (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 502
 503 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 504   = do  { elt_ty <- boxySplitListTy res_ty
 505         ; expr1' <- tcPolyExpr expr1 elt_ty
 506         ; expr2' <- tcPolyExpr expr2 elt_ty
 507         ; expr3' <- tcPolyExpr expr3 elt_ty
 508         ; eft <- newMethodFromName (ArithSeqOrigin seq)
 509                       elt_ty enumFromThenToName
 510         ; return (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 511
 512 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
 513   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 514         ; expr1' <- tcPolyExpr expr1 elt_ty
 515         ; expr2' <- tcPolyExpr expr2 elt_ty
 516         ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq)
 517                                       elt_ty enumFromToPName
 518         ; return (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2')) }
 519
 520 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 521   = do  { [elt_ty] <- boxySplitTyConApp parrTyCon res_ty
 522         ; expr1' <- tcPolyExpr expr1 elt_ty
 523         ; expr2' <- tcPolyExpr expr2 elt_ty
 524         ; expr3' <- tcPolyExpr expr3 elt_ty
 525         ; eft <- newMethodFromName (PArrSeqOrigin seq)
 526                       elt_ty enumFromThenToPName
 527         ; return (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3')) }
 528
 529 tcExpr (PArrSeq _ _) _
 530   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 531     -- the parser shouldn't have generated it and the renamer shouldn't have
 532     -- let it through
 533 \end{code}
 534
 535
 536 %************************************************************************
 537 %*                                                                      *
 538                 Template Haskell
 539 %*                                                                      *
 540 %************************************************************************
 541
 542 \begin{code}
 543 #ifdef GHCI     /* Only if bootstrapped */
 544         -- Rename excludes these cases otherwise
 545 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 546 tcExpr (HsBracket brack)  res_ty = do   { e <- tcBracket brack res_ty
 547                                         ; return (unLoc e) }
 548 #endif /* GHCI */
 549 \end{code}
 550
 551
 552 %************************************************************************
 553 %*                                                                      *
 554                 Catch-all
 555 %*                                                                      *
 556 %************************************************************************
 557
 558 \begin{code}
 559 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 560 \end{code}
 561
 562
 563 %************************************************************************
 564 %*                                                                      *
 565                 Applications
 566 %*                                                                      *
 567 %************************************************************************
 568
 569 \begin{code}
 570 ---------------------------
 571 tcApp :: HsExpr Name                            -- Function
 572       -> Arity                                  -- Number of args reqd
 573       -> ([BoxySigmaType] -> TcM arg_results)   -- Argument type-checker
 574       -> BoxyRhoType                            -- Result type
 575       -> TcM (HsExpr TcId, arg_results)
 576
 577 -- (tcFun fun n_args arg_checker res_ty)
 578 -- The argument type checker, arg_checker, will be passed exactly n_args types
 579
 580 tcApp (HsVar fun_name) n_args arg_checker res_ty
 581   = tcIdApp fun_name n_args arg_checker res_ty
 582
 583 tcApp fun n_args arg_checker res_ty     -- The vanilla case (rula APP)
 584   = do  { arg_boxes <- newBoxyTyVars (replicate n_args argTypeKind)
 585         ; fun'      <- tcExpr fun (mkFunTys (mkTyVarTys arg_boxes) res_ty)
 586         ; arg_tys'  <- mapM readFilledBox arg_boxes
 587         ; args'     <- arg_checker arg_tys'
 588         ; return (fun', args') }
 589
 590 ---------------------------
 591 tcIdApp :: Name                                 -- Function
 592         -> Arity                                -- Number of args reqd
 593         -> ([BoxySigmaType] -> TcM arg_results) -- Argument type-checker
 594                 -- The arg-checker guarantees to fill all boxes in the arg types
 595         -> BoxyRhoType                          -- Result type
 596         -> TcM (HsExpr TcId, arg_results)
 597
 598 -- Call         (f e1 ... en) :: res_ty
 599 -- Type         f :: forall a b c. theta => fa_1 -> ... -> fa_k -> fres
 600 --                      (where k <= n; fres has the rest)
 601 -- NB:  if k < n then the function doesn't have enough args, and
 602 --      presumably fres is a type variable that we are going to
 603 --      instantiate with a function type
 604 --
 605 -- Then         fres <= bx_(k+1) -> ... -> bx_n -> res_ty
 606
 607 tcIdApp fun_name n_args arg_checker res_ty
 608   = do  { let orig = OccurrenceOf fun_name
 609         ; (fun, fun_ty) <- lookupFun orig fun_name
 610
 611         -- Split up the function type
 612         ; let (tv_theta_prs, rho) = tcMultiSplitSigmaTy fun_ty
 613               (fun_arg_tys, fun_res_ty) = tcSplitFunTysN rho n_args
 614
 615               qtvs = concatMap fst tv_theta_prs         -- Quantified tyvars
 616               arg_qtvs = exactTyVarsOfTypes fun_arg_tys
 617               res_qtvs = exactTyVarsOfType fun_res_ty
 618                 -- NB: exactTyVarsOfType.  See Note [Silly type synonyms in smart-app]
 619               tau_qtvs = arg_qtvs `unionVarSet` res_qtvs
 620               k              = length fun_arg_tys       -- k <= n_args
 621               n_missing_args = n_args - k               -- Always >= 0
 622
 623         -- Match the result type of the function with the
 624         -- result type of the context, to get an inital substitution
 625         ; extra_arg_boxes <- newBoxyTyVars (replicate n_missing_args argTypeKind)
 626         ; let extra_arg_tys' = mkTyVarTys extra_arg_boxes
 627               res_ty'        = mkFunTys extra_arg_tys' res_ty
 628         ; qtys' <- preSubType qtvs tau_qtvs fun_res_ty res_ty'
 629         ; let arg_subst    = zipOpenTvSubst qtvs qtys'
 630               fun_arg_tys' = substTys arg_subst fun_arg_tys
 631
 632         -- Typecheck the arguments!
 633         -- Doing so will fill arg_qtvs and extra_arg_tys'
 634         ; args' <- arg_checker (fun_arg_tys' ++ extra_arg_tys')
 635
 636         -- Strip boxes from the qtvs that have been filled in by the arg checking
 637         -- AND any variables that are mentioned in neither arg nor result
 638         -- the latter are mentioned only in constraints; stripBoxyType will
 639         -- fill them with a monotype
 640         ; let strip qtv qty' | qtv `elemVarSet` arg_qtvs = stripBoxyType qty'
 641                              | otherwise                 = return qty'
 642         ; qtys'' <- zipWithM strip qtvs qtys'
 643         ; extra_arg_tys'' <- mapM readFilledBox extra_arg_boxes
 644
 645         -- Result subsumption
 646         ; let res_subst = zipOpenTvSubst qtvs qtys''
 647               fun_res_ty'' = substTy res_subst fun_res_ty
 648               res_ty'' = mkFunTys extra_arg_tys'' res_ty
 649         ; co_fn <- tcFunResTy fun_name fun_res_ty'' res_ty''
 650
 651         -- And pack up the results
 652         -- By applying the coercion just to the *function* we can make
 653         -- tcFun work nicely for OpApp and Sections too
 654         ; fun' <- instFun orig fun res_subst tv_theta_prs
 655         ; co_fn' <- wrapFunResCoercion fun_arg_tys' co_fn
 656         ; return (mkHsWrap co_fn' fun', args') }
 657 \end{code}
 658
 659 Note [Silly type synonyms in smart-app]
 660 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 661 When we call sripBoxyType, all of the boxes should be filled
 662 in.  But we need to be careful about type synonyms:
 663         type T a = Int
 664         f :: T a -> Int
 665         ...(f x)...
 666 In the call (f x) we'll typecheck x, expecting it to have type
 667 (T box).  Usually that would fill in the box, but in this case not;
 668 because 'a' is discarded by the silly type synonym T.  So we must
 669 use exactTyVarsOfType to figure out which type variables are free
 670 in the argument type.
 671
 672 \begin{code}
 673 -- tcId is a specialisation of tcIdApp when there are no arguments
 674 -- tcId f ty = do { (res, _) <- tcIdApp f [] (\[] -> return ()) ty
 675 --                ; return res }
 676
 677 tcId :: InstOrigin
 678      -> Name                                    -- Function
 679      -> BoxyRhoType                             -- Result type
 680      -> TcM (HsExpr TcId)
 681 tcId orig fun_name res_ty
 682   = do  { traceTc (text "tcId" <+> ppr fun_name <+> ppr res_ty)
 683         ; (fun, fun_ty) <- lookupFun orig fun_name
 684
 685         -- Split up the function type
 686         ; let (tv_theta_prs, fun_tau) = tcMultiSplitSigmaTy fun_ty
 687               qtvs = concatMap fst tv_theta_prs -- Quantified tyvars
 688               tau_qtvs = exactTyVarsOfType fun_tau      -- Mentioned in the tau part
 689         ; qtv_tys <- preSubType qtvs tau_qtvs fun_tau res_ty
 690
 691         -- Do the subsumption check wrt the result type
 692         ; let res_subst = zipTopTvSubst qtvs qtv_tys
 693               fun_tau'  = substTy res_subst fun_tau
 694
 695         ; co_fn <- tcFunResTy fun_name fun_tau' res_ty
 696
 697         -- And pack up the results
 698         ; fun' <- instFun orig fun res_subst tv_theta_prs
 699         ; return (mkHsWrap co_fn fun') }
 700
 701 --      Note [Push result type in]
 702 --
 703 -- Unify with expected result before (was: after) type-checking the args
 704 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
 705 -- This is when we might detect a too-few args situation.
 706 -- (One can think of cases when the opposite order would give
 707 -- a better error message.)
 708 -- [March 2003: I'm experimenting with putting this first.  Here's an
 709 --              example where it actually makes a real difference
 710 --    class C t a b | t a -> b
 711 --    instance C Char a Bool
 712 --
 713 --    data P t a = forall b. (C t a b) => MkP b
 714 --    data Q t   = MkQ (forall a. P t a)
 715
 716 --    f1, f2 :: Q Char;
 717 --    f1 = MkQ (MkP True)
 718 --    f2 = MkQ (MkP True :: forall a. P Char a)
 719 --
 720 -- With the change, f1 will type-check, because the 'Char' info from
 721 -- the signature is propagated into MkQ's argument. With the check
 722 -- in the other order, the extra signature in f2 is reqd.]
 723
 724 ---------------------------
 725 tcSyntaxOp :: InstOrigin -> HsExpr Name -> TcType -> TcM (HsExpr TcId)
 726 -- Typecheck a syntax operator, checking that it has the specified type
 727 -- The operator is always a variable at this stage (i.e. renamer output)
 728 tcSyntaxOp orig (HsVar op) ty = tcId orig op ty
 729 tcSyntaxOp orig other      ty = pprPanic "tcSyntaxOp" (ppr other)
 730
 731 ---------------------------
 732 instFun :: InstOrigin
 733         -> HsExpr TcId
 734         -> TvSubst                -- The instantiating substitution
 735         -> [([TyVar], ThetaType)] -- Stuff to instantiate
 736         -> TcM (HsExpr TcId)
 737
 738 instFun orig fun subst []
 739   = return fun          -- Common short cut
 740
 741 instFun orig fun subst tv_theta_prs
 742   = do  { let ty_theta_prs' = map subst_pr tv_theta_prs
 743
 744                 -- Make two ad-hoc checks
 745         ; doStupidChecks fun ty_theta_prs'
 746
 747                 -- Now do normal instantiation
 748         ; go True fun ty_theta_prs' }
 749   where
 750     subst_pr (tvs, theta)
 751         = (map (substTyVar subst) tvs, substTheta subst theta)
 752
 753     go _ fun [] = return fun
 754
 755     go True (HsVar fun_id) ((tys,theta) : prs)
 756         | want_method_inst theta
 757         = do { meth_id <- newMethodWithGivenTy orig fun_id tys
 758              ; go False (HsVar meth_id) prs }
 759                 -- Go round with 'False' to prevent further use
 760                 -- of newMethod: see Note [Multiple instantiation]
 761
 762     go _ fun ((tys, theta) : prs)
 763         = do { co_fn <- instCall orig tys theta
 764              ; go False (HsWrap co_fn fun) prs }
 765
 766         -- See Note [No method sharing]
 767     want_method_inst theta =  not (null theta)  -- Overloaded
 768                            && not opt_NoMethodSharing
 769 \end{code}
 770
 771 Note [Multiple instantiation]
 772 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 773 We are careful never to make a MethodInst that has, as its meth_id, another MethodInst.
 774 For example, consider
 775         f :: forall a. Eq a => forall b. Ord b => a -> b
 776 At a call to f, at say [Int, Bool], it's tempting to translate the call to
 777
 778         f_m1
 779   where
 780         f_m1 :: forall b. Ord b => Int -> b
 781         f_m1 = f Int dEqInt
 782
 783         f_m2 :: Int -> Bool
 784         f_m2 = f_m1 Bool dOrdBool
 785
 786 But notice that f_m2 has f_m1 as its meth_id.  Now the danger is that if we do
 787 a tcSimplCheck with a Given f_mx :: f Int dEqInt, we may make a binding
 788         f_m1 = f_mx
 789 But it's entirely possible that f_m2 will continue to float out, because it
 790 mentions no type variables.  Result, f_m1 isn't in scope.
 791
 792 Here's a concrete example that does this (test tc200):
 793
 794     class C a where
 795       f :: Eq b => b -> a -> Int
 796       baz :: Eq a => Int -> a -> Int
 797
 798     instance C Int where
 799       baz = f
 800
 801 Current solution: only do the "method sharing" thing for the first type/dict
 802 application, not for the iterated ones.  A horribly subtle point.
 803
 804 Note [No method sharing]
 805 ~~~~~~~~~~~~~~~~~~~~~~~~
 806 The -fno-method-sharing flag controls what happens so far as the LIE
 807 is concerned.  The default case is that for an overloaded function we
 808 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 809 something like
 810         f :: Num a => a -> a
 811         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 812 If you specify -fno-method-sharing, the dictionary application
 813 isn't shared, so we get
 814         f :: Num a => a -> a
 815         f = /\a (d:Num a) (x:a) -> (+) a d x x
 816 This gets a bit less sharing, but
 817         a) it's better for RULEs involving overloaded functions
 818         b) perhaps fewer separated lambdas
 819
 820 \begin{code}
 821 tcArgs :: LHsExpr Name                          -- The function (for error messages)
 822        -> [LHsExpr Name] -> [TcSigmaType]       -- Actual arguments and expected arg types
 823        -> TcM [LHsExpr TcId]                    -- Resulting args
 824
 825 tcArgs fun args expected_arg_tys
 826   = mapM (tcArg fun) (zip3 args expected_arg_tys [1..])
 827
 828 tcArg :: LHsExpr Name                           -- The function (for error messages)
 829        -> (LHsExpr Name, BoxySigmaType, Int)    -- Actual argument and expected arg type
 830        -> TcM (LHsExpr TcId)                    -- Resulting argument
 831 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no) $
 832                               tcPolyExprNC arg ty
 833 \end{code}
 834
 835
 836 Note [tagToEnum#]
 837 ~~~~~~~~~~~~~~~~~
 838 Nasty check to ensure that tagToEnum# is applied to a type that is an
 839 enumeration TyCon.  Unification may refine the type later, but this
 840 check won't see that, alas.  It's crude but it works.
 841
 842 Here's are two cases that should fail
 843         f :: forall a. a
 844         f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable
 845
 846         g :: Int
 847         g = tagToEnum# 0        -- Int is not an enumeration
 848
 849
 850 \begin{code}
 851 doStupidChecks :: HsExpr TcId
 852                -> [([TcType], ThetaType)]
 853                -> TcM ()
 854 -- Check two tiresome and ad-hoc cases
 855 -- (a) the "stupid theta" for a data con; add the constraints
 856 --     from the "stupid theta" of a data constructor (sigh)
 857 -- (b) deal with the tagToEnum# problem: see Note [tagToEnum#]
 858
 859 doStupidChecks (HsVar fun_id) ((tys,_):_)
 860   | Just con <- isDataConId_maybe fun_id   -- (a)
 861   = addDataConStupidTheta con tys
 862
 863   | fun_id `hasKey` tagToEnumKey           -- (b)
 864   = do  { tys' <- zonkTcTypes tys
 865         ; checkTc (ok tys') (tagToEnumError tys')
 866         }
 867   where
 868     ok []       = False
 869     ok (ty:tys) = case tcSplitTyConApp_maybe ty of
 870                         Just (tc,_) -> isEnumerationTyCon tc
 871                         Nothing     -> False
 872
 873 doStupidChecks fun tv_theta_prs
 874   = return () -- The common case
 875
 876
 877 tagToEnumError tys
 878   = hang (ptext SLIT("Bad call to tagToEnum#") <+> at_type)
 879          2 (vcat [ptext SLIT("Specify the type by giving a type signature"),
 880                   ptext SLIT("e.g. (tagToEnum# x) :: Bool")])
 881   where
 882     at_type | null tys = empty  -- Probably never happens
 883             | otherwise = ptext SLIT("at type") <+> ppr (head tys)
 884 \end{code}
 885
 886 %************************************************************************
 887 %*                                                                      *
 888 \subsection{@tcId@ typchecks an identifier occurrence}
 889 %*                                                                      *
 890 %************************************************************************
 891
 892 \begin{code}
 893 lookupFun :: InstOrigin -> Name -> TcM (HsExpr TcId, TcType)
 894 lookupFun orig id_name
 895   = do  { thing <- tcLookup id_name
 896         ; case thing of
 897             AGlobal (ADataCon con) -> return (HsVar wrap_id, idType wrap_id)
 898                                    where
 899                                       wrap_id = dataConWrapId con
 900
 901             AGlobal (AnId id)
 902                 | isNaughtyRecordSelector id -> failWithTc (naughtyRecordSel id)
 903                 | otherwise                  -> return (HsVar id, idType id)
 904                 -- A global cannot possibly be ill-staged
 905                 -- nor does it need the 'lifting' treatment
 906
 907             ATcId { tct_id = id, tct_type = ty, tct_co = mb_co, tct_level = lvl }
 908                 -> do { thLocalId orig id ty lvl
 909                       ; case mb_co of
 910                           Nothing -> return (HsVar id, ty)      -- Wobbly, or no free vars
 911                           Just co -> return (mkHsWrap co (HsVar id), ty) }
 912
 913             other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
 914     }
 915
 916 #ifndef GHCI  /* GHCI and TH is off */
 917 --------------------------------------
 918 -- thLocalId : Check for cross-stage lifting
 919 thLocalId orig id id_ty th_bind_lvl
 920   = return ()
 921
 922 #else         /* GHCI and TH is on */
 923 thLocalId orig id id_ty th_bind_lvl
 924   = do  { use_stage <- getStage -- TH case
 925         ; case use_stage of
 926             Brack use_lvl ps_var lie_var | use_lvl > th_bind_lvl
 927                   -> thBrackId orig id ps_var lie_var
 928             other -> do { checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage
 929                         ; return id }
 930         }
 931
 932 --------------------------------------
 933 thBrackId orig id ps_var lie_var
 934   | isExternalName id_name
 935   =     -- Top-level identifiers in this module,
 936         -- (which have External Names)
 937         -- are just like the imported case:
 938         -- no need for the 'lifting' treatment
 939         -- E.g.  this is fine:
 940         --   f x = x
 941         --   g y = [| f 3 |]
 942         -- But we do need to put f into the keep-alive
 943         -- set, because after desugaring the code will
 944         -- only mention f's *name*, not f itself.
 945     do  { keepAliveTc id_name; return id }
 946
 947   | otherwise
 948   =     -- Nested identifiers, such as 'x' in
 949         -- E.g. \x -> [| h x |]
 950         -- We must behave as if the reference to x was
 951         --      h $(lift x)
 952         -- We use 'x' itself as the splice proxy, used by
 953         -- the desugarer to stitch it all back together.
 954         -- If 'x' occurs many times we may get many identical
 955         -- bindings of the same splice proxy, but that doesn't
 956         -- matter, although it's a mite untidy.
 957     do  { let id_ty = idType id
 958         ; checkTc (isTauTy id_ty) (polySpliceErr id)
 959                -- If x is polymorphic, its occurrence sites might
 960                -- have different instantiations, so we can't use plain
 961                -- 'x' as the splice proxy name.  I don't know how to
 962                -- solve this, and it's probably unimportant, so I'm
 963                -- just going to flag an error for now
 964
 965         ; id_ty' <- zapToMonotype id_ty
 966                 -- The id_ty might have an OpenTypeKind, but we
 967                 -- can't instantiate the Lift class at that kind,
 968                 -- so we zap it to a LiftedTypeKind monotype
 969                 -- C.f. the call in TcPat.newLitInst
 970
 971         ; setLIEVar lie_var     $ do
 972         { lift <- newMethodFromName orig id_ty' DsMeta.liftName
 973                    -- Put the 'lift' constraint into the right LIE
 974
 975                    -- Update the pending splices
 976         ; ps <- readMutVar ps_var
 977         ; writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)
 978
 979         ; return id } }
 980  where
 981    id_name = idName id
 982 #endif /* GHCI */
 983 \end{code}
 984
 985
 986 %************************************************************************
 987 %*                                                                      *
 988 \subsection{Record bindings}
 989 %*                                                                      *
 990 %************************************************************************
 991
 992 Game plan for record bindings
 993 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 994 1. Find the TyCon for the bindings, from the first field label.
 995
 996 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 997
 998 For each binding field = value
 999
1000 3. Instantiate the field type (from the field label) using the type
1001    envt from step 2.
1002
1003 4  Type check the value using tcArg, passing the field type as
1004    the expected argument type.
1005
1006 This extends OK when the field types are universally quantified.
1007
1008
1009 \begin{code}
1010 tcRecordBinds
1011         :: DataCon
1012         -> [TcType]     -- Expected type for each field
1013         -> HsRecordBinds Name
1014         -> TcM (HsRecordBinds TcId)
1015
1016 tcRecordBinds data_con arg_tys rbinds
1017   = do  { mb_binds <- mappM do_bind rbinds
1018         ; return (catMaybes mb_binds) }
1019   where
1020     flds_w_tys = zipEqual "tcRecordBinds" (dataConFieldLabels data_con) arg_tys
1021     do_bind (L loc field_lbl, rhs)
1022       | Just field_ty <- assocMaybe flds_w_tys field_lbl
1023       = addErrCtxt (fieldCtxt field_lbl)        $
1024         do { rhs'   <- tcPolyExprNC rhs field_ty
1025            ; sel_id <- tcLookupField field_lbl
1026            ; ASSERT( isRecordSelector sel_id )
1027              return (Just (L loc sel_id, rhs')) }
1028       | otherwise
1029       = do { addErrTc (badFieldCon data_con field_lbl)
1030            ; return Nothing }
1031
1032 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
1033 checkMissingFields data_con rbinds
1034   | null field_labels   -- Not declared as a record;
1035                         -- But C{} is still valid if no strict fields
1036   = if any isMarkedStrict field_strs then
1037         -- Illegal if any arg is strict
1038         addErrTc (missingStrictFields data_con [])
1039     else
1040         returnM ()
1041
1042   | otherwise           -- A record
1043   = checkM (null missing_s_fields)
1044            (addErrTc (missingStrictFields data_con missing_s_fields))   `thenM_`
1045
1046     doptM Opt_WarnMissingFields         `thenM` \ warn ->
1047     checkM (not (warn && notNull missing_ns_fields))
1048            (warnTc True (missingFields data_con missing_ns_fields))
1049
1050   where
1051     missing_s_fields
1052         = [ fl | (fl, str) <- field_info,
1053                  isMarkedStrict str,
1054                  not (fl `elem` field_names_used)
1055           ]
1056     missing_ns_fields
1057         = [ fl | (fl, str) <- field_info,
1058                  not (isMarkedStrict str),
1059                  not (fl `elem` field_names_used)
1060           ]
1061
1062     field_names_used = recBindFields rbinds
1063     field_labels     = dataConFieldLabels data_con
1064
1065     field_info = zipEqual "missingFields"
1066                           field_labels
1067                           field_strs
1068
1069     field_strs = dataConStrictMarks data_con
1070 \end{code}
1071
1072 %************************************************************************
1073 %*                                                                      *
1074 \subsection{Errors and contexts}
1075 %*                                                                      *
1076 %************************************************************************
1077
1078 Boring and alphabetical:
1079 \begin{code}
1080 caseScrutCtxt expr
1081   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1082
1083 exprCtxt expr
1084   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1085
1086 fieldCtxt field_name
1087   = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1088
1089 funAppCtxt fun arg arg_no
1090   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1091                     quotes (ppr fun) <> text ", namely"])
1092          4 (quotes (ppr arg))
1093
1094 predCtxt expr
1095   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1096
1097 nonVanillaUpd tycon
1098   = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
1099                 <+> ptext SLIT("is not (yet) supported"),
1100           ptext SLIT("Use pattern-matching instead")]
1101 badFieldsUpd rbinds
1102   = hang (ptext SLIT("No constructor has all these fields:"))
1103          4 (pprQuotedList (recBindFields rbinds))
1104
1105 naughtyRecordSel sel_id
1106   = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
1107     ptext SLIT("as a function due to escaped type variables") $$
1108     ptext SLIT("Probably fix: use pattern-matching syntax instead")
1109
1110 notSelector field
1111   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1112
1113 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1114 missingStrictFields con fields
1115   = header <> rest
1116   where
1117     rest | null fields = empty  -- Happens for non-record constructors
1118                                 -- with strict fields
1119          | otherwise   = colon <+> pprWithCommas ppr fields
1120
1121     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1122              ptext SLIT("does not have the required strict field(s)")
1123
1124 missingFields :: DataCon -> [FieldLabel] -> SDoc
1125 missingFields con fields
1126   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1127         <+> pprWithCommas ppr fields
1128
1129 callCtxt fun args
1130   = ptext SLIT("In the call") <+> parens (ppr (foldl mkHsApp fun args))
1131
1132 #ifdef GHCI
1133 polySpliceErr :: Id -> SDoc
1134 polySpliceErr id
1135   = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
1136 #endif
1137 \end{code}