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