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