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