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