ghc/compiler/typecheck/TcExpr.lhs

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