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