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