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