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