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