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            ( FieldLabel, tyConStupidTheta, 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
  73 #ifdef DEBUG
  74 import TyCon            ( tyConArity )
  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 (L loc con_name) _ rbinds) res_ty
 355   = addErrCtxt (recordConCtxt expr) $
 356     do  { (con_expr, _, con_tau) <- setSrcSpan loc $
 357                                     tcId (OccurrenceOf con_name) con_name
 358         ; data_con <- tcLookupDataCon con_name
 359
 360         ; let (arg_tys, record_ty) = tcSplitFunTys con_tau
 361               flds_w_tys = zipEqual "tcExpr RecordCon" (dataConFieldLabels data_con) arg_tys
 362
 363         -- Make the result type line up
 364         ; zapExpectedTo res_ty record_ty
 365
 366         -- Typecheck the record bindings
 367         ; rbinds' <- tcRecordBinds data_con flds_w_tys rbinds
 368
 369         -- Check for missing fields
 370         ; checkMissingFields data_con rbinds
 371
 372         ; returnM (RecordCon (L loc (dataConWrapId data_con)) con_expr rbinds') }
 373
 374 -- The main complication with RecordUpd is that we need to explicitly
 375 -- handle the *non-updated* fields.  Consider:
 376 --
 377 --      data T a b = MkT1 { fa :: a, fb :: b }
 378 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 379 --                 | MkT3 { fd :: a }
 380 --
 381 --      upd :: T a b -> c -> T a c
 382 --      upd t x = t { fb = x}
 383 --
 384 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 385 -- because upd should be equivalent to:
 386 --
 387 --      upd t x = case t of
 388 --                      MkT1 p q -> MkT1 p x
 389 --                      MkT2 a b -> MkT2 p b
 390 --                      MkT3 d   -> error ...
 391 --
 392 -- So we need to give a completely fresh type to the result record,
 393 -- and then constrain it by the fields that are *not* updated ("p" above).
 394 --
 395 -- Note that because MkT3 doesn't contain all the fields being updated,
 396 -- its RHS is simply an error, so it doesn't impose any type constraints
 397 --
 398 -- All this is done in STEP 4 below.
 399 --
 400 -- Note about GADTs
 401 -- ~~~~~~~~~~~~~~~~
 402 -- For record update we require that every constructor involved in the
 403 -- update (i.e. that has all the specified fields) is "vanilla".  I
 404 -- don't know how to do the update otherwise.
 405
 406
 407 tcExpr expr@(RecordUpd record_expr rbinds _ _) res_ty
 408   = addErrCtxt (recordUpdCtxt   expr)           $
 409
 410         -- STEP 0
 411         -- Check that the field names are really field names
 412     ASSERT( notNull rbinds )
 413     let
 414         field_names = map fst rbinds
 415     in
 416     mappM (tcLookupGlobalId.unLoc) field_names  `thenM` \ sel_ids ->
 417         -- The renamer has already checked that they
 418         -- are all in scope
 419     let
 420         bad_guys = [ setSrcSpan loc $ addErrTc (notSelector field_name)
 421                    | (L loc field_name, sel_id) <- field_names `zip` sel_ids,
 422                      not (isRecordSelector sel_id)      -- Excludes class ops
 423                    ]
 424     in
 425     checkM (null bad_guys) (sequenceM bad_guys `thenM_` failM)  `thenM_`
 426
 427         -- STEP 1
 428         -- Figure out the tycon and data cons from the first field name
 429     let
 430                 -- It's OK to use the non-tc splitters here (for a selector)
 431         upd_field_lbls  = recBindFields rbinds
 432         sel_id : _      = sel_ids
 433         (tycon, _)      = recordSelectorFieldLabel sel_id       -- We've failed already if
 434         data_cons       = tyConDataCons tycon           -- it's not a field label
 435         relevant_cons   = filter is_relevant data_cons
 436         is_relevant con = all (`elem` dataConFieldLabels con) upd_field_lbls
 437     in
 438
 439         -- STEP 2
 440         -- Check that at least one constructor has all the named fields
 441         -- i.e. has an empty set of bad fields returned by badFields
 442     checkTc (not (null relevant_cons))
 443             (badFieldsUpd rbinds)       `thenM_`
 444
 445         -- Check that all relevant data cons are vanilla.  Doing record updates on
 446         -- GADTs and/or existentials is more than my tiny brain can cope with today
 447     checkTc (all isVanillaDataCon relevant_cons)
 448             (nonVanillaUpd tycon)       `thenM_`
 449
 450         -- STEP 4
 451         -- Use the un-updated fields to find a vector of booleans saying
 452         -- which type arguments must be the same in updatee and result.
 453         --
 454         -- WARNING: this code assumes that all data_cons in a common tycon
 455         -- have FieldLabels abstracted over the same tyvars.
 456     let
 457                 -- A constructor is only relevant to this process if
 458                 -- it contains *all* the fields that are being updated
 459         con1            = head relevant_cons    -- A representative constructor
 460         con1_tyvars     = dataConTyVars con1
 461         con1_fld_tys    = dataConFieldLabels con1 `zip` dataConOrigArgTys con1
 462         common_tyvars   = tyVarsOfTypes [ty | (fld,ty) <- con1_fld_tys
 463                                             , not (fld `elem` upd_field_lbls) ]
 464
 465         is_common_tv tv = tv `elemVarSet` common_tyvars
 466
 467         mk_inst_ty tv result_inst_ty
 468           | is_common_tv tv = returnM result_inst_ty            -- Same as result type
 469           | otherwise       = newTyFlexiVarTy (tyVarKind tv)    -- Fresh type, of correct kind
 470     in
 471     tcInstTyVars con1_tyvars                            `thenM` \ (_, result_inst_tys, inst_env) ->
 472     zipWithM mk_inst_ty con1_tyvars result_inst_tys     `thenM` \ inst_tys ->
 473
 474         -- STEP 3
 475         -- Typecheck the update bindings.
 476         -- (Do this after checking for bad fields in case there's a field that
 477         --  doesn't match the constructor.)
 478     let
 479         result_record_ty = mkTyConApp tycon result_inst_tys
 480         inst_fld_tys     = [(fld, substTy inst_env ty) | (fld, ty) <- con1_fld_tys]
 481     in
 482     zapExpectedTo res_ty result_record_ty       `thenM_`
 483     tcRecordBinds con1 inst_fld_tys rbinds      `thenM` \ rbinds' ->
 484
 485         -- STEP 5
 486         -- Typecheck the expression to be updated
 487     let
 488         record_ty = ASSERT( length inst_tys == tyConArity tycon )
 489                     mkTyConApp tycon inst_tys
 490         -- This is one place where the isVanilla check is important
 491         -- So that inst_tys matches the tycon
 492     in
 493     tcCheckRho record_expr record_ty            `thenM` \ record_expr' ->
 494
 495         -- STEP 6
 496         -- Figure out the LIE we need.  We have to generate some
 497         -- dictionaries for the data type context, since we are going to
 498         -- do pattern matching over the data cons.
 499         --
 500         -- What dictionaries do we need?
 501         -- We just take the context of the first data constructor
 502         -- This isn't right, but I just can't bear to union up all the relevant ones
 503     let
 504         theta' = substTheta inst_env (tyConStupidTheta tycon)
 505     in
 506     newDicts RecordUpdOrigin theta'     `thenM` \ dicts ->
 507     extendLIEs dicts                    `thenM_`
 508
 509         -- Phew!
 510     returnM (RecordUpd record_expr' rbinds' record_ty result_record_ty)
 511 \end{code}
 512
 513
 514 %************************************************************************
 515 %*                                                                      *
 516         Arithmetic sequences                    e.g. [a,b..]
 517         and their parallel-array counterparts   e.g. [: a,b.. :]
 518
 519 %*                                                                      *
 520 %************************************************************************
 521
 522 \begin{code}
 523 tcExpr (ArithSeq _ seq@(From expr)) res_ty
 524   = zapToListTy res_ty                          `thenM` \ elt_ty ->
 525     tcCheckRho expr elt_ty                      `thenM` \ expr' ->
 526
 527     newMethodFromName (ArithSeqOrigin seq)
 528                       elt_ty enumFromName       `thenM` \ enum_from ->
 529
 530     returnM (ArithSeq (HsVar enum_from) (From expr'))
 531
 532 tcExpr in_expr@(ArithSeq _ seq@(FromThen expr1 expr2)) res_ty
 533   = addErrCtxt (arithSeqCtxt in_expr) $
 534     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 535     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 536     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 537     newMethodFromName (ArithSeqOrigin seq)
 538                       elt_ty enumFromThenName           `thenM` \ enum_from_then ->
 539
 540     returnM (ArithSeq (HsVar enum_from_then) (FromThen expr1' expr2'))
 541
 542
 543 tcExpr in_expr@(ArithSeq _ seq@(FromTo expr1 expr2)) res_ty
 544   = addErrCtxt (arithSeqCtxt in_expr) $
 545     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 546     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 547     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 548     newMethodFromName (ArithSeqOrigin seq)
 549                       elt_ty enumFromToName             `thenM` \ enum_from_to ->
 550
 551     returnM (ArithSeq (HsVar enum_from_to) (FromTo expr1' expr2'))
 552
 553 tcExpr in_expr@(ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 554   = addErrCtxt  (arithSeqCtxt in_expr) $
 555     zapToListTy  res_ty                                 `thenM`    \ elt_ty ->
 556     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 557     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 558     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 559     newMethodFromName (ArithSeqOrigin seq)
 560                       elt_ty enumFromThenToName         `thenM` \ eft ->
 561
 562     returnM (ArithSeq (HsVar eft) (FromThenTo expr1' expr2' expr3'))
 563
 564 tcExpr in_expr@(PArrSeq _ seq@(FromTo expr1 expr2)) res_ty
 565   = addErrCtxt (parrSeqCtxt in_expr) $
 566     zapToTyConApp parrTyCon res_ty                      `thenM`    \ [elt_ty] ->
 567     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 568     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 569     newMethodFromName (PArrSeqOrigin seq)
 570                       elt_ty enumFromToPName            `thenM` \ enum_from_to ->
 571
 572     returnM (PArrSeq (HsVar enum_from_to) (FromTo expr1' expr2'))
 573
 574 tcExpr in_expr@(PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty
 575   = addErrCtxt  (parrSeqCtxt in_expr) $
 576     zapToTyConApp parrTyCon res_ty                      `thenM`    \ [elt_ty] ->
 577     tcCheckRho expr1 elt_ty                             `thenM`    \ expr1' ->
 578     tcCheckRho expr2 elt_ty                             `thenM`    \ expr2' ->
 579     tcCheckRho expr3 elt_ty                             `thenM`    \ expr3' ->
 580     newMethodFromName (PArrSeqOrigin seq)
 581                       elt_ty enumFromThenToPName        `thenM` \ eft ->
 582
 583     returnM (PArrSeq (HsVar eft) (FromThenTo expr1' expr2' expr3'))
 584
 585 tcExpr (PArrSeq _ _) _
 586   = panic "TcExpr.tcMonoExpr: Infinite parallel array!"
 587     -- the parser shouldn't have generated it and the renamer shouldn't have
 588     -- let it through
 589 \end{code}
 590
 591
 592 %************************************************************************
 593 %*                                                                      *
 594                 Template Haskell
 595 %*                                                                      *
 596 %************************************************************************
 597
 598 \begin{code}
 599 #ifdef GHCI     /* Only if bootstrapped */
 600         -- Rename excludes these cases otherwise
 601 tcExpr (HsSpliceE splice) res_ty = tcSpliceExpr splice res_ty
 602 tcExpr (HsBracket brack)  res_ty = do   { e <- tcBracket brack res_ty
 603                                         ; return (unLoc e) }
 604 #endif /* GHCI */
 605 \end{code}
 606
 607
 608 %************************************************************************
 609 %*                                                                      *
 610                 Catch-all
 611 %*                                                                      *
 612 %************************************************************************
 613
 614 \begin{code}
 615 tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)
 616 \end{code}
 617
 618
 619 %************************************************************************
 620 %*                                                                      *
 621 \subsection{@tcApp@ typchecks an application}
 622 %*                                                                      *
 623 %************************************************************************
 624
 625 \begin{code}
 626
 627 tcApp :: LHsExpr Name -> [LHsExpr Name]         -- Function and args
 628       -> Expected TcRhoType                     -- Expected result type of application
 629       -> TcM (HsExpr TcId)                      -- Translated fun and args
 630
 631 tcApp (L _ (HsApp e1 e2)) args res_ty
 632   = tcApp e1 (e2:args) res_ty           -- Accumulate the arguments
 633
 634 tcApp fun args res_ty
 635   = do  { let n_args = length args
 636         ; (fun', fun_tvs, fun_tau) <- tcFun fun         -- Type-check the function
 637
 638         -- Extract its argument types
 639         ; (expected_arg_tys, actual_res_ty)
 640               <- do { traceTc (text "tcApp" <+> (ppr fun $$ ppr fun_tau))
 641                     ; let msg = sep [ptext SLIT("The function") <+> quotes (ppr fun),
 642                                      ptext SLIT("is applied to")
 643                                      <+> speakN n_args <+> ptext SLIT("arguments")]
 644                     ; unifyFunTys msg n_args fun_tau }
 645
 646         ; case res_ty of
 647             Check _ -> do       -- Connect to result type first
 648                                 -- See Note [Push result type in]
 649                 { co_fn    <- tcResult fun args res_ty actual_res_ty
 650                 ; the_app' <- tcArgs fun fun' args expected_arg_tys
 651                 ; traceTc (text "tcApp: check" <+> vcat [ppr fun <+> ppr args,
 652                                                          ppr the_app', ppr actual_res_ty])
 653                 ; returnM (co_fn <$> the_app') }
 654
 655             Infer _ -> do       -- Type check args first, then
 656                                 -- refine result type, then do tcResult
 657                 { the_app'       <- tcArgs fun fun' args expected_arg_tys
 658                 ; subst          <- refineTyVars fun_tvs
 659                 ; let actual_res_ty' = substTy subst actual_res_ty
 660                 ; co_fn          <- tcResult fun args res_ty actual_res_ty'
 661                 ; traceTc (text "tcApp: infer" <+> vcat [ppr fun <+> ppr args, ppr the_app',
 662                                                          ppr actual_res_ty, ppr actual_res_ty'])
 663                 ; returnM (co_fn <$> the_app') }
 664         }
 665
 666 --      Note [Push result type in]
 667 --
 668 -- Unify with expected result before (was: after) type-checking the args
 669 -- so that the info from res_ty (was: args) percolates to args (was actual_res_ty).
 670 -- This is when we might detect a too-few args situation.
 671 -- (One can think of cases when the opposite order would give
 672 -- a better error message.)
 673 -- [March 2003: I'm experimenting with putting this first.  Here's an
 674 --              example where it actually makes a real difference
 675 --    class C t a b | t a -> b
 676 --    instance C Char a Bool
 677 --
 678 --    data P t a = forall b. (C t a b) => MkP b
 679 --    data Q t   = MkQ (forall a. P t a)
 680
 681 --    f1, f2 :: Q Char;
 682 --    f1 = MkQ (MkP True)
 683 --    f2 = MkQ (MkP True :: forall a. P Char a)
 684 --
 685 -- With the change, f1 will type-check, because the 'Char' info from
 686 -- the signature is propagated into MkQ's argument. With the check
 687 -- in the other order, the extra signature in f2 is reqd.]
 688
 689 ----------------
 690 tcFun :: LHsExpr Name -> TcM (LHsExpr TcId, [TcTyVar], TcRhoType)
 691 -- Instantiate the function, returning the type variables used
 692 -- If the function isn't simple, infer its type, and return no
 693 -- type variables
 694 tcFun (L loc (HsVar f)) = setSrcSpan loc $ do
 695                           { (fun', tvs, fun_tau) <- tcId (OccurrenceOf f) f
 696                           ; return (L loc fun', tvs, fun_tau) }
 697 tcFun fun = do { (fun', fun_tau) <- tcInfer (tcMonoExpr fun)
 698                ; return (fun', [], fun_tau) }
 699
 700 ----------------
 701 tcArgs :: LHsExpr Name                          -- The function (for error messages)
 702        -> LHsExpr TcId                          -- The function (to build into result)
 703        -> [LHsExpr Name] -> [TcSigmaType]       -- Actual arguments and expected arg types
 704        -> TcM (HsExpr TcId)                     -- Resulting application
 705
 706 tcArgs fun fun' args expected_arg_tys
 707   = do  { args' <- mappM (tcArg fun) (zip3 args expected_arg_tys [1..])
 708         ; return (unLoc (foldl mkHsApp fun' args')) }
 709
 710 tcArg :: LHsExpr Name                           -- The function (for error messages)
 711        -> (LHsExpr Name, TcSigmaType, Int)      -- Actual argument and expected arg type
 712        -> TcM (LHsExpr TcId)                    -- Resulting argument
 713 tcArg fun (arg, ty, arg_no) = addErrCtxt (funAppCtxt fun arg arg_no)
 714                                          (tcCheckSigma arg ty)
 715
 716 ----------------
 717 tcResult fun args res_ty actual_res_ty
 718   = addErrCtxtM (checkArgsCtxt fun args res_ty actual_res_ty)
 719                 (tcSubExp res_ty actual_res_ty)
 720
 721 ----------------
 722 -- If an error happens we try to figure out whether the
 723 -- function has been given too many or too few arguments,
 724 -- and say so.
 725 -- The ~(Check...) is because in the Infer case the tcSubExp
 726 -- definitely won't fail, so we can be certain we're in the Check branch
 727 checkArgsCtxt fun args (Infer _) actual_res_ty tidy_env
 728   = return (tidy_env, ptext SLIT("Urk infer"))
 729
 730 checkArgsCtxt fun args (Check expected_res_ty) actual_res_ty tidy_env
 731   = zonkTcType expected_res_ty    `thenM` \ exp_ty' ->
 732     zonkTcType actual_res_ty      `thenM` \ act_ty' ->
 733     let
 734       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 735       (env2, act_ty'') = tidyOpenType env1     act_ty'
 736       (exp_args, _)    = tcSplitFunTys exp_ty''
 737       (act_args, _)    = tcSplitFunTys act_ty''
 738
 739       len_act_args     = length act_args
 740       len_exp_args     = length exp_args
 741
 742       message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
 743               | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
 744               | otherwise                   = appCtxt fun args
 745     in
 746     returnM (env2, message)
 747
 748 ----------------
 749 unifyInfixTy :: LHsExpr Name -> HsExpr Name -> TcType
 750              -> TcM ([TcType], TcType)
 751 -- This wrapper just prepares the error message for unifyFunTys
 752 unifyInfixTy op expr op_ty
 753   = unifyFunTys msg 2 op_ty
 754   where
 755     msg = sep [herald <+> quotes (ppr expr),
 756                ptext SLIT("requires") <+> quotes (ppr op)
 757                  <+> ptext SLIT("to take two arguments")]
 758     herald = case expr of
 759                 OpApp _ _ _ _ -> ptext SLIT("The infix expression")
 760                 other         -> ptext SLIT("The operator section")
 761 \end{code}
 762
 763
 764 %************************************************************************
 765 %*                                                                      *
 766 \subsection{@tcId@ typchecks an identifier occurrence}
 767 %*                                                                      *
 768 %************************************************************************
 769
 770 tcId instantiates an occurrence of an Id.
 771 The instantiate_it loop runs round instantiating the Id.
 772 It has to be a loop because we are now prepared to entertain
 773 types like
 774         f:: forall a. Eq a => forall b. Baz b => tau
 775 We want to instantiate this to
 776         f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 777
 778 The -fno-method-sharing flag controls what happens so far as the LIE
 779 is concerned.  The default case is that for an overloaded function we
 780 generate a "method" Id, and add the Method Inst to the LIE.  So you get
 781 something like
 782         f :: Num a => a -> a
 783         f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x
 784 If you specify -fno-method-sharing, the dictionary application
 785 isn't shared, so we get
 786         f :: Num a => a -> a
 787         f = /\a (d:Num a) (x:a) -> (+) a d x x
 788 This gets a bit less sharing, but
 789         a) it's better for RULEs involving overloaded functions
 790         b) perhaps fewer separated lambdas
 791
 792 \begin{code}
 793 tcId :: InstOrigin -> Name -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
 794         -- Return the type variables at which the function
 795         -- is instantiated, as well as the translated variable and its type
 796
 797 tcId orig id_name       -- Look up the Id and instantiate its type
 798   = tcLookup id_name    `thenM` \ thing ->
 799     case thing of {
 800         AGlobal (ADataCon con)  -- Similar, but instantiate the stupid theta too
 801           -> do { (expr, tvs, tau) <- instantiate (dataConWrapId con)
 802                 ; tcInstStupidTheta con (mkTyVarTys tvs)
 803                 -- Remember to chuck in the constraints from the "silly context"
 804                 ; return (expr, tvs, tau) }
 805
 806     ;   AGlobal (AnId id) | isNaughtyRecordSelector id
 807                           -> failWithTc (naughtyRecordSel id)
 808     ;   AGlobal (AnId id) -> instantiate id
 809                 -- A global cannot possibly be ill-staged
 810                 -- nor does it need the 'lifting' treatment
 811
 812     ;   ATcId id th_level -> tc_local_id id th_level
 813
 814     ;   other -> failWithTc (ppr other <+> ptext SLIT("used where a value identifer was expected"))
 815     }
 816   where
 817
 818 #ifndef GHCI
 819     tc_local_id id th_bind_lvl                  -- Non-TH case
 820         = instantiate id
 821
 822 #else /* GHCI and TH is on */
 823     tc_local_id id th_bind_lvl                  -- TH case
 824         =       -- Check for cross-stage lifting
 825           getStage                              `thenM` \ use_stage ->
 826           case use_stage of
 827               Brack use_lvl ps_var lie_var
 828                 | use_lvl > th_bind_lvl
 829                 -> if isExternalName id_name then
 830                         -- Top-level identifiers in this module,
 831                         -- (which have External Names)
 832                         -- are just like the imported case:
 833                         -- no need for the 'lifting' treatment
 834                         -- E.g.  this is fine:
 835                         --   f x = x
 836                         --   g y = [| f 3 |]
 837                         -- But we do need to put f into the keep-alive
 838                         -- set, because after desugaring the code will
 839                         -- only mention f's *name*, not f itself.
 840                         keepAliveTc id_name     `thenM_`
 841                         instantiate id
 842
 843                    else -- Nested identifiers, such as 'x' in
 844                         -- E.g. \x -> [| h x |]
 845                         -- We must behave as if the reference to x was
 846                         --      h $(lift x)
 847                         -- We use 'x' itself as the splice proxy, used by
 848                         -- the desugarer to stitch it all back together.
 849                         -- If 'x' occurs many times we may get many identical
 850                         -- bindings of the same splice proxy, but that doesn't
 851                         -- matter, although it's a mite untidy.
 852                    let
 853                        id_ty = idType id
 854                    in
 855                    checkTc (isTauTy id_ty)      (polySpliceErr id)      `thenM_`
 856                        -- If x is polymorphic, its occurrence sites might
 857                        -- have different instantiations, so we can't use plain
 858                        -- 'x' as the splice proxy name.  I don't know how to
 859                        -- solve this, and it's probably unimportant, so I'm
 860                        -- just going to flag an error for now
 861
 862                    setLIEVar lie_var    (
 863                    newMethodFromName orig id_ty DsMeta.liftName `thenM` \ lift ->
 864                            -- Put the 'lift' constraint into the right LIE
 865
 866                    -- Update the pending splices
 867                    readMutVar ps_var                    `thenM` \ ps ->
 868                    writeMutVar ps_var ((id_name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps)     `thenM_`
 869
 870                    returnM (HsVar id, [], id_ty))
 871
 872               other ->
 873                 checkWellStaged (quotes (ppr id)) th_bind_lvl use_stage `thenM_`
 874                 instantiate id
 875 #endif /* GHCI */
 876
 877     instantiate :: TcId -> TcM (HsExpr TcId, [TcTyVar], TcRhoType)
 878     instantiate fun_id = loop (HsVar fun_id) [] (idType fun_id)
 879
 880     loop (HsVar fun_id) tvs fun_ty
 881         | want_method_inst fun_ty
 882         = tcInstType fun_ty             `thenM` \ (tyvars, theta, tau) ->
 883           newMethodWithGivenTy orig fun_id
 884                 (mkTyVarTys tyvars) theta tau   `thenM` \ meth_id ->
 885           loop (HsVar meth_id) (tvs ++ tyvars) tau
 886
 887     loop fun tvs fun_ty
 888         | isSigmaTy fun_ty
 889         = tcInstCall orig fun_ty        `thenM` \ (inst_fn, new_tvs, tau) ->
 890           loop (inst_fn <$> fun) (tvs ++ new_tvs) tau
 891
 892         | otherwise
 893         = returnM (fun, tvs, fun_ty)
 894
 895         --      Hack Alert (want_method_inst)!
 896         -- If   f :: (%x :: T) => Int -> Int
 897         -- Then if we have two separate calls, (f 3, f 4), we cannot
 898         -- make a method constraint that then gets shared, thus:
 899         --      let m = f %x in (m 3, m 4)
 900         -- because that loses the linearity of the constraint.
 901         -- The simplest thing to do is never to construct a method constraint
 902         -- in the first place that has a linear implicit parameter in it.
 903     want_method_inst fun_ty
 904         | opt_NoMethodSharing = False
 905         | otherwise           = case tcSplitSigmaTy fun_ty of
 906                                   (_,[],_)    -> False  -- Not overloaded
 907                                   (_,theta,_) -> not (any isLinearPred theta)
 908 \end{code}
 909
 910 %************************************************************************
 911 %*                                                                      *
 912 \subsection{Record bindings}
 913 %*                                                                      *
 914 %************************************************************************
 915
 916 Game plan for record bindings
 917 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 918 1. Find the TyCon for the bindings, from the first field label.
 919
 920 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 921
 922 For each binding field = value
 923
 924 3. Instantiate the field type (from the field label) using the type
 925    envt from step 2.
 926
 927 4  Type check the value using tcArg, passing the field type as
 928    the expected argument type.
 929
 930 This extends OK when the field types are universally quantified.
 931
 932
 933 \begin{code}
 934 tcRecordBinds
 935         :: DataCon
 936         -> [(FieldLabel,TcType)]        -- Expected type for each field
 937         -> HsRecordBinds Name
 938         -> TcM (HsRecordBinds TcId)
 939
 940 tcRecordBinds data_con flds_w_tys rbinds
 941   = do  { mb_binds <- mappM do_bind rbinds
 942         ; return (catMaybes mb_binds) }
 943   where
 944     do_bind (L loc field_lbl, rhs)
 945       | Just field_ty <- assocMaybe flds_w_tys field_lbl
 946       = addErrCtxt (fieldCtxt field_lbl)        $
 947         do { rhs'   <- tcCheckSigma rhs field_ty
 948            ; sel_id <- tcLookupId field_lbl
 949            ; ASSERT( isRecordSelector sel_id )
 950              return (Just (L loc sel_id, rhs')) }
 951       | otherwise
 952       = do { addErrTc (badFieldCon data_con field_lbl)
 953            ; return Nothing }
 954
 955 checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM ()
 956 checkMissingFields data_con rbinds
 957   | null field_labels   -- Not declared as a record;
 958                         -- But C{} is still valid if no strict fields
 959   = if any isMarkedStrict field_strs then
 960         -- Illegal if any arg is strict
 961         addErrTc (missingStrictFields data_con [])
 962     else
 963         returnM ()
 964
 965   | otherwise           -- A record
 966   = checkM (null missing_s_fields)
 967            (addErrTc (missingStrictFields data_con missing_s_fields))   `thenM_`
 968
 969     doptM Opt_WarnMissingFields         `thenM` \ warn ->
 970     checkM (not (warn && notNull missing_ns_fields))
 971            (warnTc True (missingFields data_con missing_ns_fields))
 972
 973   where
 974     missing_s_fields
 975         = [ fl | (fl, str) <- field_info,
 976                  isMarkedStrict str,
 977                  not (fl `elem` field_names_used)
 978           ]
 979     missing_ns_fields
 980         = [ fl | (fl, str) <- field_info,
 981                  not (isMarkedStrict str),
 982                  not (fl `elem` field_names_used)
 983           ]
 984
 985     field_names_used = recBindFields rbinds
 986     field_labels     = dataConFieldLabels data_con
 987
 988     field_info = zipEqual "missingFields"
 989                           field_labels
 990                           field_strs
 991
 992     field_strs = dataConStrictMarks data_con
 993 \end{code}
 994
 995 %************************************************************************
 996 %*                                                                      *
 997 \subsection{@tcCheckRhos@ typechecks a {\em list} of expressions}
 998 %*                                                                      *
 999 %************************************************************************
1000
1001 \begin{code}
1002 tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
1003
1004 tcCheckRhos [] [] = returnM []
1005 tcCheckRhos (expr:exprs) (ty:tys)
1006  = tcCheckRho  expr  ty         `thenM` \ expr' ->
1007    tcCheckRhos exprs tys        `thenM` \ exprs' ->
1008    returnM (expr':exprs')
1009 tcCheckRhos exprs tys = pprPanic "tcCheckRhos" (ppr exprs $$ ppr tys)
1010 \end{code}
1011
1012
1013 %************************************************************************
1014 %*                                                                      *
1015 \subsection{Literals}
1016 %*                                                                      *
1017 %************************************************************************
1018
1019 Overloaded literals.
1020
1021 \begin{code}
1022 tcLit :: HsLit -> Expected TcRhoType -> TcM (HsExpr TcId)
1023 tcLit lit res_ty
1024   = zapExpectedTo res_ty (hsLitType lit)                `thenM_`
1025     returnM (HsLit lit)
1026 \end{code}
1027
1028
1029 %************************************************************************
1030 %*                                                                      *
1031 \subsection{Errors and contexts}
1032 %*                                                                      *
1033 %************************************************************************
1034
1035 Boring and alphabetical:
1036 \begin{code}
1037 arithSeqCtxt expr
1038   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
1039
1040 parrSeqCtxt expr
1041   = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
1042
1043 caseCtxt expr
1044   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1045
1046 caseScrutCtxt expr
1047   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1048
1049 exprCtxt expr
1050   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1051
1052 fieldCtxt field_name
1053   = ptext SLIT("In the") <+> quotes (ppr field_name) <+> ptext SLIT("field of a record")
1054
1055 funAppCtxt fun arg arg_no
1056   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1057                     quotes (ppr fun) <> text ", namely"])
1058          4 (quotes (ppr arg))
1059
1060 listCtxt expr
1061   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1062
1063 parrCtxt expr
1064   = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr)
1065
1066 predCtxt expr
1067   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1068
1069 appCtxt fun args
1070   = ptext SLIT("In the application") <+> quotes (ppr the_app)
1071   where
1072     the_app = foldl mkHsApp fun args    -- Used in error messages
1073
1074 nonVanillaUpd tycon
1075   = vcat [ptext SLIT("Record update for the non-Haskell-98 data type") <+> quotes (ppr tycon)
1076                 <+> ptext SLIT("is not (yet) supported"),
1077           ptext SLIT("Use pattern-matching instead")]
1078 badFieldsUpd rbinds
1079   = hang (ptext SLIT("No constructor has all these fields:"))
1080          4 (pprQuotedList (recBindFields rbinds))
1081
1082 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1083 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1084
1085 naughtyRecordSel sel_id
1086   = ptext SLIT("Cannot use record selector") <+> quotes (ppr sel_id) <+>
1087     ptext SLIT("as a function due to escaped type variables") $$
1088     ptext SLIT("Probably fix: use pattern-matching syntax instead")
1089
1090 notSelector field
1091   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1092
1093 missingStrictFields :: DataCon -> [FieldLabel] -> SDoc
1094 missingStrictFields con fields
1095   = header <> rest
1096   where
1097     rest | null fields = empty  -- Happens for non-record constructors
1098                                 -- with strict fields
1099          | otherwise   = colon <+> pprWithCommas ppr fields
1100
1101     header = ptext SLIT("Constructor") <+> quotes (ppr con) <+>
1102              ptext SLIT("does not have the required strict field(s)")
1103
1104 missingFields :: DataCon -> [FieldLabel] -> SDoc
1105 missingFields con fields
1106   = ptext SLIT("Fields of") <+> quotes (ppr con) <+> ptext SLIT("not initialised:")
1107         <+> pprWithCommas ppr fields
1108
1109 wrongArgsCtxt too_many_or_few fun args
1110   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1111                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1112                     <+> ptext SLIT("arguments in the call"))
1113          4 (parens (ppr the_app))
1114   where
1115     the_app = foldl mkHsApp fun args    -- Used in error messages
1116
1117 #ifdef GHCI
1118 polySpliceErr :: Id -> SDoc
1119 polySpliceErr id
1120   = ptext SLIT("Can't splice the polymorphic local variable") <+> quotes (ppr id)
1121 #endif
1122 \end{code}