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         -- Unify with expected result before type-checking the args
 597         -- so that the info from res_ty percolates to expected_arg_tys
 598         -- This is when we might detect a too-few args situation
 599     tcAddErrCtxtM (checkArgsCtxt fun args res_ty actual_result_ty)
 600                   (tcSub res_ty actual_result_ty)       `thenTc` \ (co_fn, lie_res) ->
 601
 602         -- Now typecheck the args
 603     mapAndUnzipTc (tcArg fun)
 604           (zip3 args expected_arg_tys [1..])    `thenTc` \ (args', lie_args_s) ->
 605
 606     returnTc (co_fn <$> foldl HsApp fun' args',
 607               lie_res `plusLIE` lie_fun `plusLIE` plusLIEs lie_args_s)
 608
 609
 610 -- If an error happens we try to figure out whether the
 611 -- function has been given too many or too few arguments,
 612 -- and say so
 613 checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env
 614   = zonkTcType expected_res_ty    `thenNF_Tc` \ exp_ty' ->
 615     zonkTcType actual_res_ty      `thenNF_Tc` \ act_ty' ->
 616     let
 617       (env1, exp_ty'') = tidyOpenType tidy_env exp_ty'
 618       (env2, act_ty'') = tidyOpenType env1     act_ty'
 619       (exp_args, _)    = tcSplitFunTys exp_ty''
 620       (act_args, _)    = tcSplitFunTys act_ty''
 621
 622       len_act_args     = length act_args
 623       len_exp_args     = length exp_args
 624
 625       message | len_exp_args < len_act_args = wrongArgsCtxt "too few" fun args
 626               | len_exp_args > len_act_args = wrongArgsCtxt "too many" fun args
 627               | otherwise                   = appCtxt fun args
 628     in
 629     returnNF_Tc (env2, message)
 630
 631
 632 split_fun_ty :: TcType          -- The type of the function
 633              -> Int             -- Number of arguments
 634              -> TcM ([TcType],  -- Function argument types
 635                      TcType)    -- Function result types
 636
 637 split_fun_ty fun_ty 0
 638   = returnTc ([], fun_ty)
 639
 640 split_fun_ty fun_ty n
 641   =     -- Expect the function to have type A->B
 642     unifyFunTy fun_ty           `thenTc` \ (arg_ty, res_ty) ->
 643     split_fun_ty res_ty (n-1)   `thenTc` \ (arg_tys, final_res_ty) ->
 644     returnTc (arg_ty:arg_tys, final_res_ty)
 645 \end{code}
 646
 647 \begin{code}
 648 tcArg :: RenamedHsExpr                          -- The function (for error messages)
 649       -> (RenamedHsExpr, TcSigmaType, Int)      -- Actual argument and expected arg type
 650       -> TcM (TcExpr, LIE)                      -- Resulting argument and LIE
 651
 652 tcArg the_fun (arg, expected_arg_ty, arg_no)
 653   = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $
 654     tcExpr arg expected_arg_ty
 655 \end{code}
 656
 657
 658 %************************************************************************
 659 %*                                                                      *
 660 \subsection{@tcId@ typchecks an identifier occurrence}
 661 %*                                                                      *
 662 %************************************************************************
 663
 664 \begin{code}
 665 tcId :: Name -> NF_TcM (TcExpr, LIE, TcType)
 666 tcId name       -- Look up the Id and instantiate its type
 667   = tcLookupId name                     `thenNF_Tc` \ id ->
 668     tcInstId id
 669 \end{code}
 670
 671 Typecheck expression which in most cases will be an Id.
 672
 673 \begin{code}
 674 tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType)
 675 tcExpr_id (HsVar name) = tcId name
 676 tcExpr_id expr         = newTyVarTy openTypeKind        `thenNF_Tc` \ id_ty ->
 677                          tcMonoExpr expr id_ty  `thenTc`    \ (expr', lie_id) ->
 678                          returnTc (expr', lie_id, id_ty)
 679 \end{code}
 680
 681
 682 %************************************************************************
 683 %*                                                                      *
 684 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 685 %*                                                                      *
 686 %************************************************************************
 687
 688 \begin{code}
 689 tcDoStmts do_or_lc stmts src_loc res_ty
 690   =     -- get the Monad and MonadZero classes
 691         -- create type consisting of a fresh monad tyvar
 692     ASSERT( not (null stmts) )
 693     tcAddSrcLoc src_loc $
 694
 695         -- If it's a comprehension we're dealing with,
 696         -- force it to be a list comprehension.
 697         -- (as of Haskell 98, monad comprehensions are no more.)
 698     (case do_or_lc of
 699        ListComp -> unifyListTy res_ty                   `thenTc` \ elt_ty ->
 700                    returnNF_Tc (mkTyConTy listTyCon, (mkListTy, elt_ty))
 701
 702        _        -> newTyVarTy (mkArrowKind liftedTypeKind liftedTypeKind)       `thenNF_Tc` \ m_ty ->
 703                    newTyVarTy liftedTypeKind                                    `thenNF_Tc` \ elt_ty ->
 704                    unifyTauTy res_ty (mkAppTy m_ty elt_ty)                      `thenTc_`
 705                    returnNF_Tc (m_ty, (mkAppTy m_ty, elt_ty))
 706     )                                                   `thenNF_Tc` \ (tc_ty, m_ty) ->
 707
 708     tcStmts (DoCtxt do_or_lc) m_ty stmts                `thenTc`   \ (stmts', stmts_lie) ->
 709
 710         -- Build the then and zero methods in case we need them
 711         -- It's important that "then" and "return" appear just once in the final LIE,
 712         -- not only for typechecker efficiency, but also because otherwise during
 713         -- simplification we end up with silly stuff like
 714         --      then = case d of (t,r) -> t
 715         --      then = then
 716         -- where the second "then" sees that it already exists in the "available" stuff.
 717         --
 718     tcLookupGlobalId returnMName                `thenNF_Tc` \ return_sel_id ->
 719     tcLookupGlobalId thenMName                  `thenNF_Tc` \ then_sel_id ->
 720     tcLookupGlobalId failMName                  `thenNF_Tc` \ fail_sel_id ->
 721     newMethod DoOrigin return_sel_id [tc_ty]    `thenNF_Tc` \ return_inst ->
 722     newMethod DoOrigin then_sel_id   [tc_ty]    `thenNF_Tc` \ then_inst ->
 723     newMethod DoOrigin fail_sel_id   [tc_ty]    `thenNF_Tc` \ fail_inst ->
 724     let
 725         monad_lie = mkLIE [return_inst, then_inst, fail_inst]
 726     in
 727     returnTc (HsDoOut do_or_lc stmts'
 728                       (instToId return_inst) (instToId then_inst) (instToId fail_inst)
 729                       res_ty src_loc,
 730               stmts_lie `plusLIE` monad_lie)
 731 \end{code}
 732
 733
 734 %************************************************************************
 735 %*                                                                      *
 736 \subsection{Record bindings}
 737 %*                                                                      *
 738 %************************************************************************
 739
 740 Game plan for record bindings
 741 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 742 1. Find the TyCon for the bindings, from the first field label.
 743
 744 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 745
 746 For each binding field = value
 747
 748 3. Instantiate the field type (from the field label) using the type
 749    envt from step 2.
 750
 751 4  Type check the value using tcArg, passing the field type as
 752    the expected argument type.
 753
 754 This extends OK when the field types are universally quantified.
 755
 756
 757 \begin{code}
 758 tcRecordBinds
 759         :: TyCon                -- Type constructor for the record
 760         -> [TcType]             -- Args of this type constructor
 761         -> RenamedRecordBinds
 762         -> TcM (TcRecordBinds, LIE)
 763
 764 tcRecordBinds tycon ty_args rbinds
 765   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 766     returnTc (rbinds', plusLIEs lies)
 767   where
 768     tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args
 769
 770     do_bind (field_lbl_name, rhs, pun_flag)
 771       = tcLookupGlobalId field_lbl_name         `thenNF_Tc` \ sel_id ->
 772         let
 773             field_lbl = recordSelectorFieldLabel sel_id
 774             field_ty  = substTy tenv (fieldLabelType field_lbl)
 775         in
 776         ASSERT( isRecordSelector sel_id )
 777                 -- This lookup and assertion will surely succeed, because
 778                 -- we check that the fields are indeed record selectors
 779                 -- before calling tcRecordBinds
 780         ASSERT2( fieldLabelTyCon field_lbl == tycon, ppr field_lbl )
 781                 -- The caller of tcRecordBinds has already checked
 782                 -- that all the fields come from the same type
 783
 784         tcExpr rhs field_ty                     `thenTc` \ (rhs', lie) ->
 785
 786         returnTc ((sel_id, rhs', pun_flag), lie)
 787
 788 badFields rbinds data_con
 789   = [field_name | (field_name, _, _) <- rbinds,
 790                   not (field_name `elem` field_names)
 791     ]
 792   where
 793     field_names = map fieldLabelName (dataConFieldLabels data_con)
 794
 795 missingFields rbinds data_con
 796   | null field_labels = ([], [])        -- Not declared as a record;
 797                                         -- But C{} is still valid
 798   | otherwise
 799   = (missing_strict_fields, other_missing_fields)
 800   where
 801     missing_strict_fields
 802         = [ fl | (fl, str) <- field_info,
 803                  isMarkedStrict str,
 804                  not (fieldLabelName fl `elem` field_names_used)
 805           ]
 806     other_missing_fields
 807         = [ fl | (fl, str) <- field_info,
 808                  not (isMarkedStrict str),
 809                  not (fieldLabelName fl `elem` field_names_used)
 810           ]
 811
 812     field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
 813     field_labels     = dataConFieldLabels data_con
 814
 815     field_info = zipEqual "missingFields"
 816                           field_labels
 817                           (dropList ex_theta (dataConStrictMarks data_con))
 818         -- The 'drop' is because dataConStrictMarks
 819         -- includes the existential dictionaries
 820     (_, _, _, ex_theta, _, _) = dataConSig data_con
 821 \end{code}
 822
 823 %************************************************************************
 824 %*                                                                      *
 825 \subsection{@tcMonoExprs@ typechecks a {\em list} of expressions}
 826 %*                                                                      *
 827 %************************************************************************
 828
 829 \begin{code}
 830 tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE)
 831
 832 tcMonoExprs [] [] = returnTc ([], emptyLIE)
 833 tcMonoExprs (expr:exprs) (ty:tys)
 834  = tcMonoExpr  expr  ty         `thenTc` \ (expr',  lie1) ->
 835    tcMonoExprs exprs tys                `thenTc` \ (exprs', lie2) ->
 836    returnTc (expr':exprs', lie1 `plusLIE` lie2)
 837 \end{code}
 838
 839
 840 %************************************************************************
 841 %*                                                                      *
 842 \subsection{Literals}
 843 %*                                                                      *
 844 %************************************************************************
 845
 846 Overloaded literals.
 847
 848 \begin{code}
 849 tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE)
 850 tcLit (HsLitLit s _) res_ty
 851   = tcLookupClass cCallableClassName                    `thenNF_Tc` \ cCallableClass ->
 852     newDicts (LitLitOrigin (_UNPK_ s))
 853              [mkClassPred cCallableClass [res_ty]]      `thenNF_Tc` \ dicts ->
 854     returnTc (HsLit (HsLitLit s res_ty), mkLIE dicts)
 855
 856 tcLit lit res_ty
 857   = unifyTauTy res_ty (simpleHsLitTy lit)               `thenTc_`
 858     returnTc (HsLit lit, emptyLIE)
 859 \end{code}
 860
 861
 862 %************************************************************************
 863 %*                                                                      *
 864 \subsection{Errors and contexts}
 865 %*                                                                      *
 866 %************************************************************************
 867
 868 Mini-utils:
 869
 870 Boring and alphabetical:
 871 \begin{code}
 872 arithSeqCtxt expr
 873   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr expr)
 874
 875 caseCtxt expr
 876   = hang (ptext SLIT("In the case expression:")) 4 (ppr expr)
 877
 878 caseScrutCtxt expr
 879   = hang (ptext SLIT("In the scrutinee of a case expression:")) 4 (ppr expr)
 880
 881 exprSigCtxt expr
 882   = hang (ptext SLIT("In an expression with a type signature:"))
 883          4 (ppr expr)
 884
 885 listCtxt expr
 886   = hang (ptext SLIT("In the list element:")) 4 (ppr expr)
 887
 888 predCtxt expr
 889   = hang (ptext SLIT("In the predicate expression:")) 4 (ppr expr)
 890
 891 exprCtxt expr
 892   = hang (ptext SLIT("In the expression:")) 4 (ppr expr)
 893
 894 funAppCtxt fun arg arg_no
 895   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
 896                     quotes (ppr fun) <> text ", namely"])
 897          4 (quotes (ppr arg))
 898
 899 wrongArgsCtxt too_many_or_few fun args
 900   = hang (ptext SLIT("Probable cause:") <+> quotes (ppr fun)
 901                     <+> ptext SLIT("is applied to") <+> text too_many_or_few
 902                     <+> ptext SLIT("arguments in the call"))
 903          4 (parens (ppr the_app))
 904   where
 905     the_app = foldl HsApp fun args      -- Used in error messages
 906
 907 appCtxt fun args
 908   = ptext SLIT("In the application") <+> quotes (ppr the_app)
 909   where
 910     the_app = foldl HsApp fun args      -- Used in error messages
 911
 912 lurkingRank2Err fun fun_ty
 913   = hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
 914          4 (vcat [ptext SLIT("It is applied to too few arguments"),
 915                   ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
 916
 917 badFieldsUpd rbinds
 918   = hang (ptext SLIT("No constructor has all these fields:"))
 919          4 (pprQuotedList fields)
 920   where
 921     fields = [field | (field, _, _) <- rbinds]
 922
 923 recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
 924 recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
 925
 926 notSelector field
 927   = hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
 928
 929 missingStrictFieldCon :: Name -> FieldLabel -> SDoc
 930 missingStrictFieldCon con field
 931   = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
 932           ptext SLIT("does not have the required strict field"), quotes (ppr field)]
 933
 934 missingFieldCon :: Name -> FieldLabel -> SDoc
 935 missingFieldCon con field
 936   = hsep [ptext SLIT("Field") <+> quotes (ppr field),
 937           ptext SLIT("is not initialised")]
 938 \end{code}