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 ( tcApp, tcExpr, tcPolyExpr, tcId ) where
   8
   9 #include "HsVersions.h"
  10
  11 import HsSyn            ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
  12                           MonoBinds(..), StmtCtxt(..),
  13                           mkMonoBind, nullMonoBinds
  14                         )
  15 import RnHsSyn          ( RenamedHsExpr, RenamedRecordBinds )
  16 import TcHsSyn          ( TcExpr, TcRecordBinds, mkHsTyApp, mkHsLet )
  17
  18 import TcMonad
  19 import BasicTypes       ( RecFlag(..) )
  20
  21 import Inst             ( InstOrigin(..),
  22                           LIE, emptyLIE, unitLIE, plusLIE, plusLIEs,
  23                           newOverloadedLit, newMethod, newIPDict,
  24                           instOverloadedFun, newDicts, newClassDicts,
  25                           getIPsOfLIE, instToId, ipToId
  26                         )
  27 import TcBinds          ( tcBindsAndThen )
  28 import TcEnv            ( tcInstId,
  29                           tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
  30                           tcLookupTyCon, tcLookupDataCon, tcLookup,
  31                           tcExtendGlobalTyVars
  32                         )
  33 import TcMatches        ( tcMatchesCase, tcMatchLambda, tcStmts )
  34 import TcMonoType       ( tcHsSigType, checkSigTyVars, sigCtxt )
  35 import TcPat            ( badFieldCon, simpleHsLitTy )
  36 import TcSimplify       ( tcSimplifyAndCheck, partitionPredsOfLIE )
  37 import TcImprove        ( tcImprove )
  38 import TcType           ( TcType, TcTauType,
  39                           tcInstTyVars,
  40                           tcInstTcType, tcSplitRhoTy,
  41                           newTyVarTy, newTyVarTys, zonkTcType )
  42
  43 import FieldLabel       ( fieldLabelName, fieldLabelType, fieldLabelTyCon )
  44 import Id               ( idType, recordSelectorFieldLabel, isRecordSelector, mkVanillaId )
  45 import DataCon          ( dataConFieldLabels, dataConSig,
  46                           dataConStrictMarks, StrictnessMark(..)
  47                         )
  48 import Name             ( Name, getName )
  49 import Type             ( mkFunTy, mkAppTy, mkTyVarTys, ipName_maybe,
  50                           splitFunTy_maybe, splitFunTys, isNotUsgTy,
  51                           mkTyConApp, splitSigmaTy,
  52                           splitRhoTy,
  53                           isTauTy, tyVarsOfType, tyVarsOfTypes,
  54                           isSigmaTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
  55                           boxedTypeKind, openTypeKind, mkArrowKind,
  56                           tidyOpenType
  57                         )
  58 import TyCon            ( TyCon, tyConTyVars )
  59 import Subst            ( mkTopTyVarSubst, substClasses, substTy )
  60 import UsageSPUtils     ( unannotTy )
  61 import VarSet           ( elemVarSet, mkVarSet )
  62 import TysWiredIn       ( boolTy )
  63 import TcUnify          ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
  64 import PrelNames        ( cCallableClassKey, cReturnableClassKey,
  65                           enumFromClassOpKey, enumFromThenClassOpKey,
  66                           enumFromToClassOpKey, enumFromThenToClassOpKey,
  67                           thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey
  68                         )
  69 import Outputable
  70 import Maybes           ( maybeToBool, mapMaybe )
  71 import ListSetOps       ( minusList )
  72 import Util
  73 import CmdLineOpts      ( opt_WarnMissingFields )
  74
  75 \end{code}
  76
  77 %************************************************************************
  78 %*                                                                      *
  79 \subsection{Main wrappers}
  80 %*                                                                      *
  81 %************************************************************************
  82
  83 \begin{code}
  84 tcExpr :: RenamedHsExpr                 -- Expession to type check
  85         -> TcType                       -- Expected type (could be a polytpye)
  86         -> TcM (TcExpr, LIE)
  87
  88 tcExpr expr ty | isSigmaTy ty = -- Polymorphic case
  89                                 tcPolyExpr expr ty      `thenTc` \ (expr', lie, _, _, _) ->
  90                                 returnTc (expr', lie)
  91
  92                | otherwise    = -- Monomorphic case
  93                                 tcMonoExpr expr ty
  94 \end{code}
  95
  96
  97 %************************************************************************
  98 %*                                                                      *
  99 \subsection{@tcPolyExpr@ typchecks an application}
 100 %*                                                                      *
 101 %************************************************************************
 102
 103 \begin{code}
 104 -- tcPolyExpr is like tcMonoExpr, except that the expected type
 105 -- can be a polymorphic one.
 106 tcPolyExpr :: RenamedHsExpr
 107            -> TcType                            -- Expected type
 108            -> TcM (TcExpr, LIE,         -- Generalised expr with expected type, and LIE
 109                      TcExpr, TcTauType, LIE)    -- Same thing, but instantiated; tau-type returned
 110
 111 tcPolyExpr arg expected_arg_ty
 112   =     -- Ha!  The argument type of the function is a for-all type,
 113         -- An example of rank-2 polymorphism.
 114
 115         -- To ensure that the forall'd type variables don't get unified with each
 116         -- other or any other types, we make fresh copy of the alleged type
 117     tcInstTcType expected_arg_ty        `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
 118     let
 119         (sig_theta, sig_tau) = splitRhoTy sig_rho
 120         free_tyvars          = tyVarsOfType expected_arg_ty
 121     in
 122         -- Type-check the arg and unify with expected type
 123     tcMonoExpr arg sig_tau                              `thenTc` \ (arg', lie_arg) ->
 124
 125         -- Check that the sig_tyvars havn't been constrained
 126         -- The interesting bit here is that we must include the free variables
 127         -- of the expected arg ty.  Here's an example:
 128         --       runST (newVar True)
 129         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 130         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 131         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 132         -- So now s' isn't unconstrained because it's linked to a.
 133         -- Conclusion: include the free vars of the expected arg type in the
 134         -- list of "free vars" for the signature check.
 135
 136     tcExtendGlobalTyVars free_tyvars                              $
 137     tcAddErrCtxtM (sigCtxt sig_msg sig_tyvars sig_theta sig_tau)  $
 138
 139     checkSigTyVars sig_tyvars free_tyvars       `thenTc` \ zonked_sig_tyvars ->
 140
 141     newDicts SignatureOrigin sig_theta          `thenNF_Tc` \ (sig_dicts, dict_ids) ->
 142     tcImprove (sig_dicts `plusLIE` lie_arg)     `thenTc_`
 143         -- ToDo: better origin
 144     tcSimplifyAndCheck
 145         (text "the type signature of an expression")
 146         (mkVarSet zonked_sig_tyvars)
 147         sig_dicts lie_arg                       `thenTc` \ (free_insts, inst_binds) ->
 148
 149     let
 150             -- This HsLet binds any Insts which came out of the simplification.
 151             -- It's a bit out of place here, but using AbsBind involves inventing
 152             -- a couple of new names which seems worse.
 153         generalised_arg = TyLam zonked_sig_tyvars $
 154                           DictLam dict_ids $
 155                           mkHsLet inst_binds $
 156                           arg'
 157     in
 158     returnTc ( generalised_arg, free_insts,
 159                arg', sig_tau, lie_arg )
 160   where
 161     sig_msg = ptext SLIT("When checking an expression type signature")
 162 \end{code}
 163
 164 %************************************************************************
 165 %*                                                                      *
 166 \subsection{The TAUT rules for variables}
 167 %*                                                                      *
 168 %************************************************************************
 169
 170 \begin{code}
 171 tcMonoExpr :: RenamedHsExpr             -- Expession to type check
 172            -> TcTauType                 -- Expected type (could be a type variable)
 173            -> TcM (TcExpr, LIE)
 174
 175 tcMonoExpr (HsVar name) res_ty
 176   = tcId name                   `thenNF_Tc` \ (expr', lie, id_ty) ->
 177     unifyTauTy res_ty id_ty     `thenTc_`
 178
 179     -- Check that the result type doesn't have any nested for-alls.
 180     -- For example, a "build" on its own is no good; it must be
 181     -- applied to something.
 182     checkTc (isTauTy id_ty)
 183             (lurkingRank2Err name id_ty) `thenTc_`
 184
 185     returnTc (expr', lie)
 186 \end{code}
 187
 188 \begin{code}
 189 tcMonoExpr (HsIPVar name) res_ty
 190   -- ZZ What's the `id' used for here...
 191   = let id = mkVanillaId name res_ty in
 192     tcGetInstLoc (OccurrenceOf id)      `thenNF_Tc` \ loc ->
 193     newIPDict name res_ty loc           `thenNF_Tc` \ ip ->
 194     returnNF_Tc (HsIPVar (instToId ip), unitLIE ip)
 195 \end{code}
 196
 197 %************************************************************************
 198 %*                                                                      *
 199 \subsection{Other expression forms}
 200 %*                                                                      *
 201 %************************************************************************
 202
 203 \begin{code}
 204 tcMonoExpr (HsLit lit)     res_ty = tcLit lit res_ty
 205 tcMonoExpr (HsOverLit lit) res_ty = newOverloadedLit (LiteralOrigin lit) lit res_ty
 206 tcMonoExpr (HsPar expr)    res_ty = tcMonoExpr expr res_ty
 207
 208 tcMonoExpr (NegApp expr neg) res_ty
 209   = tcMonoExpr (HsApp (HsVar neg) expr) res_ty
 210
 211 tcMonoExpr (HsLam match) res_ty
 212   = tcMatchLambda match res_ty          `thenTc` \ (match',lie) ->
 213     returnTc (HsLam match', lie)
 214
 215 tcMonoExpr (HsApp e1 e2) res_ty = accum e1 [e2]
 216   where
 217     accum (HsApp e1 e2) args = accum e1 (e2:args)
 218     accum fun args
 219       = tcApp fun args res_ty   `thenTc` \ (fun', args', lie) ->
 220         returnTc (foldl HsApp fun' args', lie)
 221
 222 -- equivalent to (op e1) e2:
 223 tcMonoExpr (OpApp arg1 op fix arg2) res_ty
 224   = tcApp op [arg1,arg2] res_ty `thenTc` \ (op', [arg1', arg2'], lie) ->
 225     returnTc (OpApp arg1' op' fix arg2', lie)
 226 \end{code}
 227
 228 Note that the operators in sections are expected to be binary, and
 229 a type error will occur if they aren't.
 230
 231 \begin{code}
 232 -- Left sections, equivalent to
 233 --      \ x -> e op x,
 234 -- or
 235 --      \ x -> op e x,
 236 -- or just
 237 --      op e
 238
 239 tcMonoExpr in_expr@(SectionL arg op) res_ty
 240   = tcApp op [arg] res_ty               `thenTc` \ (op', [arg'], lie) ->
 241
 242         -- Check that res_ty is a function type
 243         -- Without this check we barf in the desugarer on
 244         --      f op = (3 `op`)
 245         -- because it tries to desugar to
 246         --      f op = \r -> 3 op r
 247         -- so (3 `op`) had better be a function!
 248     tcAddErrCtxt (sectionLAppCtxt in_expr) $
 249     unifyFunTy res_ty                   `thenTc_`
 250
 251     returnTc (SectionL arg' op', lie)
 252
 253 -- Right sections, equivalent to \ x -> x op expr, or
 254 --      \ x -> op x expr
 255
 256 tcMonoExpr in_expr@(SectionR op expr) res_ty
 257   = tcExpr_id op                `thenTc`    \ (op', lie1, op_ty) ->
 258     tcAddErrCtxt (sectionRAppCtxt in_expr) $
 259     split_fun_ty op_ty 2 {- two args -}                 `thenTc` \ ([arg1_ty, arg2_ty], op_res_ty) ->
 260     tcMonoExpr expr arg2_ty                             `thenTc` \ (expr',lie2) ->
 261     unifyTauTy res_ty (mkFunTy arg1_ty op_res_ty)       `thenTc_`
 262     returnTc (SectionR op' expr', lie1 `plusLIE` lie2)
 263 \end{code}
 264
 265 The interesting thing about @ccall@ is that it is just a template
 266 which we instantiate by filling in details about the types of its
 267 argument and result (ie minimal typechecking is performed).  So, the
 268 basic story is that we allocate a load of type variables (to hold the
 269 arg/result types); unify them with the args/result; and store them for
 270 later use.
 271
 272 \begin{code}
 273 tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty
 274   =     -- Get the callable and returnable classes.
 275     tcLookupClass cCallableClassName    `thenNF_Tc` \ cCallableClass ->
 276     tcLookupClass cReturnableClassName  `thenNF_Tc` \ cReturnableClass ->
 277     tcLookupTyCon ioTyConName           `thenNF_Tc` \ ioTyCon ->
 278     let
 279         new_arg_dict (arg, arg_ty)
 280           = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 281                           [(cCallableClass, [arg_ty])]  `thenNF_Tc` \ (arg_dicts, _) ->
 282             returnNF_Tc arg_dicts       -- Actually a singleton bag
 283
 284         result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
 285     in
 286
 287         -- Arguments
 288     let n_args = length args
 289         tv_idxs | n_args == 0 = []
 290                 | otherwise   = [1..n_args]
 291     in
 292     newTyVarTys (length tv_idxs) openTypeKind           `thenNF_Tc` \ arg_tys ->
 293     tcMonoExprs args arg_tys                            `thenTc`    \ (args', args_lie) ->
 294
 295         -- The argument types can be unboxed or boxed; the result
 296         -- type must, however, be boxed since it's an argument to the IO
 297         -- type constructor.
 298     newTyVarTy boxedTypeKind            `thenNF_Tc` \ result_ty ->
 299     let
 300         io_result_ty = mkTyConApp ioTyCon [result_ty]
 301     in
 302     unifyTauTy res_ty io_result_ty              `thenTc_`
 303
 304         -- Construct the extra insts, which encode the
 305         -- constraints on the argument and result types.
 306     mapNF_Tc new_arg_dict (zipEqual "tcMonoExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
 307     newClassDicts result_origin [(cReturnableClass, [result_ty])]       `thenNF_Tc` \ (ccres_dict, _) ->
 308     returnTc (HsCCall lbl args' may_gc is_asm io_result_ty,
 309               foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie)
 310 \end{code}
 311
 312 \begin{code}
 313 tcMonoExpr (HsSCC lbl expr) res_ty
 314   = tcMonoExpr expr res_ty              `thenTc` \ (expr', lie) ->
 315     returnTc (HsSCC lbl expr', lie)
 316
 317 tcMonoExpr (HsLet binds expr) res_ty
 318   = tcBindsAndThen
 319         combiner
 320         binds                   -- Bindings to check
 321         tc_expr         `thenTc` \ (expr', lie) ->
 322     returnTc (expr', lie)
 323   where
 324     tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
 325               returnTc (expr', lie)
 326     combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
 327
 328 tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
 329   = tcAddSrcLoc src_loc                 $
 330     tcAddErrCtxt (caseCtxt in_expr)     $
 331
 332         -- Typecheck the case alternatives first.
 333         -- The case patterns tend to give good type info to use
 334         -- when typechecking the scrutinee.  For example
 335         --      case (map f) of
 336         --        (x:xs) -> ...
 337         -- will report that map is applied to too few arguments
 338         --
 339         -- Not only that, but it's better to check the matches on their
 340         -- own, so that we get the expected results for scoped type variables.
 341         --      f x = case x of
 342         --              (p::a, q::b) -> (q,p)
 343         -- The above should work: the match (p,q) -> (q,p) is polymorphic as
 344         -- claimed by the pattern signatures.  But if we typechecked the
 345         -- match with x in scope and x's type as the expected type, we'd be hosed.
 346
 347     tcMatchesCase matches res_ty        `thenTc`    \ (scrut_ty, matches', lie2) ->
 348
 349     tcAddErrCtxt (caseScrutCtxt scrut)  (
 350       tcMonoExpr scrut scrut_ty
 351     )                                   `thenTc`    \ (scrut',lie1) ->
 352
 353     returnTc (HsCase scrut' matches' src_loc, plusLIE lie1 lie2)
 354
 355 tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty
 356   = tcAddSrcLoc src_loc $
 357     tcAddErrCtxt (predCtxt pred) (
 358     tcMonoExpr pred boolTy      )       `thenTc`    \ (pred',lie1) ->
 359
 360     tcMonoExpr b1 res_ty                `thenTc`    \ (b1',lie2) ->
 361     tcMonoExpr b2 res_ty                `thenTc`    \ (b2',lie3) ->
 362     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3))
 363 \end{code}
 364
 365 \begin{code}
 366 tcMonoExpr expr@(HsDo do_or_lc stmts src_loc) res_ty
 367   = tcDoStmts do_or_lc stmts src_loc res_ty
 368 \end{code}
 369
 370 \begin{code}
 371 tcMonoExpr in_expr@(ExplicitList exprs) res_ty  -- Non-empty list
 372   = unifyListTy res_ty                        `thenTc` \ elt_ty ->
 373     mapAndUnzipTc (tc_elt elt_ty) exprs       `thenTc` \ (exprs', lies) ->
 374     returnTc (ExplicitListOut elt_ty exprs', plusLIEs lies)
 375   where
 376     tc_elt elt_ty expr
 377       = tcAddErrCtxt (listCtxt expr) $
 378         tcMonoExpr expr elt_ty
 379
 380 tcMonoExpr (ExplicitTuple exprs boxity) res_ty
 381   = unifyTupleTy boxity (length exprs) res_ty   `thenTc` \ arg_tys ->
 382     mapAndUnzipTc (\ (expr, arg_ty) -> tcMonoExpr expr arg_ty)
 383                (exprs `zip` arg_tys) -- we know they're of equal length.
 384                                                 `thenTc` \ (exprs', lies) ->
 385     returnTc (ExplicitTuple exprs' boxity, plusLIEs lies)
 386
 387 tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
 388   = tcAddErrCtxt (recordConCtxt expr)           $
 389     tcId con_name                       `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 390     let
 391         (_, record_ty) = splitFunTys con_tau
 392         (tycon, ty_args, _) = splitAlgTyConApp record_ty
 393     in
 394     ASSERT( maybeToBool (splitAlgTyConApp_maybe record_ty ) )
 395     unifyTauTy res_ty record_ty          `thenTc_`
 396
 397         -- Check that the record bindings match the constructor
 398         -- con_name is syntactically constrained to be a data constructor
 399     tcLookupDataCon con_name    `thenTc` \ (data_con, _, _) ->
 400     let
 401         bad_fields = badFields rbinds data_con
 402     in
 403     if not (null bad_fields) then
 404         mapNF_Tc (addErrTc . badFieldCon con_name) bad_fields   `thenNF_Tc_`
 405         failTc  -- Fail now, because tcRecordBinds will crash on a bad field
 406     else
 407
 408         -- Typecheck the record bindings
 409     tcRecordBinds tycon ty_args rbinds          `thenTc` \ (rbinds', rbinds_lie) ->
 410
 411     let
 412       missing_s_fields = missingStrictFields rbinds data_con
 413     in
 414     checkTcM (null missing_s_fields)
 415         (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
 416          returnNF_Tc ())  `thenNF_Tc_`
 417     let
 418       missing_fields = missingFields rbinds data_con
 419     in
 420     checkTcM (not (opt_WarnMissingFields && not (null missing_fields)))
 421         (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
 422          returnNF_Tc ())  `thenNF_Tc_`
 423
 424     returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
 425
 426 -- The main complication with RecordUpd is that we need to explicitly
 427 -- handle the *non-updated* fields.  Consider:
 428 --
 429 --      data T a b = MkT1 { fa :: a, fb :: b }
 430 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 431 --                 | MkT3 { fd :: a }
 432 --
 433 --      upd :: T a b -> c -> T a c
 434 --      upd t x = t { fb = x}
 435 --
 436 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 437 -- because upd should be equivalent to:
 438 --
 439 --      upd t x = case t of
 440 --                      MkT1 p q -> MkT1 p x
 441 --                      MkT2 a b -> MkT2 p b
 442 --                      MkT3 d   -> error ...
 443 --
 444 -- So we need to give a completely fresh type to the result record,
 445 -- and then constrain it by the fields that are *not* updated ("p" above).
 446 --
 447 -- Note that because MkT3 doesn't contain all the fields being updated,
 448 -- its RHS is simply an error, so it doesn't impose any type constraints
 449 --
 450 -- All this is done in STEP 4 below.
 451
 452 tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
 453   = tcAddErrCtxt (recordUpdCtxt expr)           $
 454
 455         -- STEP 0
 456         -- Check that the field names are really field names
 457     ASSERT( not (null rbinds) )
 458     let
 459         field_names = [field_name | (field_name, _, _) <- rbinds]
 460     in
 461     mapNF_Tc tcLookupGlobal_maybe field_names           `thenNF_Tc` \ maybe_sel_ids ->
 462     let
 463         bad_guys = [ addErrTc (notSelector field_name)
 464                    | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids,
 465                       case maybe_sel_id of
 466                         Just (AnId sel_id) -> not (isRecordSelector sel_id)
 467                         other              -> True
 468                    ]
 469     in
 470     checkTcM (null bad_guys) (listNF_Tc bad_guys `thenNF_Tc_` failTc)   `thenTc_`
 471
 472         -- STEP 1
 473         -- Figure out the tycon and data cons from the first field name
 474     let
 475         (Just sel_id : _)         = maybe_sel_ids
 476         (_, _, tau)               = ASSERT( isNotUsgTy (idType sel_id) )
 477                                     splitSigmaTy (idType sel_id)        -- Selectors can be overloaded
 478                                                                         -- when the data type has a context
 479         Just (data_ty, _)         = splitFunTy_maybe tau        -- Must succeed since sel_id is a selector
 480         (tycon, _, data_cons)       = splitAlgTyConApp data_ty
 481         (con_tyvars, _, _, _, _, _) = dataConSig (head data_cons)
 482     in
 483     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, _) ->
 484
 485         -- STEP 2
 486         -- Check that at least one constructor has all the named fields
 487         -- i.e. has an empty set of bad fields returned by badFields
 488     checkTc (any (null . badFields rbinds) data_cons)
 489             (badFieldsUpd rbinds)               `thenTc_`
 490
 491         -- STEP 3
 492         -- Typecheck the update bindings.
 493         -- (Do this after checking for bad fields in case there's a field that
 494         --  doesn't match the constructor.)
 495     let
 496         result_record_ty = mkTyConApp tycon result_inst_tys
 497     in
 498     unifyTauTy res_ty result_record_ty          `thenTc_`
 499     tcRecordBinds tycon result_inst_tys rbinds  `thenTc` \ (rbinds', rbinds_lie) ->
 500
 501         -- STEP 4
 502         -- Use the un-updated fields to find a vector of booleans saying
 503         -- which type arguments must be the same in updatee and result.
 504         --
 505         -- WARNING: this code assumes that all data_cons in a common tycon
 506         -- have FieldLabels abstracted over the same tyvars.
 507     let
 508         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (sel_id, _, _) <- rbinds']
 509         con_field_lbls_s    = map dataConFieldLabels data_cons
 510
 511                 -- A constructor is only relevant to this process if
 512                 -- it contains all the fields that are being updated
 513         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 514         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 515
 516         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 517         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 518
 519         mk_inst_ty (tyvar, result_inst_ty)
 520           | tyvar `elemVarSet` common_tyvars = returnNF_Tc result_inst_ty       -- Same as result type
 521           | otherwise                               = newTyVarTy boxedTypeKind  -- Fresh type
 522     in
 523     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 524
 525         -- STEP 5
 526         -- Typecheck the expression to be updated
 527     let
 528         record_ty = mkTyConApp tycon inst_tys
 529     in
 530     tcMonoExpr record_expr record_ty                    `thenTc`    \ (record_expr', record_lie) ->
 531
 532         -- STEP 6
 533         -- Figure out the LIE we need.  We have to generate some
 534         -- dictionaries for the data type context, since we are going to
 535         -- do some construction.
 536         --
 537         -- What dictionaries do we need?  For the moment we assume that all
 538         -- data constructors have the same context, and grab it from the first
 539         -- constructor.  If they have varying contexts then we'd have to
 540         -- union the ones that could participate in the update.
 541     let
 542         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 543         inst_env = mkTopTyVarSubst tyvars result_inst_tys
 544         theta'   = substClasses inst_env theta
 545     in
 546     newClassDicts RecordUpdOrigin theta'        `thenNF_Tc` \ (con_lie, dicts) ->
 547
 548         -- Phew!
 549     returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
 550               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie)
 551
 552 tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty
 553   = unifyListTy res_ty                          `thenTc` \ elt_ty ->
 554     tcMonoExpr expr elt_ty                      `thenTc` \ (expr', lie1) ->
 555
 556     tcLookupGlobalId enumFromClassOpName        `thenNF_Tc` \ sel_id ->
 557     newMethod (ArithSeqOrigin seq)
 558               sel_id [elt_ty]                   `thenNF_Tc` \ (lie2, enum_from_id) ->
 559
 560     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 561               lie1 `plusLIE` lie2)
 562
 563 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty
 564   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 565     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 566     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 567     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 568     tcLookupGlobalId enumFromThenClassOpName            `thenNF_Tc` \ sel_id ->
 569     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 570
 571     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 572                            (FromThen expr1' expr2'),
 573               lie1 `plusLIE` lie2 `plusLIE` lie3)
 574
 575 tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty
 576   = tcAddErrCtxt (arithSeqCtxt in_expr) $
 577     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 578     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 579     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 580     tcLookupGlobalId enumFromToClassOpName              `thenNF_Tc` \ sel_id ->
 581     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 582
 583     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 584                           (FromTo expr1' expr2'),
 585               lie1 `plusLIE` lie2 `plusLIE` lie3)
 586
 587 tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
 588   = tcAddErrCtxt  (arithSeqCtxt in_expr) $
 589     unifyListTy  res_ty                                 `thenTc`    \ elt_ty ->
 590     tcMonoExpr expr1 elt_ty                             `thenTc`    \ (expr1',lie1) ->
 591     tcMonoExpr expr2 elt_ty                             `thenTc`    \ (expr2',lie2) ->
 592     tcMonoExpr expr3 elt_ty                             `thenTc`    \ (expr3',lie3) ->
 593     tcLookupGlobalId enumFromThenToClassOpName          `thenNF_Tc` \ sel_id ->
 594     newMethod (ArithSeqOrigin seq) sel_id [elt_ty]      `thenNF_Tc` \ (lie4, eft_id) ->
 595
 596     returnTc (ArithSeqOut (HsVar eft_id)
 597                            (FromThenTo expr1' expr2' expr3'),
 598               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4)
 599 \end{code}
 600
 601 %************************************************************************
 602 %*                                                                      *
 603 \subsection{Expressions type signatures}
 604 %*                                                                      *
 605 %************************************************************************
 606
 607 \begin{code}
 608 tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
 609  = tcSetErrCtxt (exprSigCtxt in_expr)   $
 610    tcHsSigType  poly_ty         `thenTc` \ sig_tc_ty ->
 611
 612    if not (isSigmaTy sig_tc_ty) then
 613         -- Easy case
 614         unifyTauTy sig_tc_ty res_ty     `thenTc_`
 615         tcMonoExpr expr sig_tc_ty
 616
 617    else -- Signature is polymorphic
 618         tcPolyExpr expr sig_tc_ty               `thenTc` \ (_, _, expr, expr_ty, lie) ->
 619
 620             -- Now match the signature type with res_ty.
 621             -- We must not do this earlier, because res_ty might well
 622             -- mention variables free in the environment, and we'd get
 623             -- bogus complaints about not being able to for-all the
 624             -- sig_tyvars
 625         unifyTauTy res_ty expr_ty                       `thenTc_`
 626
 627             -- If everything is ok, return the stuff unchanged, except for
 628             -- the effect of any substutions etc.  We simply discard the
 629             -- result of the tcSimplifyAndCheck (inside tcPolyExpr), except for any default
 630             -- resolution it may have done, which is recorded in the
 631             -- substitution.
 632         returnTc (expr, lie)
 633 \end{code}
 634
 635 Implicit Parameter bindings.
 636
 637 \begin{code}
 638 tcMonoExpr (HsWith expr binds) res_ty
 639   = tcMonoExpr expr res_ty              `thenTc` \ (expr', lie) ->
 640     tcIPBinds binds                     `thenTc` \ (binds', types, lie2) ->
 641     partitionPredsOfLIE isBound lie     `thenTc` \ (ips, lie', dict_binds) ->
 642     let expr'' = if nullMonoBinds dict_binds
 643                  then expr'
 644                  else HsLet (mkMonoBind (revBinds dict_binds) [] NonRecursive)
 645                             expr'
 646     in
 647     tcCheckIPBinds binds' types ips     `thenTc_`
 648     returnTc (HsWith expr'' binds', lie' `plusLIE` lie2)
 649   where isBound p
 650           = case ipName_maybe p of
 651             Just n -> n `elem` names
 652             Nothing -> False
 653         names = map fst binds
 654         -- revBinds is used because tcSimplify outputs the bindings
 655         -- out-of-order.  it's not a problem elsewhere because these
 656         -- bindings are normally used in a recursive let
 657         -- ZZ probably need to find a better solution
 658         revBinds (b1 `AndMonoBinds` b2) =
 659             (revBinds b2) `AndMonoBinds` (revBinds b1)
 660         revBinds b = b
 661
 662 tcIPBinds ((name, expr) : binds)
 663   = newTyVarTy openTypeKind     `thenTc` \ ty ->
 664     tcGetSrcLoc                 `thenTc` \ loc ->
 665     let id = ipToId name ty loc in
 666     tcMonoExpr expr ty          `thenTc` \ (expr', lie) ->
 667     zonkTcType ty               `thenTc` \ ty' ->
 668     tcIPBinds binds             `thenTc` \ (binds', types, lie2) ->
 669     returnTc ((id, expr') : binds', ty : types, lie `plusLIE` lie2)
 670 tcIPBinds [] = returnTc ([], [], emptyLIE)
 671
 672 tcCheckIPBinds binds types ips
 673   = foldrTc tcCheckIPBind (getIPsOfLIE ips) (zip binds types)
 674
 675 -- ZZ how do we use the loc?
 676 tcCheckIPBind bt@((v, _), t1) ((n, t2) : ips) | getName v == n
 677   = unifyTauTy t1 t2            `thenTc_`
 678     tcCheckIPBind bt ips        `thenTc` \ ips' ->
 679     returnTc ips'
 680 tcCheckIPBind bt (ip : ips)
 681   = tcCheckIPBind bt ips        `thenTc` \ ips' ->
 682     returnTc (ip : ips')
 683 tcCheckIPBind bt []
 684   = returnTc []
 685 \end{code}
 686
 687 Typecheck expression which in most cases will be an Id.
 688
 689 \begin{code}
 690 tcExpr_id :: RenamedHsExpr
 691            -> TcM (TcExpr,
 692                      LIE,
 693                      TcType)
 694 tcExpr_id id_expr
 695  = case id_expr of
 696         HsVar name -> tcId name                 `thenNF_Tc` \ stuff ->
 697                       returnTc stuff
 698         other      -> newTyVarTy openTypeKind   `thenNF_Tc` \ id_ty ->
 699                       tcMonoExpr id_expr id_ty  `thenTc`    \ (id_expr', lie_id) ->
 700                       returnTc (id_expr', lie_id, id_ty)
 701 \end{code}
 702
 703 %************************************************************************
 704 %*                                                                      *
 705 \subsection{@tcApp@ typchecks an application}
 706 %*                                                                      *
 707 %************************************************************************
 708
 709 \begin{code}
 710
 711 tcApp :: RenamedHsExpr -> [RenamedHsExpr]       -- Function and args
 712       -> TcType                                 -- Expected result type of application
 713       -> TcM (TcExpr, [TcExpr],         -- Translated fun and args
 714                 LIE)
 715
 716 tcApp fun args res_ty
 717   =     -- First type-check the function
 718     tcExpr_id fun                               `thenTc` \ (fun', lie_fun, fun_ty) ->
 719
 720     tcAddErrCtxt (wrongArgsCtxt "too many" fun args) (
 721         split_fun_ty fun_ty (length args)
 722     )                                           `thenTc` \ (expected_arg_tys, actual_result_ty) ->
 723
 724         -- Unify with expected result before type-checking the args
 725         -- This is when we might detect a too-few args situation
 726     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty) (
 727        unifyTauTy res_ty actual_result_ty
 728     )                                                   `thenTc_`
 729
 730         -- Now typecheck the args
 731     mapAndUnzipTc (tcArg fun)
 732           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 733
 734     -- Check that the result type doesn't have any nested for-alls.
 735     -- For example, a "build" on its own is no good; it must be applied to something.
 736     checkTc (isTauTy actual_result_ty)
 737             (lurkingRank2Err fun actual_result_ty)      `thenTc_`
 738
 739     returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
 740
 741
 742 -- If an error happens we try to figure out whether the
 743 -- function has been given too many or too few arguments,
 744 -- and say so
 745 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
 746   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 747     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 748     let
 749       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 750       (env2, act_ty'') = tidyOpenType env1     act_ty'
 751       (exp_args, _) = splitFunTys exp_ty''
 752       (act_args, _) = splitFunTys act_ty''
 753
 754       message | length exp_args < length act_args = wrongArgsCtxt "too few" fun args
 755               | length exp_args > length act_args = wrongArgsCtxt "too many" fun args
 756               | otherwise                         = appCtxt fun args
 757     in
 758     returnNF_Tc (env2, message)
 759
 760
 761 split_fun_ty :: TcType          -- The type of the function
 762              -> Int                     -- Number of arguments
 763              -> TcM ([TcType],  -- Function argument types
 764                        TcType)  -- Function result types
 765
 766 split_fun_ty fun_ty 0
 767   = returnTc ([], fun_ty)
 768
 769 split_fun_ty fun_ty n
 770   =     -- Expect the function to have type A->B
 771     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 772     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 773     returnTc (arg_ty:arg_tys, final_res_ty)
 774 \end{code}
 775
 776 \begin{code}
 777 tcArg :: RenamedHsExpr                  -- The function (for error messages)
 778       -> (RenamedHsExpr, TcType, Int)   -- Actual argument and expected arg type
 779       -> TcM (TcExpr, LIE)      -- Resulting argument and LIE
 780
 781 tcArg the_fun (arg, expected_arg_ty, arg_no)
 782   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 783     tcExpr arg expected_arg_ty
 784 \end{code}
 785
 786
 787 %************************************************************************
 788 %*                                                                      *
 789 \subsection{@tcId@ typchecks an identifier occurrence}
 790 %*                                                                      *
 791 %************************************************************************
 792
 793 Between the renamer and the first invocation of the UsageSP inference,
 794 identifiers read from interface files will have usage information in
 795 their types, whereas other identifiers will not.  The unannotTy here
 796 in @tcId@ prevents this information from pointlessly propagating
 797 further prior to the first usage inference.
 798
 799 \begin{code}
 800 tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
 801
 802 tcId name
 803   =     -- Look up the Id and instantiate its type
 804     tcLookup name                       `thenNF_Tc` \ thing ->
 805     case thing of
 806       ATcId tc_id       -> instantiate_it (OccurrenceOf tc_id) tc_id (idType tc_id)
 807       AGlobal (AnId id) -> tcInstId id                  `thenNF_Tc` \ (tyvars, theta, tau) ->
 808                            instantiate_it2 (OccurrenceOf id) id tyvars theta tau
 809
 810   where
 811         -- The instantiate_it loop runs round instantiating the Id.
 812         -- It has to be a loop because we are now prepared to entertain
 813         -- types like
 814         --              f:: forall a. Eq a => forall b. Baz b => tau
 815         -- We want to instantiate this to
 816         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 817     instantiate_it orig fun ty
 818       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 819         tcSplitRhoTy rho        `thenNF_Tc` \ (theta, tau) ->
 820         instantiate_it2 orig fun tyvars theta tau
 821
 822     instantiate_it2 orig fun tyvars theta tau
 823       = if null theta then      -- Is it overloaded?
 824                 returnNF_Tc (mkHsTyApp (HsVar fun) arg_tys, emptyLIE, tau)
 825         else
 826                 -- Yes, it's overloaded
 827         instOverloadedFun orig fun arg_tys theta tau    `thenNF_Tc` \ (fun', lie1) ->
 828         instantiate_it orig fun' tau                    `thenNF_Tc` \ (expr, lie2, final_tau) ->
 829         returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
 830
 831       where
 832         arg_tys = mkTyVarTys tyvars
 833 \end{code}
 834
 835 %************************************************************************
 836 %*                                                                      *
 837 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 838 %*                                                                      *
 839 %************************************************************************
 840
 841 \begin{code}
 842 tcDoStmts do_or_lc stmts src_loc res_ty
 843   =     -- get the Monad and MonadZero classes
 844         -- create type consisting of a fresh monad tyvar
 845     ASSERT( not (null stmts) )
 846     tcAddSrcLoc src_loc $
 847
 848     newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind)        `thenNF_Tc` \ m ->
 849     newTyVarTy boxedTypeKind                                    `thenNF_Tc` \ elt_ty ->
 850     unifyTauTy res_ty (mkAppTy m elt_ty)                        `thenTc_`
 851
 852         -- If it's a comprehension we're dealing with,
 853         -- force it to be a list comprehension.
 854         -- (as of Haskell 98, monad comprehensions are no more.)
 855     (case do_or_lc of
 856        ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
 857        _        -> returnTc ())                                 `thenTc_`
 858
 859     tcStmts do_or_lc (mkAppTy m) stmts elt_ty   `thenTc`   \ (stmts', stmts_lie) ->
 860
 861         -- Build the then and zero methods in case we need them
 862         -- It's important that "then" and "return" appear just once in the final LIE,
 863         -- not only for typechecker efficiency, but also because otherwise during
 864         -- simplification we end up with silly stuff like
 865         --      then = case d of (t,r) -> t
 866         --      then = then
 867         -- where the second "then" sees that it already exists in the "available" stuff.
 868         --
 869     tcLookupGlobalId returnMClassOpName         `thenNF_Tc` \ return_sel_id ->
 870     tcLookupGlobalId thenMClassOpName           `thenNF_Tc` \ then_sel_id ->
 871     tcLookupGlobalId failMClassOpName           `thenNF_Tc` \ fail_sel_id ->
 872     newMethod DoOrigin return_sel_id [m]        `thenNF_Tc` \ (return_lie, return_id) ->
 873     newMethod DoOrigin then_sel_id [m]          `thenNF_Tc` \ (then_lie, then_id) ->
 874     newMethod DoOrigin fail_sel_id [m]          `thenNF_Tc` \ (fail_lie, fail_id) ->
 875     let
 876       monad_lie = then_lie `plusLIE` return_lie `plusLIE` fail_lie
 877     in
 878     returnTc (HsDoOut do_or_lc stmts' return_id then_id fail_id res_ty src_loc,
 879               stmts_lie `plusLIE` monad_lie)
 880 \end{code}
 881
 882
 883 %************************************************************************
 884 %*                                                                      *
 885 \subsection{Record bindings}
 886 %*                                                                      *
 887 %************************************************************************
 888
 889 Game plan for record bindings
 890 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 891 1. Find the TyCon for the bindings, from the first field label.
 892
 893 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 894
 895 For each binding field = value
 896
 897 3. Instantiate the field type (from the field label) using the type
 898    envt from step 2.
 899
 900 4  Type check the value using tcArg, passing the field type as
 901    the expected argument type.
 902
 903 This extends OK when the field types are universally quantified.
 904
 905
 906 \begin{code}
 907 tcRecordBinds
 908         :: TyCon                -- Type constructor for the record
 909         -> [TcType]             -- Args of this type constructor
 910         -> RenamedRecordBinds
 911         -> TcM (TcRecordBinds, LIE)
 912
 913 tcRecordBinds tycon ty_args rbinds
 914   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 915     returnTc (rbinds', plusLIEs lies)
 916   where
 917     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 918
 919     do_bind (field_lbl_name, rhs, pun_flag)
 920       = tcLookupGlobalId field_lbl_name         `thenNF_Tc` \ sel_id ->
 921         let
 922             field_lbl = recordSelectorFieldLabel sel_id
 923             field_ty  = substTy tenv (fieldLabelType field_lbl)
 924         in
 925         ASSERT( isRecordSelector sel_id )
 926                 -- This lookup and assertion will surely succeed, because
 927                 -- we check that the fields are indeed record selectors
 928                 -- before calling tcRecordBinds
 929         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 930                 -- The caller of tcRecordBinds has already checked
 931                 -- that all the fields come from the same type
 932
 933         tcPolyExpr rhs field_ty         `thenTc` \ (rhs', lie, _, _, _) ->
 934
 935         returnTc ((sel_id, rhs', pun_flag), lie)
 936
 937 badFields rbinds data_con
 938   = [field_name | (field_name, _, _) <- rbinds,
 939                   not (field_name `elem` field_names)
 940     ]
 941   where
 942     field_names = map fieldLabelName (dataConFieldLabels data_con)
 943
 944 missingStrictFields rbinds data_con
 945   = [ fn | fn <- strict_field_names,
 946                  not (fn `elem` field_names_used)
 947     ]
 948   where
 949     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 950     strict_field_names = mapMaybe isStrict field_info
 951
 952     isStrict (fl, MarkedStrict) = Just (fieldLabelName fl)
 953     isStrict _                  = Nothing
 954
 955     field_info = zip (dataConFieldLabels data_con)
 956                      (dataConStrictMarks data_con)
 957
 958 missingFields rbinds data_con
 959   = [ fn | fn <- non_strict_field_names, not (fn `elem` field_names_used) ]
 960   where
 961     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 962
 963      -- missing strict fields have already been flagged as
 964      -- being so, so leave them out here.
 965     non_strict_field_names = mapMaybe isn'tStrict field_info
 966
 967     isn'tStrict (fl, MarkedStrict) = Nothing
 968     isn'tStrict (fl, _)            = Just (fieldLabelName fl)
 969
 970     field_info = zip (dataConFieldLabels data_con)
 971                      (dataConStrictMarks data_con)
 972
 973 \end{code}
 974
 975 %************************************************************************
 976 %*                                                                      *
 977 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
 978 %*                                                                      *
 979 %************************************************************************
 980
 981 \begin{code}
 982 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE)
 983
 984 tcMonoExprs [] [] = returnTc ([], emptyLIE)
 985 tcMonoExprs (expr:exprs) (ty:tys)
 986  = tcMonoExpr  expr  ty         `thenTc` \ (expr',  lie1) ->
 987    tcMonoExprs exprs tys                `thenTc` \ (exprs', lie2) ->
 988    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 989 \end{code}
 990
 991
 992 %************************************************************************
 993 %*                                                                      *
 994 \subsection{Literals}
 995 %*                                                                      *
 996 %************************************************************************
 997
 998 Overloaded literals.
 999
1000 \begin{code}
1001 tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
1002 tcLit (HsLitLit s _) res_ty
1003   = tcLookupClass cCallableClassName                    `thenNF_Tc` \ cCallableClass ->
1004     newClassDicts (LitLitOrigin (_UNPK_ s))
1005                   [(cCallableClass,[res_ty])]           `thenNF_Tc` \ (dicts, _) ->
1006     returnTc (HsLit (HsLitLit s res_ty), dicts)
1007
1008 tcLit lit res_ty
1009   = unifyTauTy res_ty (simpleHsLitTy lit)               `thenTc_`
1010     returnTc (HsLit lit, emptyLIE)
1011 \end{code}
1012
1013
1014 %************************************************************************
1015 %*                                                                      *
1016 \subsection{Errors and contexts}
1017 %*                                                                      *
1018 %************************************************************************
1019
1020 Mini-utils:
1021
1022 \begin{code}
1023 pp_nest_hang :: String -> SDoc -> SDoc
1024 pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
1025 \end{code}
1026
1027 Boring and alphabetical:
1028 \begin{code}
1029 arithSeqCtxt expr
1030   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
1031
1032 caseCtxt expr
1033   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1034
1035 caseScrutCtxt expr
1036   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1037
1038 exprSigCtxt expr
1039   = hang (ptext SLIT("In an expression with a type signature:"))
1040          4 (ppr expr)
1041
1042 listCtxt expr
1043   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1044
1045 predCtxt expr
1046   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1047
1048 sectionRAppCtxt expr
1049   = hang (ptext SLIT("In the right section:")) 4 (ppr expr)
1050
1051 sectionLAppCtxt expr
1052   = hang (ptext SLIT("In the left section:")) 4 (ppr expr)
1053
1054 funAppCtxt fun arg arg_no
1055   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1056                     quotes (ppr fun) <> text ", namely"])
1057          4 (quotes (ppr arg))
1058
1059 wrongArgsCtxt too_many_or_few fun args
1060   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1061                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1062                     <+> ptext SLIT("arguments in the call"))
1063          4 (parens (ppr the_app))
1064   where
1065     the_app = foldl HsApp fun args      -- Used in error messages
1066
1067 appCtxt fun args
1068   = ptext SLIT("In the application") <+> quotes (ppr the_app)
1069   where
1070     the_app = foldl HsApp fun args      -- Used in error messages
1071
1072 lurkingRank2Err fun fun_ty
1073   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1074          4 (vcat [ptext SLIT("It is applied to too few arguments"),
1075                   ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
1076
1077 badFieldsUpd rbinds
1078   = hang (ptext SLIT("No constructor has all these fields:"))
1079          4 (pprQuotedList fields)
1080   where
1081     fields = [field | (field, _, _) <- rbinds]
1082
1083 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1084 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1085
1086 notSelector field
1087   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1088
1089 missingStrictFieldCon :: Name -> Name -> SDoc
1090 missingStrictFieldCon con field
1091   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
1092           ptext SLIT("does not have the required strict field"), quotes (ppr field)]
1093
1094 missingFieldCon :: Name -> Name -> SDoc
1095 missingFieldCon con field
1096   = hsep [ptext SLIT("Field") <+> quotes (ppr field),
1097           ptext SLIT("is not initialised")]
1098 \end{code}