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