ghc/compiler/typecheck/TcExpr.lhs

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