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