ghc/compiler/typecheck/TcExpr.lhs

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