ghc/compiler/typecheck/TcExpr.lhs

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