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