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