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