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