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 DsMeta
  68 import ListSetOps       ( minusList )
  69 import CmdLineOpts
  70 import HscTypes         ( TyThing(..) )
  71
  72 import Util
  73 import Outputable
  74 import FastString
  75 \end{code}
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{Main wrappers}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 tcExpr :: RenamedHsExpr         -- Expession to type check
  85         -> TcSigmaType          -- Expected type (could be a polytpye)
  86         -> TcM TcExpr           -- Generalised expr with expected type
  87
  88 tcExpr expr expected_ty
  89   = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_`
  90     tc_expr' expr expected_ty
  91
  92 tc_expr' expr expected_ty
  93   | not (isSigmaTy expected_ty)  -- Monomorphic case
  94   = tcMonoExpr expr expected_ty
  95
  96   | otherwise
  97   = tcGen expected_ty emptyVarSet (
  98         tcMonoExpr expr
  99     )                           `thenM` \ (gen_fn, expr') ->
 100     returnM (gen_fn <$> expr')
 101 \end{code}
 102
 103
 104 %************************************************************************
 105 %*                                                                      *
 106 \subsection{The TAUT rules for variables}
 107 %*                                                                      *
 108 %************************************************************************
 109
 110 \begin{code}
 111 tcMonoExpr :: RenamedHsExpr             -- Expession to type check
 112            -> TcRhoType                 -- Expected type (could be a type variable)
 113                                         -- Definitely no foralls at the top
 114                                         -- Can be a 'hole'.
 115            -> TcM TcExpr
 116
 117 tcMonoExpr (HsVar name) res_ty
 118   = tcId name                   `thenM` \ (expr', id_ty) ->
 119     tcSubExp res_ty id_ty       `thenM` \ co_fn ->
 120     returnM (co_fn <$> expr')
 121
 122 tcMonoExpr (HsIPVar ip) res_ty
 123   =     -- Implicit parameters must have a *tau-type* not a
 124         -- type scheme.  We enforce this by creating a fresh
 125         -- type variable as its type.  (Because res_ty may not
 126         -- be a tau-type.)
 127     newTyVarTy openTypeKind             `thenM` \ ip_ty ->
 128     newIPDict (IPOcc ip) ip ip_ty       `thenM` \ (ip', inst) ->
 129     extendLIE inst                      `thenM_`
 130     tcSubExp res_ty ip_ty               `thenM` \ co_fn ->
 131     returnM (co_fn <$> HsIPVar ip')
 132 \end{code}
 133
 134
 135 %************************************************************************
 136 %*                                                                      *
 137 \subsection{Expressions type signatures}
 138 %*                                                                      *
 139 %************************************************************************
 140
 141 \begin{code}
 142 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
 143  = addErrCtxt (exprSigCtxt in_expr)     $
 144    tcHsSigType ExprSigCtxt poly_ty      `thenM` \ sig_tc_ty ->
 145    tcExpr expr sig_tc_ty                `thenM` \ expr' ->
 146
 147         -- Must instantiate the outer for-alls of sig_tc_ty
 148         -- else we risk instantiating a ? res_ty to a forall-type
 149         -- which breaks the invariant that tcMonoExpr only returns phi-types
 150    tcInstCall SignatureOrigin sig_tc_ty `thenM` \ (inst_fn, inst_sig_ty) ->
 151    tcSubExp res_ty inst_sig_ty          `thenM` \ co_fn ->
 152
 153    returnM (co_fn <$> inst_fn expr')
 154
 155 tcMonoExpr (HsType ty) res_ty
 156   = failWithTc (text "Can't handle type argument:" <+> ppr ty)
 157         -- This is the syntax for type applications that I was planning
 158         -- but there are difficulties (e.g. what order for type args)
 159         -- so it's not enabled yet.
 160         -- Can't eliminate it altogether from the parser, because the
 161         -- same parser parses *patterns*.
 162 \end{code}
 163
 164
 165 %************************************************************************
 166 %*                                                                      *
 167 \subsection{Other expression forms}
 168 %*                                                                      *
 169 %************************************************************************
 170
 171 \begin{code}
 172 tcMonoExpr (HsLit lit)     res_ty  = tcLit lit res_ty
 173 tcMonoExpr (HsOverLit lit) res_ty  = newOverloadedLit (LiteralOrigin lit) lit res_ty
 174 tcMonoExpr (HsPar expr)    res_ty  = tcMonoExpr expr res_ty     `thenM` \ expr' ->
 175                                      returnM (HsPar expr')
 176 tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty     `thenM` \ expr' ->
 177                                      returnM (HsSCC lbl expr')
 178
 179
 180 tcMonoExpr (NegApp expr neg_name) res_ty
 181   = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty
 182         -- ToDo: use tcSyntaxName
 183
 184 tcMonoExpr (HsLam match) res_ty
 185   = tcMatchLambda match res_ty          `thenM` \ match' ->
 186     returnM (HsLam match')
 187
 188 tcMonoExpr (HsApp e1 e2) res_ty
 189   = tcApp e1 [e2] res_ty
 190 \end{code}
 191
 192 Note that the operators in sections are expected to be binary, and
 193 a type error will occur if they aren't.
 194
 195 \begin{code}
 196 -- Left sections, equivalent to
 197 --      \ x -> e op x,
 198 -- or
 199 --      \ x -> op e x,
 200 -- or just
 201 --      op e
 202
 203 tcMonoExpr in_expr@(SectionL arg1 op) res_ty
 204   = tcExpr_id op                                `thenM` \ (op', op_ty) ->
 205     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 206     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 207     addErrCtxt (exprCtxt in_expr)               $
 208     tcSubExp res_ty (mkFunTy arg2_ty op_res_ty) `thenM` \ co_fn ->
 209     returnM (co_fn <$> SectionL arg1' op')
 210
 211 -- Right sections, equivalent to \ x -> x op expr, or
 212 --      \ x -> op x expr
 213
 214 tcMonoExpr in_expr@(SectionR op arg2) res_ty
 215   = tcExpr_id op                                `thenM` \ (op', op_ty) ->
 216     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 217     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 218     addErrCtxt (exprCtxt in_expr)               $
 219     tcSubExp res_ty (mkFunTy arg1_ty op_res_ty) `thenM` \ co_fn ->
 220     returnM (co_fn <$> SectionR op' arg2')
 221
 222 -- equivalent to (op e1) e2:
 223
 224 tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty
 225   = tcExpr_id op                                `thenM` \ (op', op_ty) ->
 226     split_fun_ty op_ty 2 {- two args -}         `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 227     tcArg op (arg1, arg1_ty, 1)                 `thenM` \ arg1' ->
 228     tcArg op (arg2, arg2_ty, 2)                 `thenM` \ arg2' ->
 229     addErrCtxt (exprCtxt in_expr)               $
 230     tcSubExp res_ty op_res_ty                   `thenM` \ co_fn ->
 231     returnM (OpApp arg1' op' fix arg2')
 232 \end{code}
 233
 234 \begin{code}
 235 tcMonoExpr (HsLet binds expr) res_ty
 236   = tcBindsAndThen
 237         combiner
 238         binds                   -- Bindings to check
 239         (tcMonoExpr expr res_ty)
 240   where
 241     combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
 242
 243 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
 244   = addSrcLoc src_loc                   $
 245     addErrCtxt (caseCtxt in_expr)       $
 246
 247         -- Typecheck the case alternatives first.
 248         -- The case patterns tend to give good type info to use
 249         -- when typechecking the scrutinee.  For example
 250         --      case (map f) of
 251         --        (x:xs) -> ...
 252         -- will report that map is applied to too few arguments
 253         --
 254         -- Not only that, but it's better to check the matches on their
 255         -- own, so that we get the expected results for scoped type variables.
 256         --      f x = case x of
 257         --              (p::a, q::b) -> (q,p)
 258         -- The above should work: the match (p,q) -> (q,p) is polymorphic as
 259         -- claimed by the pattern signatures.  But if we typechecked the
 260         -- match with x in scope and x's type as the expected type, we'd be hosed.
 261
 262     tcMatchesCase matches res_ty        `thenM`    \ (scrut_ty, matches') ->
 263
 264     addErrCtxt (caseScrutCtxt scrut)    (
 265       tcMonoExpr scrut scrut_ty
 266     )                                   `thenM`    \ scrut' ->
 267
 268     returnM (HsCase scrut' matches' src_loc)
 269
 270 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
 271   = addSrcLoc src_loc   $
 272     addErrCtxt (predCtxt pred) (
 273     tcMonoExpr pred boolTy      )       `thenM`    \ pred' ->
 274
 275     zapToType res_ty                    `thenM`    \ res_ty' ->
 276         -- C.f. the call to zapToType in TcMatches.tcMatches
 277
 278     tcMonoExpr b1 res_ty'               `thenM`    \ b1' ->
 279     tcMonoExpr b2 res_ty'               `thenM`    \ b2' ->
 280     returnM (HsIf pred' b1' b2' src_loc)
 281
 282 tcMonoExpr (HsDo do_or_lc stmts method_names _ src_loc) res_ty
 283   = addSrcLoc src_loc           $
 284     tcDoStmts do_or_lc stmts method_names res_ty        `thenM` \ (binds, stmts', methods') ->
 285     returnM (mkHsLet binds (HsDo do_or_lc stmts' methods' res_ty src_loc))
 286
 287 tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty        -- Non-empty list
 288   = unifyListTy res_ty                `thenM` \ elt_ty ->
 289     mappM (tc_elt elt_ty) exprs       `thenM` \ exprs' ->
 290     returnM (ExplicitList elt_ty exprs')
 291   where
 292     tc_elt elt_ty expr
 293       = addErrCtxt (listCtxt expr) $
 294         tcMonoExpr expr elt_ty
 295
 296 tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty        -- maybe empty
 297   = unifyPArrTy res_ty                `thenM` \ elt_ty ->
 298     mappM (tc_elt elt_ty) exprs       `thenM` \ exprs' ->
 299     returnM (ExplicitPArr elt_ty exprs')
 300   where
 301     tc_elt elt_ty expr
 302       = addErrCtxt (parrCtxt expr) $
 303         tcMonoExpr expr elt_ty
 304
 305 tcMonoExpr (ExplicitTuple exprs boxity) res_ty
 306   = unifyTupleTy boxity (length exprs) res_ty   `thenM` \ arg_tys ->
 307     tcMonoExprs exprs arg_tys                   `thenM` \ exprs' ->
 308     returnM (ExplicitTuple exprs' boxity)
 309 \end{code}
 310
 311
 312 %************************************************************************
 313 %*                                                                      *
 314                 Foreign calls
 315 %*                                                                      *
 316 %************************************************************************
 317
 318 The interesting thing about @ccall@ is that it is just a template
 319 which we instantiate by filling in details about the types of its
 320 argument and result (ie minimal typechecking is performed).  So, the
 321 basic story is that we allocate a load of type variables (to hold the
 322 arg/result types); unify them with the args/result; and store them for
 323 later use.
 324
 325 \begin{code}
 326 tcMonoExpr e0@(HsCCall lbl args may_gc is_casm ignored_fake_result_ty) res_ty
 327
 328   = getDOpts                            `thenM` \ dflags ->
 329
 330     checkTc (not (is_casm && dopt_HscLang dflags /= HscC))
 331         (vcat [text "_casm_ is only supported when compiling via C (-fvia-C).",
 332                text "Either compile with -fvia-C, or, better, rewrite your code",
 333                text "to use the foreign function interface.  _casm_s are deprecated",
 334                text "and support for them may one day disappear."])
 335                                         `thenM_`
 336
 337     -- Get the callable and returnable classes.
 338     tcLookupClass cCallableClassName    `thenM` \ cCallableClass ->
 339     tcLookupClass cReturnableClassName  `thenM` \ cReturnableClass ->
 340     tcLookupTyCon ioTyConName           `thenM` \ ioTyCon ->
 341     let
 342         new_arg_dict (arg, arg_ty)
 343           = newDicts (CCallOrigin (unpackFS lbl) (Just arg))
 344                      [mkClassPred cCallableClass [arg_ty]]      `thenM` \ arg_dicts ->
 345             returnM arg_dicts   -- Actually a singleton bag
 346
 347         result_origin = CCallOrigin (unpackFS lbl) Nothing {- Not an arg -}
 348     in
 349
 350         -- Arguments
 351     let tv_idxs | null args  = []
 352                 | otherwise  = [1..length args]
 353     in
 354     newTyVarTys (length tv_idxs) openTypeKind           `thenM` \ arg_tys ->
 355     tcMonoExprs args arg_tys                            `thenM` \ args' ->
 356
 357         -- The argument types can be unlifted or lifted; the result
 358         -- type must, however, be lifted since it's an argument to the IO
 359         -- type constructor.
 360     newTyVarTy liftedTypeKind           `thenM` \ result_ty ->
 361     let
 362         io_result_ty = mkTyConApp ioTyCon [result_ty]
 363     in
 364     unifyTauTy res_ty io_result_ty              `thenM_`
 365
 366         -- Construct the extra insts, which encode the
 367         -- constraints on the argument and result types.
 368     mappM new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)       `thenM` \ ccarg_dicts_s ->
 369     newDicts result_origin [mkClassPred cReturnableClass [result_ty]]   `thenM` \ ccres_dict ->
 370     extendLIEs (ccres_dict ++ concat ccarg_dicts_s)                     `thenM_`
 371     returnM (HsCCall lbl args' may_gc is_casm io_result_ty)
 372 \end{code}
 373
 374
 375 %************************************************************************
 376 %*                                                                      *
 377                 Record construction and update
 378 %*                                                                      *
 379 %************************************************************************
 380
 381 \begin{code}
 382 tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
 383   = addErrCtxt (recordConCtxt expr)             $
 384     tcId con_name                       `thenM` \ (con_expr, con_tau) ->
 385     let
 386         (_, record_ty)   = tcSplitFunTys con_tau
 387         (tycon, ty_args) = tcSplitTyConApp record_ty
 388     in
 389     ASSERT( isAlgTyCon tycon )
 390     unifyTauTy res_ty record_ty          `thenM_`
 391
 392         -- Check that the record bindings match the constructor
 393         -- con_name is syntactically constrained to be a data constructor
 394     tcLookupDataCon con_name    `thenM` \ data_con ->
 395     let
 396         bad_fields = badFields rbinds data_con
 397     in
 398     if notNull bad_fields then
 399         mappM (addErrTc . badFieldCon data_con) bad_fields      `thenM_`
 400         failM   -- Fail now, because tcRecordBinds will crash on a bad field
 401     else
 402
 403         -- Typecheck the record bindings
 404     tcRecordBinds tycon ty_args rbinds          `thenM` \ rbinds' ->
 405
 406         -- Check for missing fields
 407     checkMissingFields data_con rbinds          `thenM_`
 408
 409     returnM (RecordConOut data_con con_expr rbinds')
 410
 411 -- The main complication with RecordUpd is that we need to explicitly
 412 -- handle the *non-updated* fields.  Consider:
 413 --
 414 --      data T a b = MkT1 { fa :: a, fb :: b }
 415 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 416 --                 | MkT3 { fd :: a }
 417 --
 418 --      upd :: T a b -> c -> T a c
 419 --      upd t x = t { fb = x}
 420 --
 421 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 422 -- because upd should be equivalent to:
 423 --
 424 --      upd t x = case t of
 425 --                      MkT1 p q -> MkT1 p x
 426 --                      MkT2 a b -> MkT2 p b
 427 --                      MkT3 d   -> error ...
 428 --
 429 -- So we need to give a completely fresh type to the result record,
 430 -- and then constrain it by the fields that are *not* updated ("p" above).
 431 --
 432 -- Note that because MkT3 doesn't contain all the fields being updated,
 433 -- its RHS is simply an error, so it doesn't impose any type constraints
 434 --
 435 -- All this is done in STEP 4 below.
 436
 437 tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
 438   = addErrCtxt (recordUpdCtxt   expr)           $
 439
 440         -- STEP 0
 441         -- Check that the field names are really field names
 442     ASSERT( notNull rbinds )
 443     let
 444         field_names = recBindFields rbinds
 445     in
 446     mappM tcLookupGlobal_maybe field_names              `thenM` \ maybe_sel_ids ->
 447     let
 448         bad_guys = [ addErrTc (notSelector field_name)
 449                    | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
 450                       case maybe_sel_id of
 451                         Just (AnId sel_id) -> not (isRecordSelector sel_id)
 452                         other              -> True
 453                    ]
 454     in
 455     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 456
 457         -- STEP 1
 458         -- Figure out the tycon and data cons from the first field name
 459     let
 460                 -- It's OK to use the non-tc splitters here (for a selector)
 461         (Just (AnId sel_id) : _) = maybe_sel_ids
 462
 463         (_, _, tau)  = tcSplitSigmaTy (idType sel_id)   -- Selectors can be overloaded
 464                                                         -- when the data type has a context
 465         data_ty      = tcFunArgTy tau                   -- Must succeed since sel_id is a selector
 466         tycon        = tcTyConAppTyCon data_ty
 467         data_cons    = tyConDataCons tycon
 468         tycon_tyvars = tyConTyVars tycon                -- The data cons use the same type vars
 469     in
 470     tcInstTyVars VanillaTv tycon_tyvars         `thenM` \ (_, result_inst_tys, inst_env) ->
 471
 472         -- STEP 2
 473         -- Check that at least one constructor has all the named fields
 474         -- i.e. has an empty set of bad fields returned by badFields
 475     checkTc (any (null . badFields rbinds) data_cons)
 476             (badFieldsUpd rbinds)               `thenM_`
 477
 478         -- STEP 3
 479         -- Typecheck the update bindings.
 480         -- (Do this after checking for bad fields in case there's a field that
 481         --  doesn't match the constructor.)
 482     let
 483         result_record_ty = mkTyConApp tycon result_inst_tys
 484     in
 485     unifyTauTy res_ty result_record_ty          `thenM_`
 486     tcRecordBinds tycon result_inst_tys rbinds  `thenM` \ rbinds' ->
 487
 488         -- STEP 4
 489         -- Use the un-updated fields to find a vector of booleans saying
 490         -- which type arguments must be the same in updatee and result.
 491         --
 492         -- WARNING: this code assumes that all data_cons in a common tycon
 493         -- have FieldLabels abstracted over the same tyvars.
 494     let
 495         upd_field_lbls      = map recordSelectorFieldLabel (recBindFields rbinds')
 496         con_field_lbls_s    = map dataConFieldLabels data_cons
 497
 498                 -- A constructor is only relevant to this process if
 499                 -- it contains all the fields that are being updated
 500         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 501         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 502
 503         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 504         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 505
 506         mk_inst_ty (tyvar, result_inst_ty)
 507           | tyvar `elemVarSet` common_tyvars = returnM result_inst_ty   -- Same as result type
 508           | otherwise                        = newTyVarTy liftedTypeKind        -- Fresh type
 509     in
 510     mappM mk_inst_ty (zip tycon_tyvars result_inst_tys) `thenM` \ inst_tys ->
 511
 512         -- STEP 5
 513         -- Typecheck the expression to be updated
 514     let
 515         record_ty = mkTyConApp tycon inst_tys
 516     in
 517     tcMonoExpr record_expr record_ty            `thenM` \ record_expr' ->
 518
 519         -- STEP 6
 520         -- Figure out the LIE we need.  We have to generate some
 521         -- dictionaries for the data type context, since we are going to
 522         -- do pattern matching over the data cons.
 523         --
 524         -- What dictionaries do we need?
 525         -- We just take the context of the type constructor
 526     let
 527         theta' = substTheta inst_env (tyConTheta tycon)
 528     in
 529     newDicts RecordUpdOrigin theta'     `thenM` \ dicts ->
 530     extendLIEs dicts                    `thenM_`
 531
 532         -- Phew!
 533     returnM (RecordUpdOut record_expr' record_ty result_record_ty rbinds')
 534 \end{code}
 535
 536
 537 %************************************************************************
 538 %*                                                                      *
 539         Arithmetic sequences                    e.g. [a,b..]
 540         and their parallel-array counterparts   e.g. [: a,b.. :]
 541
 542 %*                                                                      *
 543 %************************************************************************
 544
 545 \begin{code}
 546 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
 547   = unifyListTy res_ty                          `thenM` \ elt_ty ->
 548     tcMonoExpr expr elt_ty                      `thenM` \ expr' ->
 549
 550     newMethodFromName (ArithSeqOrigin seq)
 551                       elt_ty enumFromName       `thenM` \ enum_from ->
 552
 553     returnM (ArithSeqOut (HsVar enum_from) (From expr'))
 554
 555 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 556   = addErrCtxt (arithSeqCtxt in_expr) $
 557     unifyListTy  res_ty                                 `thenM`    \ elt_ty ->
 558     tcMonoExpr expr1 elt_ty                             `thenM`    \ expr1' ->
 559     tcMonoExpr expr2 elt_ty                             `thenM`    \ expr2' ->
 560     newMethodFromName (ArithSeqOrigin seq)
 561                       elt_ty enumFromThenName           `thenM` \ enum_from_then ->
 562
 563     returnM (ArithSeqOut (HsVar enum_from_then) (FromThen expr1' expr2'))
 564
 565
 566 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 567   = addErrCtxt (arithSeqCtxt in_expr) $
 568     unifyListTy  res_ty                                 `thenM`    \ elt_ty ->
 569     tcMonoExpr expr1 elt_ty                             `thenM`    \ expr1' ->
 570     tcMonoExpr expr2 elt_ty                             `thenM`    \ expr2' ->
 571     newMethodFromName (ArithSeqOrigin seq)
 572                       elt_ty enumFromToName             `thenM` \ enum_from_to ->
 573
 574     returnM (ArithSeqOut (HsVar enum_from_to) (FromTo expr1' expr2'))
 575
 576 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) 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     tcMonoExpr expr3 elt_ty                             `thenM`    \ expr3' ->
 582     newMethodFromName (ArithSeqOrigin seq)
 583                       elt_ty enumFromThenToName         `thenM` \ eft ->
 584
 585     returnM (ArithSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3'))
 586
 587 tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty
 588   = addErrCtxt (parrSeqCtxt in_expr) $
 589     unifyPArrTy  res_ty                                 `thenM`    \ elt_ty ->
 590     tcMonoExpr expr1 elt_ty                             `thenM`    \ expr1' ->
 591     tcMonoExpr expr2 elt_ty                             `thenM`    \ expr2' ->
 592     newMethodFromName (PArrSeqOrigin seq)
 593                       elt_ty enumFromToPName            `thenM` \ enum_from_to ->
 594
 595     returnM (PArrSeqOut (HsVar enum_from_to) (FromTo expr1' expr2'))
 596
 597 tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) 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     tcMonoExpr expr3 elt_ty                             `thenM`    \ expr3' ->
 603     newMethodFromName (PArrSeqOrigin seq)
 604                       elt_ty enumFromThenToPName        `thenM` \ eft ->
 605
 606     returnM (PArrSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3'))
 607
 608 tcMonoExpr (PArrSeqIn _) _
 609   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 610     -- the parser shouldn't have generated it and the renamer shouldn't have
 611     -- let it through
 612 \end{code}
 613
 614
 615 %************************************************************************
 616 %*                                                                      *
 617                 Template Haskell
 618 %*                                                                      *
 619 %************************************************************************
 620
 621 \begin{code}
 622 #ifdef GHCI     /* Only if bootstrapped */
 623         -- Rename excludes these cases otherwise
 624
 625 tcMonoExpr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty
 626
 627 tcMonoExpr (HsBracket brack) res_ty
 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}