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