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