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