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, 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 )
  58 import PrelNames        ( cCallableClassName,
  59                           cReturnableClassName,
  60                           enumFromName, enumFromThenName,
  61                           enumFromToName, enumFromThenToName,
  62                           enumFromToPName, enumFromThenToPName,
  63                           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  = tcAddErrCtxt (exprSigCtxt in_expr)   $
 140    tcHsSigType ExprSigCtxt poly_ty      `thenTc` \ sig_tc_ty ->
 141    tcExpr expr sig_tc_ty                `thenTc` \ (expr', lie1) ->
 142
 143         -- Must instantiate the outer for-alls of sig_tc_ty
 144         -- else we risk instantiating a ? res_ty to a forall-type
 145         -- which breaks the invariant that tcMonoExpr only returns phi-types
 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 method_names _ src_loc) res_ty
 340   = tcAddSrcLoc src_loc (tcDoStmts do_or_lc stmts method_names 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 tcDoStmts PArrComp stmts method_names src_loc res_ty
 824   = unifyPArrTy res_ty                    `thenTc` \elt_ty              ->
 825     tcStmts (DoCtxt PArrComp)
 826             (mkPArrTy, elt_ty) stmts      `thenTc` \(stmts', stmts_lie) ->
 827     returnTc (HsDo PArrComp stmts'
 828                    []                   -- Unused
 829                    res_ty src_loc,
 830               stmts_lie)
 831
 832 tcDoStmts ListComp stmts method_names src_loc res_ty
 833   = unifyListTy res_ty                  `thenTc` \ elt_ty ->
 834     tcStmts (DoCtxt ListComp)
 835             (mkListTy, elt_ty) stmts    `thenTc` \ (stmts', stmts_lie) ->
 836     returnTc (HsDo ListComp stmts'
 837                    []                   -- Unused
 838                    res_ty src_loc,
 839               stmts_lie)
 840
 841 tcDoStmts DoExpr stmts method_names src_loc res_ty
 842   = newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)      `thenNF_Tc` \ tc_ty ->
 843     newTyVarTy liftedTypeKind                                   `thenNF_Tc` \ elt_ty ->
 844     unifyTauTy res_ty (mkAppTy tc_ty elt_ty)                    `thenTc_`
 845
 846     tcStmts (DoCtxt DoExpr) (mkAppTy tc_ty, elt_ty) stmts       `thenTc`   \ (stmts', stmts_lie) ->
 847
 848         -- Build the then and zero methods in case we need them
 849         -- It's important that "then" and "return" appear just once in the final LIE,
 850         -- not only for typechecker efficiency, but also because otherwise during
 851         -- simplification we end up with silly stuff like
 852         --      then = case d of (t,r) -> t
 853         --      then = then
 854         -- where the second "then" sees that it already exists in the "available" stuff.
 855         --
 856     mapNF_Tc (newMethodFromName DoOrigin tc_ty) method_names    `thenNF_Tc` \ insts ->
 857
 858     returnTc (HsDo DoExpr stmts'
 859                    (map instToId insts)
 860                    res_ty src_loc,
 861               stmts_lie `plusLIE` mkLIE insts)
 862 \end{code}
 863
 864
 865 %************************************************************************
 866 %*                                                                      *
 867 \subsection{Record bindings}
 868 %*                                                                      *
 869 %************************************************************************
 870
 871 Game plan for record bindings
 872 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 873 1. Find the TyCon for the bindings, from the first field label.
 874
 875 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 876
 877 For each binding field = value
 878
 879 3. Instantiate the field type (from the field label) using the type
 880    envt from step 2.
 881
 882 4  Type check the value using tcArg, passing the field type as
 883    the expected argument type.
 884
 885 This extends OK when the field types are universally quantified.
 886
 887
 888 \begin{code}
 889 tcRecordBinds
 890         :: TyCon                -- Type constructor for the record
 891         -> [TcType]             -- Args of this type constructor
 892         -> RenamedRecordBinds
 893         -> TcM (TcRecordBinds, LIE)
 894
 895 tcRecordBinds tycon ty_args rbinds
 896   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 897     returnTc (rbinds', plusLIEs lies)
 898   where
 899     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 900
 901     do_bind (field_lbl_name, rhs, pun_flag)
 902       = tcLookupGlobalId field_lbl_name         `thenNF_Tc` \ sel_id ->
 903         let
 904             field_lbl = recordSelectorFieldLabel sel_id
 905             field_ty  = substTy tenv (fieldLabelType field_lbl)
 906         in
 907         ASSERT( isRecordSelector sel_id )
 908                 -- This lookup and assertion will surely succeed, because
 909                 -- we check that the fields are indeed record selectors
 910                 -- before calling tcRecordBinds
 911         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 912                 -- The caller of tcRecordBinds has already checked
 913                 -- that all the fields come from the same type
 914
 915         tcExpr rhs field_ty                     `thenTc` \ (rhs', lie) ->
 916
 917         returnTc ((sel_id, rhs', pun_flag), lie)
 918
 919 badFields rbinds data_con
 920   = [field_name | (field_name, _, _) <- rbinds,
 921                   not (field_name `elem` field_names)
 922     ]
 923   where
 924     field_names = map fieldLabelName (dataConFieldLabels data_con)
 925
 926 missingFields rbinds data_con
 927   | null field_labels = ([], [])        -- Not declared as a record;
 928                                         -- But C{} is still valid
 929   | otherwise
 930   = (missing_strict_fields, other_missing_fields)
 931   where
 932     missing_strict_fields
 933         = [ fl | (fl, str) <- field_info,
 934                  isMarkedStrict str,
 935                  not (fieldLabelName fl `elem` field_names_used)
 936           ]
 937     other_missing_fields
 938         = [ fl | (fl, str) <- field_info,
 939                  not (isMarkedStrict str),
 940                  not (fieldLabelName fl `elem` field_names_used)
 941           ]
 942
 943     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 944     field_labels     = dataConFieldLabels data_con
 945
 946     field_info = zipEqual "missingFields"
 947                           field_labels
 948                           (dropList ex_theta (dataConStrictMarks data_con))
 949         -- The 'drop' is because dataConStrictMarks
 950         -- includes the existential dictionaries
 951     (_, _, _, ex_theta, _, _) = dataConSig data_con
 952 \end{code}
 953
 954 %************************************************************************
 955 %*                                                                      *
 956 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
 957 %*                                                                      *
 958 %************************************************************************
 959
 960 \begin{code}
 961 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE)
 962
 963 tcMonoExprs [] [] = returnTc ([], emptyLIE)
 964 tcMonoExprs (expr:exprs) (ty:tys)
 965  = tcMonoExpr  expr  ty         `thenTc` \ (expr',  lie1) ->
 966    tcMonoExprs exprs tys                `thenTc` \ (exprs', lie2) ->
 967    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 968 \end{code}
 969
 970
 971 %************************************************************************
 972 %*                                                                      *
 973 \subsection{Literals}
 974 %*                                                                      *
 975 %************************************************************************
 976
 977 Overloaded literals.
 978
 979 \begin{code}
 980 tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
 981 tcLit (HsLitLit s _) res_ty
 982   = tcLookupClass cCallableClassName                    `thenNF_Tc` \ cCallableClass ->
 983     newDicts (LitLitOrigin (unpackFS s))
 984              [mkClassPred cCallableClass [res_ty]]      `thenNF_Tc` \ dicts ->
 985     returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
 986
 987 tcLit lit res_ty
 988   = unifyTauTy res_ty (simpleHsLitTy lit)               `thenTc_`
 989     returnTc (HsLit lit, emptyLIE)
 990 \end{code}
 991
 992
 993 %************************************************************************
 994 %*                                                                      *
 995 \subsection{Errors and contexts}
 996 %*                                                                      *
 997 %************************************************************************
 998
 999 Mini-utils:
1000
1001 Boring and alphabetical:
1002 \begin{code}
1003 arithSeqCtxt expr
1004   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
1005
1006 parrSeqCtxt expr
1007   = hang (ptext SLIT("In a parallel array sequence:")) 4 (ppr expr)
1008
1009 caseCtxt expr
1010   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
1011
1012 caseScrutCtxt expr
1013   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
1014
1015 exprSigCtxt expr
1016   = hang (ptext SLIT("When checking the type signature of the expression:"))
1017          4 (ppr expr)
1018
1019 listCtxt expr
1020   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
1021
1022 parrCtxt expr
1023   = hang (ptext SLIT("In the parallel array element:")) 4 (ppr expr)
1024
1025 predCtxt expr
1026   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
1027
1028 exprCtxt expr
1029   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
1030
1031 funAppCtxt fun arg arg_no
1032   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1033                     quotes (ppr fun) <> text ", namely"])
1034          4 (quotes (ppr arg))
1035
1036 wrongArgsCtxt too_many_or_few fun args
1037   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
1038                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
1039                     <+> ptext SLIT("arguments in the call"))
1040          4 (parens (ppr the_app))
1041   where
1042     the_app = foldl HsApp fun args      -- Used in error messages
1043
1044 appCtxt fun args
1045   = ptext SLIT("In the application") <+> quotes (ppr the_app)
1046   where
1047     the_app = foldl HsApp fun args      -- Used in error messages
1048
1049 lurkingRank2Err fun fun_ty
1050   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
1051          4 (vcat [ptext SLIT("It is applied to too few arguments"),
1052                   ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
1053
1054 badFieldsUpd rbinds
1055   = hang (ptext SLIT("No constructor has all these fields:"))
1056          4 (pprQuotedList fields)
1057   where
1058     fields = [field | (field, _, _) <- rbinds]
1059
1060 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
1061 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
1062
1063 notSelector field
1064   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
1065
1066 missingStrictFieldCon :: Name -> FieldLabel -> SDoc
1067 missingStrictFieldCon con field
1068   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
1069           ptext SLIT("does not have the required strict field"), quotes (ppr field)]
1070
1071 missingFieldCon :: Name -> FieldLabel -> SDoc
1072 missingFieldCon con field
1073   = hsep [ptext SLIT("Field") <+> quotes (ppr field),
1074           ptext SLIT("is not initialised")]
1075 \end{code}