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