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