ghc/compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcExpr]{Typecheck an expression}
   5
   6 \begin{code}
   7 module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where
   8
   9 #include "HsVersions.h"
  10
  11 #ifdef GHCI     /* Only if bootstrapped */
  12 import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcBracket )
  13 import Id               ( Id )
  14 import Name             ( isExternalName )
  15 import TcType           ( isTauTy )
  16 import TcEnv            ( checkWellStaged )
  17 import HsSyn            ( nlHsApp )
  18 import qualified DsMeta
  19 #endif
  20
  21 import HsSyn            ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields,
  22                           HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar )
  23 import TcHsSyn          ( hsLitType, (<$>) )
  24 import TcRnMonad
  25 import TcUnify          ( Expected(..), tcInfer, zapExpectedType, zapExpectedTo, tcSubExp, tcGen,
  26                           unifyFunTys, zapToListTy, zapToTyConApp )
  27 import BasicTypes       ( isMarkedStrict )
  28 import Inst             ( newOverloadedLit, newMethodFromName, newIPDict,
  29                           newDicts, newMethodWithGivenTy, tcInstStupidTheta, tcInstCall )
  30 import TcBinds          ( tcBindsAndThen )
  31 import TcEnv            ( tcLookup, tcLookupId, checkProcLevel,
  32                           tcLookupDataCon, tcLookupGlobalId
  33                         )
  34 import TcArrows         ( tcProc )
  35 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) )
  36 import TcHsType         ( tcHsSigType, UserTypeCtxt(..) )
  37 import TcPat            ( badFieldCon, refineTyVars )
  38 import TcMType          ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType )
  39 import TcType           ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType,
  40                           tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
  41                           isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred,
  42                           tcSplitSigmaTy, tidyOpenType
  43                         )
  44 import Kind             ( openTypeKind, liftedTypeKind, argTypeKind )
  45
  46 import Id               ( idType, recordSelectorFieldLabel, isRecordSelector )
  47 import DataCon          ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
  48 import Name             ( Name )
  49 import TyCon            ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta,
  50                           tyConDataCons, tyConFields )
  51 import Type             ( zipTopTvSubst, substTheta, substTy )
  52 import VarSet           ( emptyVarSet, elemVarSet )
  53 import TysWiredIn       ( boolTy, parrTyCon, tupleTyCon )
  54 import PrelNames        ( enumFromName, enumFromThenName,
  55                           enumFromToName, enumFromThenToName,
  56                           enumFromToPName, enumFromThenToPName
  57                         )
  58 import ListSetOps       ( minusList )
  59 import CmdLineOpts
  60 import HscTypes         ( TyThing(..) )
  61 import SrcLoc           ( Located(..), unLoc, getLoc )
  62 import Util
  63 import Outputable
  64 import FastString
  65
  66 #ifdef DEBUG
  67 import TyCon            ( isAlgTyCon )
  68 #endif
  69 \end{code}
  70
  71 %************************************************************************
  72 %*                                                                      *
  73 \subsection{Main wrappers}
  74 %*                                                                      *
  75 %************************************************************************
  76
  77 \begin{code}
  78 -- tcCheckSigma does type *checking*; it's passed the expected type of the result
  79 tcCheckSigma :: LHsExpr Name            -- Expession to type check
  80              -> TcSigmaType             -- Expected type (could be a polytpye)
  81              -> TcM (LHsExpr TcId)      -- Generalised expr with expected type
  82
  83 tcCheckSigma expr expected_ty
  84   = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_`
  85     tc_expr' expr expected_ty
  86
  87 tc_expr' expr sigma_ty
  88   | isSigmaTy sigma_ty
  89   = tcGen sigma_ty emptyVarSet (
  90         \ rho_ty -> tcCheckRho expr rho_ty
  91     )                           `thenM` \ (gen_fn, expr') ->
  92     returnM (L (getLoc expr') (gen_fn <$> unLoc expr'))
  93
  94 tc_expr' expr rho_ty    -- Monomorphic case
  95   = tcCheckRho expr rho_ty
  96 \end{code}
  97
  98 Typecheck expression which in most cases will be an Id.
  99 The expression can return a higher-ranked type, such as
 100         (forall a. a->a) -> Int
 101 so we must create a hole to pass in as the expected tyvar.
 102
 103 \begin{code}
 104 tcCheckRho :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId)
 105 tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty)
 106
 107 tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType)
 108 tcInferRho (L loc (HsVar name)) = setSrcSpan loc $ do
 109                                   { (e,_,ty) <- tcId name; return (L loc e, ty)}
 110 tcInferRho expr                 = tcInfer (tcMonoExpr expr)
 111 \end{code}
 112
 113
 114
 115 %************************************************************************
 116 %*                                                                      *
 117 \subsection{The TAUT rules for variables}TcExpr
 118 %*                                                                      *
 119 %************************************************************************
 120
 121 \begin{code}
 122 tcMonoExpr :: LHsExpr Name              -- Expession to type check
 123            -> Expected TcRhoType        -- Expected type (could be a type variable)
 124                                         -- Definitely no foralls at the top
 125                                         -- Can be a 'hole'.
 126            -> TcM (LHsExpr TcId)
 127
 128 tcMonoExpr (L loc expr) res_ty
 129   = setSrcSpan loc (do { expr' <- tc_expr expr res_ty
 130                        ; return (L loc expr') })
 131
 132 tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId)
 133 tc_expr (HsVar name) res_ty
 134   = do  { (expr', _, id_ty) <- tcId name
 135         ; co_fn <- tcSubExp res_ty id_ty
 136         ; returnM (co_fn <$> expr') }
 137
 138 tc_expr (HsIPVar ip) res_ty
 139   =     -- Implicit parameters must have a *tau-type* not a
 140         -- type scheme.  We enforce this by creating a fresh
 141         -- type variable as its type.  (Because res_ty may not
 142         -- be a tau-type.)
 143     newTyFlexiVarTy argTypeKind         `thenM` \ ip_ty ->
 144         -- argTypeKind: it can't be an unboxed tuple
 145     newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) ->
 146     extendLIE inst                      `thenM_`
 147     tcSubExp res_ty ip_ty               `thenM` \ co_fn ->
 148     returnM (co_fn <$> HsIPVar ip')
 149 \end{code}
 150
 151
 152 %************************************************************************
 153 %*                                                                      *
 154 \subsection{Expressions type signatures}
 155 %*                                                                      *
 156 %************************************************************************
 157
 158 \begin{code}
 159 tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty
 160  = addErrCtxt (exprCtxt in_expr)                        $
 161    tcHsSigType ExprSigCtxt poly_ty                      `thenM` \ sig_tc_ty ->
 162    tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty    `thenM` \ (co_fn, expr') ->
 163    returnM (co_fn <$> ExprWithTySigOut expr' poly_ty)
 164
 165 tc_expr (HsType ty) res_ty
 166   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 167         -- This is the syntax for type applications that I was planning
 168         -- but there are difficulties (e.g. what order for type args)
 169         -- so it's not enabled yet.
 170         -- Can't eliminate it altogether from the parser, because the
 171         -- same parser parses *patterns*.
 172 \end{code}
 173
 174
 175 %************************************************************************
 176 %*                                                                      *
 177 \subsection{Other expression forms}
 178 %*                                                                      *
 179 %************************************************************************
 180
 181 \begin{code}
 182 tc_expr (HsPar expr)    res_ty  = tcMonoExpr expr res_ty        `thenM` \ expr' ->
 183                                   returnM (HsPar expr')
 184 tc_expr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty        `thenM` \ expr' ->
 185                                   returnM (HsSCC lbl expr')
 186 tc_expr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' ->  -- hdaume: core annotation
 187                                          returnM (HsCoreAnn lbl expr')
 188
 189 tc_expr (HsLit lit) res_ty  = tcLit lit res_ty
 190
 191 tc_expr (HsOverLit lit) res_ty
 192   = zapExpectedType res_ty liftedTypeKind               `thenM` \ res_ty' ->
 193         -- Overloaded literals must have liftedTypeKind, because
 194         -- we're instantiating an overloaded function here,
 195         -- whereas res_ty might be openTypeKind. This was a bug in 6.2.2
 196     newOverloadedLit (LiteralOrigin lit) lit res_ty'    `thenM` \ lit_expr ->
 197     returnM (unLoc lit_expr)    -- ToDo: nasty unLoc
 198
 199 tc_expr (NegApp expr neg_name) res_ty
 200   = tc_expr (HsApp (nlHsVar neg_name) expr) res_ty
 201         -- ToDo: use tcSyntaxName
 202
 203 tc_expr (HsLam match) res_ty
 204   = tcMatchLambda match res_ty          `thenM` \ match' ->
 205     returnM (HsLam match')
 206
 207 tc_expr (HsApp e1 e2) res_ty
 208   = tcApp e1 [e2] res_ty
 209 \end{code}
 210
 211 Note that the operators in sections are expected to be binary, and
 212 a type error will occur if they aren't.
 213
 214 \begin{code}
 215 -- Left sections, equivalent to
 216 --      \ x -> e op x,
 217 -- or
 218 --      \ x -> op e x,
 219 -- or just
 220 --      op e
 221
 222 tc_expr in_expr@(SectionL arg1 op) res_ty
 223   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 224     unifyFunTys 2 op_ty {- two args -}          `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 225     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 226     addErrCtxt (exprCtxt in_expr)               $
 227     tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn ->
 228     returnM (co_fn <$> SectionL arg1' op')
 229
 230 -- Right sections, equivalent to \ x -> x op expr, or
 231 --      \ x -> op x expr
 232
 233 tc_expr in_expr@(SectionR op arg2) res_ty
 234   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 235     unifyFunTys 2 op_ty {- two args -}          `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 236     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 237     addErrCtxt (exprCtxt in_expr)               $
 238     tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn ->
 239     returnM (co_fn <$> SectionR op' arg2')
 240
 241 -- equivalent to (op e1) e2:
 242
 243 tc_expr in_expr@(OpApp arg1 op fix arg2) res_ty
 244   = tcInferRho op                               `thenM` \ (op', op_ty) ->
 245     unifyFunTys 2 op_ty {- two args -}          `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 246     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 247     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 248     addErrCtxt (exprCtxt in_expr)               $
 249     tcSubExp res_ty op_res_ty                   `thenM` \ co_fn ->
 250     returnM (OpApp arg1' op' fix arg2')
 251 \end{code}
 252
 253 \begin{code}
 254 tc_expr (HsLet binds (L loc expr)) res_ty
 255   = tcBindsAndThen
 256         glue
 257         binds                   -- Bindings to check
 258         (setSrcSpan loc $ tc_expr expr res_ty)
 259   where
 260     glue bind expr = HsLet [bind] (L loc expr)
 261
 262 tc_expr in_expr@(HsCase scrut matches) exp_ty
 263   =     -- We used to typecheck the case alternatives first.
 264         -- The case patterns tend to give good type info to use
 265         -- when typechecking the scrutinee.  For example
 266         --      case (map f) of
 267         --        (x:xs) -> ...
 268         -- will report that map is applied to too few arguments
 269         --
 270         -- But now, in the GADT world, we need to typecheck the scrutinee
 271         -- first, to get type info that may be refined in the case alternatives
 272     addErrCtxt (caseScrutCtxt scrut)
 273                (tcInferRho scrut)       `thenM`    \ (scrut', scrut_ty) ->
 274
 275     addErrCtxt (caseCtxt in_expr)                       $
 276     tcMatchesCase match_ctxt scrut_ty matches exp_ty    `thenM` \ matches' ->
 277     returnM (HsCase scrut' matches')
 278  where
 279     match_ctxt = MC { mc_what = CaseAlt,
 280                       mc_body = tcMonoExpr }
 281
 282 tc_expr (HsIf pred b1 b2) res_ty
 283   = addErrCtxt (predCtxt pred) (
 284     tcCheckRho pred boolTy      )       `thenM`    \ pred' ->
 285
 286     zapExpectedType res_ty openTypeKind `thenM`    \ res_ty' ->
 287         -- C.f. the call to zapToType in TcMatches.tcMatches
 288
 289     tcCheckRho b1 res_ty'               `thenM`    \ b1' ->
 290     tcCheckRho b2 res_ty'               `thenM`    \ b2' ->
 291     returnM (HsIf pred' b1' b2')
 292
 293 tc_expr (HsDo do_or_lc stmts method_names _) res_ty
 294   = zapExpectedType res_ty liftedTypeKind               `thenM` \ res_ty' ->
 295         -- All comprehensions yield a monotype of kind *
 296     tcDoStmts do_or_lc stmts method_names res_ty'       `thenM` \ (stmts', methods') ->
 297     returnM (HsDo do_or_lc stmts' methods' res_ty')
 298
 299 tc_expr in_expr@(ExplicitList _ exprs) res_ty   -- Non-empty list
 300   = zapToListTy res_ty                `thenM` \ elt_ty ->
 301     mappM (tc_elt elt_ty) exprs       `thenM` \ exprs' ->
 302     returnM (ExplicitList elt_ty exprs')
 303   where
 304     tc_elt elt_ty expr
 305       = addErrCtxt (listCtxt expr) $
 306         tcCheckRho expr elt_ty
 307
 308 tc_expr in_expr@(ExplicitPArr _ exprs) res_ty   -- maybe empty
 309   = do  { [elt_ty] <- zapToTyConApp parrTyCon res_ty
 310         ; exprs' <- mappM (tc_elt elt_ty) exprs
 311         ; return (ExplicitPArr elt_ty exprs') }
 312   where
 313     tc_elt elt_ty expr
 314       = addErrCtxt (parrCtxt expr) (tcCheckRho expr elt_ty)
 315
 316 tc_expr (ExplicitTuple exprs boxity) res_ty
 317   = do  { arg_tys <- zapToTyConApp (tupleTyCon boxity (length exprs)) res_ty
 318         ; exprs' <-  tcCheckRhos exprs arg_tys
 319         ; return (ExplicitTuple exprs' boxity) }
 320
 321 tc_expr (HsProc pat cmd) res_ty
 322   = tcProc pat cmd res_ty                       `thenM` \ (pat', cmd') ->
 323     returnM (HsProc pat' cmd')
 324
 325 tc_expr e@(HsArrApp _ _ _ _ _) _
 326   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 327                       ptext SLIT("was found where an expression was expected")])
 328
 329 tc_expr e@(HsArrForm _ _ _) _
 330   = failWithTc (vcat [ptext SLIT("The arrow command"), nest 2 (ppr e),
 331                       ptext SLIT("was found where an expression was expected")])
 332 \end{code}
 333
 334 %************************************************************************
 335 %*                                                                      *
 336                 Record construction and update
 337 %*                                                                      *
 338 %************************************************************************
 339
 340 \begin{code}
 341 tc_expr expr@(RecordCon con@(L loc con_name) rbinds) res_ty
 342   = addErrCtxt (recordConCtxt expr)             $
 343     addLocM tcId con                    `thenM` \ (con_expr, _, con_tau) ->
 344     let
 345         (_, record_ty)   = tcSplitFunTys con_tau
 346         (tycon, ty_args) = tcSplitTyConApp record_ty
 347     in
 348     ASSERT( isAlgTyCon tycon )
 349     zapExpectedTo res_ty record_ty      `thenM_`
 350
 351         -- Check that the record bindings match the constructor
 352         -- con_name is syntactically constrained to be a data constructor
 353     tcLookupDataCon con_name            `thenM` \ data_con ->
 354     let
 355         bad_fields = badFields rbinds data_con
 356     in
 357     if notNull bad_fields then
 358         mappM (addErrTc . badFieldCon data_con) bad_fields      `thenM_`
 359         failM   -- Fail now, because tcRecordBinds will crash on a bad field
 360     else
 361
 362         -- Typecheck the record bindings
 363     tcRecordBinds tycon ty_args rbinds          `thenM` \ rbinds' ->
 364
 365         -- Check for missing fields
 366     checkMissingFields data_con rbinds          `thenM_`
 367
 368     returnM (RecordConOut data_con (L loc con_expr) rbinds')
 369
 370 -- The main complication with RecordUpd is that we need to explicitly
 371 -- handle the *non-updated* fields.  Consider:
 372 --
 373 --      data T a b = MkT1 { fa :: a, fb :: b }
 374 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 375 --                 | MkT3 { fd :: a }
 376 --
 377 --      upd :: T a b -> c -> T a c
 378 --      upd t x = t { fb = x}
 379 --
 380 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 381 -- because upd should be equivalent to:
 382 --
 383 --      upd t x = case t of
 384 --                      MkT1 p q -> MkT1 p x
 385 --                      MkT2 a b -> MkT2 p b
 386 --                      MkT3 d   -> error ...
 387 --
 388 -- So we need to give a completely fresh type to the result record,
 389 -- and then constrain it by the fields that are *not* updated ("p" above).
 390 --
 391 -- Note that because MkT3 doesn't contain all the fields being updated,
 392 -- its RHS is simply an error, so it doesn't impose any type constraints
 393 --
 394 -- All this is done in STEP 4 below.
 395
 396 tc_expr expr@(RecordUpd record_expr rbinds) res_ty
 397   = addErrCtxt (recordUpdCtxt   expr)           $
 398
 399         -- STEP 0
 400         -- Check that the field names are really field names
 401     ASSERT( notNull rbinds )
 402     let
 403         field_names = map fst rbinds
 404     in
 405     mappM (tcLookupGlobalId.unLoc) field_names  `thenM` \ sel_ids ->
 406         -- The renamer has already checked that they
 407         -- are all in scope
 408     let
 409         bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
 410                    | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
 411                      not (isRecordSelector sel_id)      -- Excludes class ops
 412                    ]
 413     in
 414     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 415
 416         -- STEP 1
 417         -- Figure out the tycon and data cons from the first field name
 418     let
 419                 -- It's OK to use the non-tc splitters here (for a selector)
 420         sel_id : _   = sel_ids
 421         (tycon, _)   = recordSelectorFieldLabel sel_id  -- We've failed already if
 422         data_cons    = tyConDataCons tycon              -- it's not a field label
 423         tycon_tyvars = tyConTyVars tycon                -- The data cons use the same type vars
 424     in
 425     tcInstTyVars tycon_tyvars           `thenM` \ (_, result_inst_tys, inst_env) ->
 426
 427         -- STEP 2
 428         -- Check that at least one constructor has all the named fields
 429         -- i.e. has an empty set of bad fields returned by badFields
 430     checkTc (any (null . badFields rbinds) data_cons)
 431             (badFieldsUpd rbinds)       `thenM_`
 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     in
 440     zapExpectedTo res_ty result_record_ty       `thenM_`
 441     tcRecordBinds tycon result_inst_tys rbinds  `thenM` \ rbinds' ->
 442
 443         -- STEP 4
 444         -- Use the un-updated fields to find a vector of booleans saying
 445         -- which type arguments must be the same in updatee and result.
 446         --
 447         -- WARNING: this code assumes that all data_cons in a common tycon
 448         -- have FieldLabels abstracted over the same tyvars.
 449     let
 450         upd_field_lbls      = recBindFields rbinds
 451         con_field_lbls_s    = map dataConFieldLabels data_cons
 452
 453                 -- A constructor is only relevant to this process if
 454                 -- it contains all the fields that are being updated
 455         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 456         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 457
 458         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 459         common_tyvars       = tyVarsOfTypes [ty | (fld,ty,_) <- tyConFields tycon,
 460                                                   fld `elem` non_upd_field_lbls]
 461
 462         mk_inst_ty tyvar result_inst_ty
 463           | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty   -- Same as result type
 464 -- gaw 2004 FIX?
 465           | otherwise                        = newTyFlexiVarTy liftedTypeKind   -- Fresh type
 466     in
 467     zipWithM mk_inst_ty tycon_tyvars result_inst_tys    `thenM` \ inst_tys ->
 468
 469         -- STEP 5
 470         -- Typecheck the expression to be updated
 471     let
 472         record_ty = mkTyConApp tycon inst_tys
 473     in
 474     tcCheckRho record_expr record_ty            `thenM` \ record_expr' ->
 475
 476         -- STEP 6
 477         -- Figure out the LIE we need.  We have to generate some
 478         -- dictionaries for the data type context, since we are going to
 479         -- do pattern matching over the data cons.
 480         --
 481         -- What dictionaries do we need?
 482         -- We just take the context of the type constructor
 483     let
 484         theta' = substTheta inst_env (tyConStupidTheta tycon)
 485     in
 486     newDicts RecordUpdOrigin theta'     `thenM` \ dicts ->
 487     extendLIEs dicts                    `thenM_`
 488
 489         -- Phew!
 490     returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds')
 491 \end{code}
 492
 493
 494 %************************************************************************
 495 %*                                                                      *
 496         Arithmetic sequences                    e.g. [a,b..]
 497         and their parallel-array counterparts   e.g. [: a,b.. :]
 498
 499 %*                                                                      *
 500 %************************************************************************
 501
 502 \begin{code}
 503 tc_expr (ArithSeqIn seq@(From expr)) res_ty
 504   = zapToListTy res_ty                          `thenM` \ elt_ty ->
 505     tcCheckRho expr elt_ty                      `thenM` \ expr' ->
 506
 507     newMethodFromName (ArithSeqOrigin seq)
 508                       elt_ty enumFromName       `thenM` \ enum_from ->
 509
 510     returnM (ArithSeqOut (nlHsVar enum_from) (From expr'))
 511
 512 tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 513   = addErrCtxt (arithSeqCtxt in_expr) $
 514     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 515     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 516     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 517     newMethodFromName (ArithSeqOrigin seq)
 518                       elt_ty enumFromThenName           `thenM` \ enum_from_then ->
 519
 520     returnM (ArithSeqOut (nlHsVar enum_from_then) (FromThen expr1' expr2'))
 521
 522
 523 tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 524   = addErrCtxt (arithSeqCtxt in_expr) $
 525     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 526     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 527     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 528     newMethodFromName (ArithSeqOrigin seq)
 529                       elt_ty enumFromToName             `thenM` \ enum_from_to ->
 530
 531     returnM (ArithSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
 532
 533 tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 534   = addErrCtxt  (arithSeqCtxt in_expr) $
 535     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 536     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 537     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 538     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 539     newMethodFromName (ArithSeqOrigin seq)
 540                       elt_ty enumFromThenToName         `thenM` \ eft ->
 541
 542     returnM (ArithSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
 543
 544 tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
 545   = addErrCtxt (parrSeqCtxt in_expr) $
 546     zapToTyConApp parrTyCon res_ty                      `thenM`    \ [elt_ty] ->
 547     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 548     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 549     newMethodFromName (PArrSeqOrigin seq)
 550                       elt_ty enumFromToPName            `thenM` \ enum_from_to ->
 551
 552     returnM (PArrSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2'))
 553
 554 tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 555   = addErrCtxt  (parrSeqCtxt in_expr) $
 556     zapToTyConApp parrTyCon res_ty                      `thenM`    \ [elt_ty] ->
 557     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 558     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 559     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 560     newMethodFromName (PArrSeqOrigin seq)
 561                       elt_ty enumFromThenToPName        `thenM` \ eft ->
 562
 563     returnM (PArrSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3'))
 564
 565 tc_expr (PArrSeqIn _) _
 566   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 567     -- the parser shouldn't have generated it and the renamer shouldn't have
 568     -- let it through
 569 \end{code}
 570
 571
 572 %************************************************************************
 573 %*                                                                      *
 574                 Template Haskell
 575 %*                                                                      *
 576 %************************************************************************
 577
 578 \begin{code}
 579 #ifdef GHCI     /* Only if bootstrapped */
 580         -- Rename excludes these cases otherwise
 581 tc_expr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 582 tc_expr (HsBracket brack)  res_ty = do  { e <- tcBracket brack res_ty
 583                                         ; return (unLoc e) }
 584 #endif /* GHCI */
 585 \end{code}
 586
 587
 588 %************************************************************************
 589 %*                                                                      *
 590                 Catch-all
 591 %*                                                                      *
 592 %************************************************************************
 593
 594 \begin{code}
 595 tc_expr other _ = pprPanic "tcMonoExpr" (ppr other)
 596 \end{code}
 597
 598
 599 %************************************************************************
 600 %*                                                                      *
 601 \subsection{@tcApp@ typchecks an application}
 602 %*                                                                      *
 603 %************************************************************************
 604
 605 \begin{code}
 606
 607 tcApp :: LHsExpr Name -> [LHsExpr Name]         -- Function and args
 608       -> Expected TcRhoType                     -- Expected result type of application
 609       -> TcM (HsExpr TcId)                      -- Translated fun and args
 610
 611 tcApp (L _ (HsApp e1 e2)) args res_ty
 612   = tcApp e1 (e2:args) res_ty           -- Accumulate the arguments
 613
 614 tcApp fun args res_ty
 615   = do  { (fun', fun_tvs, fun_tau) <- tcFun fun         -- Type-check the function
 616
 617         -- Extract its argument types
 618         ; (expected_arg_tys, actual_res_ty)
 619               <- addErrCtxt (wrongArgsCtxt "too many" fun args) $ do
 620                  { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau))
 621                  ; unifyFunTys (length args) fun_tau }
 622
 623
 624         ; case res_ty of
 625             Check _ -> do       -- Connect to result type first
 626                                 -- See Note [Push result type in]
 627                 { co_fn    <- tcResult fun args res_ty actual_res_ty
 628                 ; the_app' <- tcArgs fun fun' args expected_arg_tys
 629                 ; traceTc (text "tcApp: check" <+> vcat [ppr fun <+> ppr args,
 630                                                          ppr the_app', ppr actual_res_ty])
 631                 ; returnM (co_fn <$> the_app') }
 632
 633             Infer _ -> do       -- Type check args first, then
 634                                 -- refine result type, then do tcResult
 635                 { the_app'       <- tcArgs fun fun' args expected_arg_tys
 636                 ; subst          <- refineTyVars fun_tvs
 637                 ; let actual_res_ty' = substTy subst actual_res_ty
 638                 ; co_fn          <- tcResult fun args res_ty actual_res_ty'
 639                 ; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app',
 640                                                          ppr actual_res_ty, ppr actual_res_ty'])
 641                 ; returnM (co_fn <$> the_app') }
 642         }
 643
 644 --      Note [Push result type in]
 645 --
 646 -- Unify with expected result before (was: after) type-checking the args
 647 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
 648 -- This is when we might detect a too-few args situation.
 649 -- (One can think of cases when the opposite order would give
 650 -- a better error message.)
 651 -- [March 2003: I'm experimenting with putting this first.  Here's an
 652 --              example where it actually makes a real difference
 653 --    class C t a b | t a -> b
 654 --    instance C Char a Bool
 655 --
 656 --    data P t a = forall b. (C t a b) => MkP b
 657 --    data Q t   = MkQ (forall a. P t a)
 658
 659 --    f1, f2 :: Q Char;
 660 --    f1 = MkQ (MkP True)
 661 --    f2 = MkQ (MkP True :: forall a. P Char a)
 662 --
 663 -- With the change, f1 will type-check, because the 'Char' info from
 664 -- the signature is propagated into MkQ's argument. With the check
 665 -- in the other order, the extra signature in f2 is reqd.]
 666
 667 ----------------
 668 tcFun :: LHsExpr Name -> TcM (LHsExpr TcId, [TcTyVar], TcRhoType)
 669 -- Instantiate the function, returning the type variables used
 670 -- If the function isn't simple, infer its type, and return no
 671 -- type variables
 672 tcFun (L loc (HsVar f)) = setSrcSpan loc $ do
 673                           { (fun', tvs, fun_tau) <- tcId f
 674                           ; return (L loc fun', tvs, fun_tau) }
 675 tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun)
 676                ; return (fun', [], fun_tau) }
 677
 678 ----------------
 679 tcArgs :: LHsExpr Name                          -- The function (for error messages)
 680        -> LHsExpr TcId                          -- The function (to build into result)
 681        -> [LHsExpr Name] -> [TcSigmaType]       -- Actual arguments and expected arg types
 682        -> TcM (HsExpr TcId)                     -- Resulting application
 683
 684 tcArgs fun fun' args expected_arg_tys
 685   = do  { args' <- mappM (tcArg fun) (zip3 args expected_arg_tys [1..])
 686         ; return (unLoc (foldl mkHsApp fun' args')) }
 687
 688 tcArg :: LHsExpr Name                           -- The function (for error messages)
 689        -> (LHsExpr Name, TcSigmaType, Int)      -- Actual argument and expected arg type
 690        -> TcM (LHsExpr TcId)                    -- Resulting argument
 691 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
 692                                          (tcCheckSigma arg ty)
 693
 694 ----------------
 695 tcResult fun args res_ty actual_res_ty
 696   = addErrCtxtM (checkArgsCtxt fun args res_ty actual_res_ty)
 697                 (tcSubExp res_ty actual_res_ty)
 698
 699 ----------------
 700 -- If an error happens we try to figure out whether the
 701 -- function has been given too many or too few arguments,
 702 -- and say so.
 703 -- The ~(Check...) is because in the Infer case the tcSubExp
 704 -- definitely won't fail, so we can be certain we're in the Check branch
 705 checkArgsCtxt fun args (Infer _) actual_res_ty tidy_env
 706   = return (tidy_env, ptext SLIT("Urk infer"))
 707
 708 checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env
 709   = zonkTcType expected_res_ty    `thenM` \ exp_ty' ->
 710     zonkTcType actual_res_ty      `thenM` \ act_ty' ->
 711     let
 712       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 713       (env2, act_ty'') = tidyOpenType env1     act_ty'
 714       (exp_args, _)    = tcSplitFunTys exp_ty''
 715       (act_args, _)    = tcSplitFunTys act_ty''
 716
 717       len_act_args     = length act_args
 718       len_exp_args     = length exp_args
 719
 720       message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
 721               | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
 722               | otherwise                   = appCtxt fun args
 723     in
 724     returnM (env2, message)
 725 \end{code}
 726
 727
 728 %************************************************************************
 729 %*                                                                      *
 730 \subsection{@tcId@ typchecks an identifier occurrence}
 731 %*                                                                      *
 732 %************************************************************************
 733
 734 tcId instantiates an occurrence of an Id.
 735 The instantiate_it loop runs round instantiating the Id.
 736 It has to be a loop because we are now prepared to entertain
 737 types like
 738         f:: forall a. Eq a => forall b. Baz b => tau
 739 We want to instantiate this to
 740         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 741
 742 The -fno-method-sharing flag controls what happens so far as the LIE
 743 is concerned.  The default case is that for an overloaded function we
 744 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 745 something like
 746         f :: Num a => a -> a
 747         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 748 If you specify -fno-method-sharing, the dictionary application
 749 isn't shared, so we get
 750         f :: Num a => a -> a
 751         f = /\a (d:Num a) (x:a) -> (+) a d x x
 752 This gets a bit less sharing, but
 753         a) it's better for RULEs involving overloaded functions
 754         b) perhaps fewer separated lambdas
 755
 756 \begin{code}
 757 tcId :: Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
 758         -- Return the type variables at which the function
 759         -- is instantiated, as well as the translated variable and its type
 760
 761 tcId id_name    -- Look up the Id and instantiate its type
 762   = tcLookup id_name    `thenM` \ thing ->
 763     case thing of {
 764         AGlobal (ADataCon con)  -- Similar, but instantiate the stupid theta too
 765           -> do { (expr, tvs, tau) <- instantiate (dataConWrapId con)
 766                 ; tcInstStupidTheta con (mkTyVarTys tvs)
 767                 -- Remember to chuck in the constraints from the "silly context"
 768                 ; return (expr, tvs, tau) }
 769
 770     ;   AGlobal (AnId id) -> instantiate id
 771                 -- A global cannot possibly be ill-staged
 772                 -- nor does it need the 'lifting' treatment
 773
 774     ;   ATcId id th_level proc_level
 775           -> do { checkProcLevel id proc_level
 776                 ; tc_local_id id th_level }
 777
 778         -- THis
 779     ;   other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
 780     }
 781   where
 782
 783 #ifndef GHCI
 784     tc_local_id id th_bind_lvl                  -- Non-TH case
 785         = instantiate id
 786
 787 #else /* GHCI and TH is on */
 788     tc_local_id id th_bind_lvl                  -- TH case
 789         =       -- Check for cross-stage lifting
 790           getStage                              `thenM` \ use_stage ->
 791           case use_stage of
 792               Brack use_lvl ps_var lie_var
 793                 | use_lvl > th_bind_lvl
 794                 -> if isExternalName id_name then
 795                         -- Top-level identifiers in this module,
 796                         -- (which have External Names)
 797                         -- are just like the imported case:
 798                         -- no need for the 'lifting' treatment
 799                         -- E.g.  this is fine:
 800                         --   f x = x
 801                         --   g y = [| f 3 |]
 802                         -- But we do need to put f into the keep-alive
 803                         -- set, because after desugaring the code will
 804                         -- only mention f's *name*, not f itself.
 805                         keepAliveTc id_name     `thenM_`
 806                         instantiate id
 807
 808                    else -- Nested identifiers, such as 'x' in
 809                         -- E.g. \x -> [| h x |]
 810                         -- We must behave as if the reference to x was
 811                         --      h $(lift x)
 812                         -- We use 'x' itself as the splice proxy, used by
 813                         -- the desugarer to stitch it all back together.
 814                         -- If 'x' occurs many times we may get many identical
 815                         -- bindings of the same splice proxy, but that doesn't
 816                         -- matter, although it's a mite untidy.
 817                    let
 818                        id_ty = idType id
 819                    in
 820                    checkTc (isTauTy id_ty)      (polySpliceErr id)      `thenM_`
 821                        -- If x is polymorphic, its occurrence sites might
 822                        -- have different instantiations, so we can't use plain
 823                        -- 'x' as the splice proxy name.  I don't know how to
 824                        -- solve this, and it's probably unimportant, so I'm
 825                        -- just going to flag an error for now
 826
 827                    setLIEVar lie_var    (
 828                    newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
 829                            -- Put the 'lift' constraint into the right LIE
 830
 831                    -- Update the pending splices
 832                    readMutVar ps_var                    `thenM` \ ps ->
 833                    writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)     `thenM_`
 834
 835                    returnM (HsVar id, [], id_ty))
 836
 837               other ->
 838                 checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
 839                 instantiate id
 840 #endif /* GHCI */
 841
 842     instantiate :: TcId -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
 843     instantiate fun_id = loop (HsVar fun_id) [] (idType fun_id)
 844
 845     loop (HsVar fun_id) tvs fun_ty
 846         | want_method_inst fun_ty
 847         = tcInstType fun_ty             `thenM` \ (tyvars, theta, tau) ->
 848           newMethodWithGivenTy orig fun_id
 849                 (mkTyVarTys tyvars) theta tau   `thenM` \ meth_id ->
 850           loop (HsVar meth_id) (tvs ++ tyvars) tau
 851
 852     loop fun tvs fun_ty
 853         | isSigmaTy fun_ty
 854         = tcInstCall orig fun_ty        `thenM` \ (inst_fn, new_tvs, tau) ->
 855           loop (inst_fn <$> fun) (tvs ++ new_tvs) tau
 856
 857         | otherwise
 858         = returnM (fun, tvs, fun_ty)
 859
 860         --      Hack Alert (want_method_inst)!
 861         -- If   f :: (%x :: T) => Int -> Int
 862         -- Then if we have two separate calls, (f 3, f 4), we cannot
 863         -- make a method constraint that then gets shared, thus:
 864         --      let m = f %x in (m 3, m 4)
 865         -- because that loses the linearity of the constraint.
 866         -- The simplest thing to do is never to construct a method constraint
 867         -- in the first place that has a linear implicit parameter in it.
 868     want_method_inst fun_ty
 869         | opt_NoMethodSharing = False
 870         | otherwise           = case tcSplitSigmaTy fun_ty of
 871                                   (_,[],_)    -> False  -- Not overloaded
 872                                   (_,theta,_) -> not (any isLinearPred theta)
 873
 874     orig = OccurrenceOf id_name
 875 \end{code}
 876
 877 %************************************************************************
 878 %*                                                                      *
 879 \subsection{Record bindings}
 880 %*                                                                      *
 881 %************************************************************************
 882
 883 Game plan for record bindings
 884 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 885 1. Find the TyCon for the bindings, from the first field label.
 886
 887 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 888
 889 For each binding field = value
 890
 891 3. Instantiate the field type (from the field label) using the type
 892    envt from step 2.
 893
 894 4  Type check the value using tcArg, passing the field type as
 895    the expected argument type.
 896
 897 This extends OK when the field types are universally quantified.
 898
 899
 900 \begin{code}
 901 tcRecordBinds
 902         :: TyCon                -- Type constructor for the record
 903         -> [TcType]             -- Args of this type constructor
 904         -> HsRecordBinds Name
 905         -> TcM (HsRecordBinds TcId)
 906
 907 tcRecordBinds tycon ty_args rbinds
 908   = mappM do_bind rbinds
 909   where
 910     tenv = zipTopTvSubst (tyConTyVars tycon) ty_args
 911
 912     do_bind (L loc field_lbl, rhs)
 913       = addErrCtxt (fieldCtxt field_lbl)        $
 914         let
 915             field_ty  = tyConFieldType tycon field_lbl
 916             field_ty' = substTy tenv field_ty
 917         in
 918         tcCheckSigma rhs field_ty'              `thenM` \ rhs' ->
 919         tcLookupId field_lbl                    `thenM` \ sel_id ->
 920         ASSERT( isRecordSelector sel_id )
 921         returnM (L loc sel_id, rhs')
 922
 923 tyConFieldType :: TyCon -> FieldLabel -> Type
 924 tyConFieldType tycon field_lbl
 925   = case [ty | (f,ty,_) <- tyConFields tycon, f == field_lbl] of
 926         (ty:other) -> ASSERT( null other) ty
 927                 -- This lookup and assertion will surely succeed, because
 928                 -- we check that the fields are indeed record selectors
 929                 -- before calling tcRecordBinds
 930
 931 badFields rbinds data_con
 932   = filter (not . (`elem` field_names)) (recBindFields rbinds)
 933   where
 934     field_names = dataConFieldLabels data_con
 935
 936 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
 937 checkMissingFields data_con rbinds
 938   | null field_labels   -- Not declared as a record;
 939                         -- But C{} is still valid if no strict fields
 940   = if any isMarkedStrict field_strs then
 941         -- Illegal if any arg is strict
 942         addErrTc (missingStrictFields data_con [])
 943     else
 944         returnM ()
 945
 946   | otherwise           -- A record
 947   = checkM (null missing_s_fields)
 948            (addErrTc (missingStrictFields data_con missing_s_fields))   `thenM_`
 949
 950     doptM Opt_WarnMissingFields         `thenM` \ warn ->
 951     checkM (not (warn && notNull missing_ns_fields))
 952            (warnTc True (missingFields data_con missing_ns_fields))
 953
 954   where
 955     missing_s_fields
 956         = [ fl | (fl, str) <- field_info,
 957                  isMarkedStrict str,
 958                  not (fl `elem` field_names_used)
 959           ]
 960     missing_ns_fields
 961         = [ fl | (fl, str) <- field_info,
 962                  not (isMarkedStrict str),
 963                  not (fl `elem` field_names_used)
 964           ]
 965
 966     field_names_used = recBindFields rbinds
 967     field_labels     = dataConFieldLabels data_con
 968
 969     field_info = zipEqual "missingFields"
 970                           field_labels
 971                           field_strs
 972
 973     field_strs = dataConStrictMarks data_con
 974 \end{code}
 975
 976 %************************************************************************
 977 %*                                                                      *
 978 \subsection{@tcCheckRhos@ typechecks a {\em list} of expressions}
 979 %*                                                                      *
 980 %************************************************************************
 981
 982 \begin{code}
 983 tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
 984
 985 tcCheckRhos [] [] = returnM []
 986 tcCheckRhos (expr:exprs) (ty:tys)
 987  = tcCheckRho  expr  ty         `thenM` \ expr' ->
 988    tcCheckRhos exprs tys        `thenM` \ exprs' ->
 989    returnM (expr':exprs')
 990 \end{code}
 991
 992
 993 %************************************************************************
 994 %*                                                                      *
 995 \subsection{Literals}
 996 %*                                                                      *
 997 %************************************************************************
 998
 999 Overloaded literals.
1000
1001 \begin{code}
1002 tcLit :: HsLit -> Expected TcRhoType -> TcM (HsExpr TcId)
1003 tcLit lit res_ty
1004   = zapExpectedTo res_ty (hsLitType lit)                `thenM_`
1005     returnM (HsLit lit)
1006 \end{code}
1007
1008
1009 %************************************************************************
1010 %*                                                                      *
1011 \subsection{Errors and contexts}
1012 %*                                                                      *
1013 %************************************************************************
1014
1015 Boring and alphabetical:
1016 \begin{code}
1017 arithSeqCtxt expr
1018   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
1019
1020 parrSeqCtxt expr
1021   = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
1022
1023 caseCtxt expr
1024   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1025
1026 caseScrutCtxt expr
1027   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1028
1029 exprCtxt expr
1030   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1031
1032 fieldCtxt field_name
1033   = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1034
1035 funAppCtxt fun arg arg_no
1036   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1037                     quotes (ppr fun) <> text ", namely"])
1038          4 (quotes (ppr arg))
1039
1040 listCtxt expr
1041   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1042
1043 parrCtxt expr
1044   = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr)
1045
1046 predCtxt expr
1047   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1048
1049 appCtxt fun args
1050   = ptext SLIT("In the application") <+> quotes (ppr the_app)
1051   where
1052     the_app = foldl mkHsApp fun args    -- Used in error messages
1053
1054 badFieldsUpd rbinds
1055   = hang (ptext SLIT("No constructor has all these fields:"))
1056          4 (pprQuotedList (recBindFields rbinds))
1057
1058 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1059 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1060
1061 notSelector field
1062   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1063
1064 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1065 missingStrictFields con fields
1066   = header <> rest
1067   where
1068     rest | null fields = empty  -- Happens for non-record constructors
1069                                 -- with strict fields
1070          | otherwise   = colon <+> pprWithCommas ppr fields
1071
1072     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1073              ptext SLIT("does not have the required strict field(s)")
1074
1075 missingFields :: DataCon -> [FieldLabel] -> SDoc
1076 missingFields con fields
1077   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1078         <+> pprWithCommas ppr fields
1079
1080 wrongArgsCtxt too_many_or_few fun args
1081   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1082                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1083                     <+> ptext SLIT("arguments in the call"))
1084          4 (parens (ppr the_app))
1085   where
1086     the_app = foldl mkHsApp fun args    -- Used in error messages
1087
1088 #ifdef GHCI
1089 polySpliceErr :: Id -> SDoc
1090 polySpliceErr id
1091   = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
1092 #endif
1093 \end{code}