ghc/compiler/typecheck/TcExpr.lhs

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