ghc/compiler/typecheck/TcExpr.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[TcExpr]{Typecheck an expression}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module TcExpr ( tcExpr ) where
  10
  11 import Ubiq
  12
  13 import HsSyn            ( HsExpr(..), Qual(..), Stmt(..),
  14                           HsBinds(..), Bind(..), MonoBinds(..),
  15                           ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
  16                           Match, Fake, InPat, OutPat, PolyType,
  17                           irrefutablePat, collectPatBinders )
  18 import RnHsSyn          ( RenamedHsExpr(..), RenamedQual(..),
  19                           RenamedStmt(..), RenamedRecordBinds(..),
  20                           RnName{-instance Outputable-}
  21                         )
  22 import TcHsSyn          ( TcExpr(..), TcQual(..), TcStmt(..),
  23                           TcIdOcc(..), TcRecordBinds(..),
  24                           mkHsTyApp
  25                         )
  26
  27 import TcMonad
  28 import Inst             ( Inst, InstOrigin(..), OverloadedLit(..),
  29                           LIE(..), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
  30                           newMethod, newMethodWithGivenTy, newDicts )
  31 import TcBinds          ( tcBindsAndThen )
  32 import TcEnv            ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
  33                           tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars
  34                         )
  35 import TcMatches        ( tcMatchesCase, tcMatch )
  36 import TcMonoType       ( tcPolyType )
  37 import TcPat            ( tcPat )
  38 import TcSimplify       ( tcSimplifyAndCheck, tcSimplifyRank2 )
  39 import TcType           ( TcType(..), TcMaybe(..),
  40                           tcInstId, tcInstType, tcInstTheta, tcInstTcType, tcInstTyVars,
  41                           newTyVarTy, zonkTcTyVars, zonkTcType )
  42 import TcKind           ( TcKind )
  43
  44 import Class            ( Class(..), getClassSig )
  45 import FieldLabel       ( fieldLabelName )
  46 import Id               ( Id(..), GenId, idType, dataConFieldLabels, dataConSig )
  47 import Kind             ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
  48 import GenSpecEtc       ( checkSigTyVars, checkSigTyVarsGivenGlobals )
  49 import Name             ( Name{-instance Eq-} )
  50 import PrelInfo         ( intPrimTy, charPrimTy, doublePrimTy,
  51                           floatPrimTy, addrPrimTy, addrTy,
  52                           boolTy, charTy, stringTy, mkListTy,
  53                           mkTupleTy, mkPrimIoTy )
  54 import Type             ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
  55                           getTyVar_maybe, getFunTy_maybe,
  56                           splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
  57                           isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe,
  58                           getAppDataTyCon, maybeAppDataTyCon
  59                         )
  60 import TyVar            ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet )
  61 import Unify            ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
  62 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey,
  63                           enumFromClassOpKey, enumFromThenClassOpKey,
  64                           enumFromToClassOpKey, enumFromThenToClassOpKey,
  65                           monadClassKey, monadZeroClassKey )
  66
  67 --import Name           ( Name )                -- Instance
  68 import Outputable       ( interpp'SP )
  69 import PprType          ( GenType, GenTyVar )   -- Instances
  70 import Maybes           ( maybeToBool )
  71 import Pretty
  72 import Util
  73 \end{code}
  74
  75 \begin{code}
  76 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
  77 \end{code}
  78
  79 %************************************************************************
  80 %*                                                                      *
  81 \subsection{The TAUT rules for variables}
  82 %*                                                                      *
  83 %************************************************************************
  84
  85 \begin{code}
  86 tcExpr (HsVar name)
  87   = tcId name           `thenNF_Tc` \ (expr', lie, res_ty) ->
  88
  89     -- Check that the result type doesn't have any nested for-alls.
  90     -- For example, a "build" on its own is no good; it must be
  91     -- applied to something.
  92     checkTc (isTauTy res_ty)
  93             (lurkingRank2Err name res_ty) `thenTc_`
  94
  95     returnTc (expr', lie, res_ty)
  96 \end{code}
  97
  98 %************************************************************************
  99 %*                                                                      *
 100 \subsection{Literals}
 101 %*                                                                      *
 102 %************************************************************************
 103
 104 Overloaded literals.
 105
 106 \begin{code}
 107 tcExpr (HsLit (HsInt i))
 108   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 109
 110     newOverloadedLit (LiteralOrigin (HsInt i))
 111                      (OverloadedIntegral i)
 112                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 113
 114     returnTc (HsVar over_lit_id, lie, ty)
 115
 116 tcExpr (HsLit (HsFrac f))
 117   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 118
 119     newOverloadedLit (LiteralOrigin (HsFrac f))
 120                      (OverloadedFractional f)
 121                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 122
 123     returnTc (HsVar over_lit_id, lie, ty)
 124
 125 tcExpr (HsLit lit@(HsLitLit s))
 126   = tcLookupClassByKey cCallableClassKey                `thenNF_Tc` \ cCallableClass ->
 127     newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ ty ->
 128     newDicts (LitLitOrigin (_UNPK_ s))
 129              [(cCallableClass, ty)]                     `thenNF_Tc` \ (dicts, _) ->
 130     returnTc (HsLitOut lit ty, dicts, ty)
 131 \end{code}
 132
 133 Primitive literals:
 134
 135 \begin{code}
 136 tcExpr (HsLit lit@(HsCharPrim c))
 137   = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
 138
 139 tcExpr (HsLit lit@(HsStringPrim s))
 140   = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
 141
 142 tcExpr (HsLit lit@(HsIntPrim i))
 143   = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
 144
 145 tcExpr (HsLit lit@(HsFloatPrim f))
 146   = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
 147
 148 tcExpr (HsLit lit@(HsDoublePrim d))
 149   = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
 150 \end{code}
 151
 152 Unoverloaded literals:
 153
 154 \begin{code}
 155 tcExpr (HsLit lit@(HsChar c))
 156   = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
 157
 158 tcExpr (HsLit lit@(HsString str))
 159   = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
 160 \end{code}
 161
 162 %************************************************************************
 163 %*                                                                      *
 164 \subsection{Other expression forms}
 165 %*                                                                      *
 166 %************************************************************************
 167
 168 \begin{code}
 169 tcExpr (HsLam match)
 170   = tcMatch match       `thenTc` \ (match',lie,ty) ->
 171     returnTc (HsLam match', lie, ty)
 172
 173 tcExpr (HsApp e1 e2) = accum e1 [e2]
 174   where
 175     accum (HsApp e1 e2) args = accum e1 (e2:args)
 176     accum fun args
 177       = tcApp fun args  `thenTc` \ (fun', args', lie, res_ty) ->
 178         returnTc (foldl HsApp fun' args', lie, res_ty)
 179
 180 -- equivalent to (op e1) e2:
 181 tcExpr (OpApp arg1 op arg2)
 182   = tcApp op [arg1,arg2]        `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
 183     returnTc (OpApp arg1' op' arg2', lie, res_ty)
 184 \end{code}
 185
 186 Note that the operators in sections are expected to be binary, and
 187 a type error will occur if they aren't.
 188
 189 \begin{code}
 190 -- Left sections, equivalent to
 191 --      \ x -> e op x,
 192 -- or
 193 --      \ x -> op e x,
 194 -- or just
 195 --      op e
 196
 197 tcExpr in_expr@(SectionL arg op)
 198   = tcApp op [arg]              `thenTc` \ (op', [arg'], lie, res_ty) ->
 199
 200         -- Check that res_ty is a function type
 201         -- Without this check we barf in the desugarer on
 202         --      f op = (3 `op`)
 203         -- because it tries to desugar to
 204         --      f op = \r -> 3 op r
 205         -- so (3 `op`) had better be a function!
 206     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty1 ->
 207     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty2 ->
 208     tcAddErrCtxt (sectionLAppCtxt in_expr) $
 209     unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
 210
 211     returnTc (SectionL arg' op', lie, res_ty)
 212
 213 -- Right sections, equivalent to \ x -> x op expr, or
 214 --      \ x -> op x expr
 215
 216 tcExpr in_expr@(SectionR op expr)
 217   = tcExpr op                   `thenTc`    \ (op',  lie1, op_ty) ->
 218     tcExpr expr                 `thenTc`    \ (expr',lie2, expr_ty) ->
 219
 220     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty1 ->
 221     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty2 ->
 222     tcAddErrCtxt (sectionRAppCtxt in_expr) $
 223     unifyTauTy op_ty (mkFunTys [ty1, expr_ty] ty2)     `thenTc_`
 224
 225     returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
 226 \end{code}
 227
 228 The interesting thing about @ccall@ is that it is just a template
 229 which we instantiate by filling in details about the types of its
 230 argument and result (ie minimal typechecking is performed).  So, the
 231 basic story is that we allocate a load of type variables (to hold the
 232 arg/result types); unify them with the args/result; and store them for
 233 later use.
 234
 235 \begin{code}
 236 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
 237   =     -- Get the callable and returnable classes.
 238     tcLookupClassByKey cCallableClassKey        `thenNF_Tc` \ cCallableClass ->
 239     tcLookupClassByKey cReturnableClassKey      `thenNF_Tc` \ cReturnableClass ->
 240
 241     let
 242         new_arg_dict (arg, arg_ty)
 243           = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 244                      [(cCallableClass, arg_ty)]         `thenNF_Tc` \ (arg_dicts, _) ->
 245             returnNF_Tc arg_dicts       -- Actually a singleton bag
 246
 247         result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
 248     in
 249
 250         -- Arguments
 251     tcExprs args                        `thenTc` \ (args', args_lie, arg_tys) ->
 252
 253         -- The argument types can be unboxed or boxed; the result
 254         -- type must, however, be boxed since it's an argument to the PrimIO
 255         -- type constructor.
 256     newTyVarTy mkBoxedTypeKind                  `thenNF_Tc` \ result_ty ->
 257
 258         -- Construct the extra insts, which encode the
 259         -- constraints on the argument and result types.
 260     mapNF_Tc new_arg_dict (args `zip` arg_tys)                  `thenNF_Tc` \ ccarg_dicts_s ->
 261     newDicts result_origin [(cReturnableClass, result_ty)]      `thenNF_Tc` \ (ccres_dict, _) ->
 262
 263     returnTc (CCall lbl args' may_gc is_asm result_ty,
 264               foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
 265               mkPrimIoTy result_ty)
 266 \end{code}
 267
 268 \begin{code}
 269 tcExpr (HsSCC label expr)
 270   = tcExpr expr         `thenTc` \ (expr', lie, expr_ty) ->
 271          -- No unification. Give SCC the type of expr
 272     returnTc (HsSCC label expr', lie, expr_ty)
 273
 274 tcExpr (HsLet binds expr)
 275   = tcBindsAndThen
 276         HsLet                   -- The combiner
 277         binds                   -- Bindings to check
 278         (tcExpr expr)           -- Typechecker for the expression
 279
 280 tcExpr in_expr@(HsCase expr matches src_loc)
 281   = tcAddSrcLoc src_loc $
 282     tcExpr expr                 `thenTc`    \ (expr',lie1,expr_ty) ->
 283     newTyVarTy mkTypeKind       `thenNF_Tc` \ result_ty ->
 284
 285     tcAddErrCtxt (caseCtxt in_expr) $
 286     tcMatchesCase (mkFunTy expr_ty result_ty) matches
 287                                 `thenTc`    \ (matches',lie2) ->
 288
 289     returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
 290
 291 tcExpr (HsIf pred b1 b2 src_loc)
 292   = tcAddSrcLoc src_loc $
 293     tcExpr pred                 `thenTc`    \ (pred',lie1,predTy) ->
 294
 295     tcAddErrCtxt (predCtxt pred) (
 296       unifyTauTy predTy boolTy
 297     )                           `thenTc_`
 298
 299     tcExpr b1                   `thenTc`    \ (b1',lie2,result_ty) ->
 300     tcExpr b2                   `thenTc`    \ (b2',lie3,b2Ty) ->
 301
 302     tcAddErrCtxt (branchCtxt b1 b2) $
 303     unifyTauTy result_ty b2Ty                           `thenTc_`
 304
 305     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
 306
 307 tcExpr (ListComp expr quals)
 308   = tcListComp expr quals       `thenTc` \ ((expr',quals'), lie, ty) ->
 309     returnTc (ListComp expr' quals', lie, ty)
 310 \end{code}
 311
 312 \begin{code}
 313 tcExpr (HsDo stmts src_loc)
 314   =     -- get the Monad and MonadZero classes
 315         -- create type consisting of a fresh monad tyvar
 316     tcAddSrcLoc src_loc $
 317     newTyVarTy monadKind        `thenNF_Tc` \ m ->
 318     tcDoStmts False m stmts     `thenTc` \ ((stmts',monad,mzero), lie, do_ty) ->
 319
 320         -- create dictionaries for monad and possibly monadzero
 321     (if monad then
 322         tcLookupClassByKey monadClassKey                `thenNF_Tc` \ monadClass ->
 323         newDicts DoOrigin [(monadClass, m)]
 324     else
 325         returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
 326     )                                           `thenNF_Tc` \ (m_lie,  [m_id])  ->
 327     (if mzero then
 328         tcLookupClassByKey monadZeroClassKey    `thenNF_Tc` \ monadZeroClass ->
 329         newDicts DoOrigin [(monadZeroClass, m)]
 330      else
 331         returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"])
 332     )                                           `thenNF_Tc` \ (mz_lie, [mz_id]) ->
 333
 334     returnTc (HsDoOut stmts' m_id mz_id src_loc,
 335               lie `plusLIE` m_lie `plusLIE` mz_lie,
 336               do_ty)
 337   where
 338     monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind
 339 \end{code}
 340
 341 \begin{code}
 342 tcExpr (ExplicitList [])
 343   = newTyVarTy mkBoxedTypeKind          `thenNF_Tc` \ tyvar_ty ->
 344     returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
 345
 346
 347 tcExpr in_expr@(ExplicitList exprs)     -- Non-empty list
 348   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
 349     tcAddErrCtxt (listCtxt in_expr) $
 350     unifyTauTyList tys                  `thenTc_`
 351     returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
 352
 353 tcExpr (ExplicitTuple exprs)
 354   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys) ->
 355     returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
 356
 357 tcExpr (RecordCon (HsVar con) rbinds)
 358   = tcId con                            `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 359     let
 360         (_, record_ty)       = splitFunTy con_tau
 361     in
 362         -- Con is syntactically constrained to be a data constructor
 363     ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
 364
 365     tcRecordBinds record_ty rbinds              `thenTc` \ (rbinds', rbinds_lie) ->
 366
 367         -- Check that the record bindings match the constructor
 368     tcLookupGlobalValue con                     `thenNF_Tc` \ con_id ->
 369     checkTc (checkRecordFields rbinds con_id)
 370             (badFieldsCon con rbinds)           `thenTc_`
 371
 372     returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
 373
 374 -- One small complication in RecordUpd is that we have to generate some
 375 -- dictionaries for the data type context, since we are going to
 376 -- do some construction.
 377 --
 378 -- What dictionaries do we need?  For the moment we assume that all
 379 -- data constructors have the same context, and grab it from the first
 380 -- constructor.  If they have varying contexts then we'd have to
 381 -- union the ones that could participate in the update.
 382
 383 tcExpr (RecordUpd record_expr rbinds)
 384   = ASSERT( not (null rbinds) )
 385     tcAddErrCtxt recordUpdCtxt                  $
 386
 387     tcExpr record_expr                  `thenTc` \ (record_expr', record_lie, record_ty) ->
 388     tcRecordBinds record_ty rbinds      `thenTc` \ (rbinds', rbinds_lie) ->
 389
 390         -- Check that the field names are plausible
 391     zonkTcType record_ty                `thenNF_Tc` \ record_ty' ->
 392     let
 393         (tycon, inst_tys, data_cons) = getAppDataTyCon record_ty'
 394         -- The record binds are non-empty (syntax); so at least one field
 395         -- label will have been unified with record_ty by tcRecordBinds;
 396         -- field labels must be of data type; hencd the getAppDataTyCon must succeed.
 397         (tyvars, theta, _, _) = dataConSig (head data_cons)
 398     in
 399     tcInstTheta (tyvars `zipEqual` inst_tys) theta      `thenNF_Tc` \ theta' ->
 400     newDicts RecordUpdOrigin theta'                     `thenNF_Tc` \ (con_lie, dicts) ->
 401     checkTc (any (checkRecordFields rbinds) data_cons)
 402             (badFieldsUpd rbinds)               `thenTc_`
 403
 404     returnTc (RecordUpdOut record_expr' dicts rbinds',
 405               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
 406               record_ty)
 407
 408 tcExpr (ArithSeqIn seq@(From expr))
 409   = tcExpr expr                                 `thenTc`    \ (expr', lie1, ty) ->
 410
 411     tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
 412     newMethod (ArithSeqOrigin seq)
 413               (RealId sel_id) [ty]              `thenNF_Tc` \ (lie2, enum_from_id) ->
 414
 415     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 416               lie1 `plusLIE` lie2,
 417               mkListTy ty)
 418
 419 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
 420   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 421     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 422
 423     tcAddErrCtxt (arithSeqCtxt in_expr) $
 424     unifyTauTyList [ty1, ty2]                           `thenTc_`
 425
 426     tcLookupGlobalValueByKey enumFromThenClassOpKey     `thenNF_Tc` \ sel_id ->
 427     newMethod (ArithSeqOrigin seq)
 428               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 429
 430     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 431                            (FromThen expr1' expr2'),
 432               lie1 `plusLIE` lie2 `plusLIE` lie3,
 433               mkListTy ty1)
 434
 435 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
 436   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 437     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 438
 439     tcAddErrCtxt (arithSeqCtxt in_expr) $
 440     unifyTauTyList [ty1,ty2]    `thenTc_`
 441
 442     tcLookupGlobalValueByKey enumFromToClassOpKey       `thenNF_Tc` \ sel_id ->
 443     newMethod (ArithSeqOrigin seq)
 444               (RealId sel_id) [ty1]             `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 445
 446     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 447                           (FromTo expr1' expr2'),
 448               lie1 `plusLIE` lie2 `plusLIE` lie3,
 449                mkListTy ty1)
 450
 451 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
 452   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 453     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 454     tcExpr expr3                `thenTc`    \ (expr3',lie3,ty3) ->
 455
 456     tcAddErrCtxt  (arithSeqCtxt in_expr) $
 457     unifyTauTyList [ty1,ty2,ty3]                        `thenTc_`
 458
 459     tcLookupGlobalValueByKey enumFromThenToClassOpKey   `thenNF_Tc` \ sel_id ->
 460     newMethod (ArithSeqOrigin seq)
 461               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie4, eft_id) ->
 462
 463     returnTc (ArithSeqOut (HsVar eft_id)
 464                            (FromThenTo expr1' expr2' expr3'),
 465               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
 466               mkListTy ty1)
 467 \end{code}
 468
 469 %************************************************************************
 470 %*                                                                      *
 471 \subsection{Expressions type signatures}
 472 %*                                                                      *
 473 %************************************************************************
 474
 475 \begin{code}
 476 tcExpr in_expr@(ExprWithTySig expr poly_ty)
 477  = tcExpr expr                  `thenTc` \ (texpr, lie, tau_ty) ->
 478    tcPolyType  poly_ty          `thenTc` \ sigma_sig ->
 479
 480         -- Check the tau-type part
 481    tcSetErrCtxt (exprSigCtxt in_expr)   $
 482    tcInstType [] sigma_sig              `thenNF_Tc` \ sigma_sig' ->
 483    let
 484         (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
 485    in
 486    unifyTauTy tau_ty sig_tau'           `thenTc_`
 487
 488         -- Check the type variables of the signature
 489    checkSigTyVars sig_tyvars' sig_tau'  `thenTc_`
 490
 491         -- Check overloading constraints
 492    newDicts SignatureOrigin sig_theta'          `thenNF_Tc` \ (sig_dicts, _) ->
 493    tcSimplifyAndCheck
 494         (mkTyVarSet sig_tyvars')
 495         sig_dicts lie                           `thenTc_`
 496
 497         -- If everything is ok, return the stuff unchanged, except for
 498         -- the effect of any substutions etc.  We simply discard the
 499         -- result of the tcSimplifyAndCheck, except for any default
 500         -- resolution it may have done, which is recorded in the
 501         -- substitution.
 502    returnTc (texpr, lie, tau_ty)
 503 \end{code}
 504
 505 %************************************************************************
 506 %*                                                                      *
 507 \subsection{@tcApp@ typchecks an application}
 508 %*                                                                      *
 509 %************************************************************************
 510
 511 \begin{code}
 512 tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
 513       -> TcM s (TcExpr s, [TcExpr s],       -- Translated fun and args
 514                 LIE s,
 515                 TcType s)                   -- Type of the application
 516
 517 tcApp fun args
 518   =     -- First type-check the function
 519         -- In the HsVar case we go straight to tcId to avoid hitting the
 520         -- rank-2 check, which we check later here anyway
 521     (case fun of
 522         HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
 523         other      -> tcExpr fun
 524     )                                   `thenTc` \ (fun', lie_fun, fun_ty) ->
 525
 526     tcApp_help fun 1 fun_ty args        `thenTc` \ (args', lie_args, res_ty) ->
 527
 528     -- Check that the result type doesn't have any nested for-alls.
 529     -- For example, a "build" on its own is no good; it must be applied to something.
 530     checkTc (isTauTy res_ty)
 531             (lurkingRank2Err fun fun_ty) `thenTc_`
 532
 533     returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
 534
 535
 536 tcApp_help :: RenamedHsExpr -> Int      -- Function and arg position, used in error message(s)
 537            -> TcType s                  -- The type of the function
 538            -> [RenamedHsExpr]           -- Arguments
 539            -> TcM s ([TcExpr s],                -- Typechecked args
 540                      LIE s,
 541                      TcType s)          -- Result type of the application
 542
 543 tcApp_help orig_fun arg_no fun_ty []
 544   = returnTc ([], emptyLIE, fun_ty)
 545
 546 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
 547   =     -- Expect the function to have type A->B
 548     tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
 549             unifyFunTy fun_ty
 550     )                                                   `thenTc` \ (expected_arg_ty, result_ty) ->
 551
 552         -- Type check the argument
 553     tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
 554                 tcArg expected_arg_ty arg
 555     )                                                   `thenTc` \ (arg', lie_arg) ->
 556
 557         -- Do the other args
 558     tcApp_help orig_fun (arg_no+1) result_ty args       `thenTc` \ (args', lie_args, res_ty) ->
 559
 560         -- Done
 561     returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
 562
 563 \end{code}
 564
 565 \begin{code}
 566 tcArg :: TcType s                       -- Expected arg type
 567       -> RenamedHsExpr                  -- Actual argument
 568       -> TcM s (TcExpr s, LIE s)        -- Resulting argument and LIE
 569
 570 tcArg expected_arg_ty arg
 571   | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
 572   =     -- The ordinary, non-rank-2 polymorphic case
 573     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 574     unifyTauTy expected_arg_ty actual_arg_ty    `thenTc_`
 575     returnTc (arg', lie_arg)
 576
 577   | otherwise
 578   =     -- Ha!  The argument type of the function is a for-all type,
 579         -- An example of rank-2 polymorphism.
 580
 581         -- No need to instantiate the argument type... it's must be the result
 582         -- of instantiating a function involving rank-2 polymorphism, so there
 583         -- isn't any danger of using the same tyvars twice
 584         -- The argument type shouldn't be overloaded type (hence ASSERT)
 585     let
 586         (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty
 587     in
 588     ASSERT( null expected_theta )       -- And expected_tyvars are all DontBind things
 589
 590         -- Type-check the arg and unify with expected type
 591     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 592     unifyTauTy expected_tau actual_arg_ty       `thenTc_`  (
 593
 594         -- Check that the arg_tyvars havn't been constrained
 595         -- The interesting bit here is that we must include the free variables
 596         -- of the expected arg ty.  Here's an example:
 597         --       runST (newVar True)
 598         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 599         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 600         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 601         -- So now s' isn't unconstrained because it's linked to a.
 602         -- Conclusion: include the free vars of the expected arg type in the
 603         -- list of "free vars" for the signature check.
 604     tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
 605     tcGetGlobalTyVars                                           `thenNF_Tc` \ env_tyvars ->
 606     zonkTcTyVars (tyVarsOfType expected_arg_ty)                 `thenNF_Tc` \ free_tyvars ->
 607     checkSigTyVarsGivenGlobals
 608         (env_tyvars `unionTyVarSets` free_tyvars)
 609         expected_tyvars expected_tau                            `thenTc_`
 610
 611         -- Check that there's no overloading involved
 612         -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
 613         -- but which, on simplification, don't actually need a dictionary involving
 614         -- the tyvar.  So we have to do a proper simplification right here.
 615     tcSimplifyRank2 (mkTyVarSet expected_tyvars)
 616                     lie_arg                             `thenTc` \ (free_insts, inst_binds) ->
 617
 618         -- This HsLet binds any Insts which came out of the simplification.
 619         -- It's a bit out of place here, but using AbsBind involves inventing
 620         -- a couple of new names which seems worse.
 621     returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
 622     )
 623   where
 624
 625     mk_binds []
 626         = EmptyBinds
 627     mk_binds ((inst,rhs):inst_binds)
 628         = (SingleBind (NonRecBind (VarMonoBind inst rhs)))
 629                 `ThenBinds`
 630           mk_binds inst_binds
 631 \end{code}
 632
 633 %************************************************************************
 634 %*                                                                      *
 635 \subsection{@tcId@ typchecks an identifier occurrence}
 636 %*                                                                      *
 637 %************************************************************************
 638
 639 \begin{code}
 640 tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
 641
 642 tcId name
 643   =     -- Look up the Id and instantiate its type
 644     tcLookupLocalValue name     `thenNF_Tc` \ maybe_local ->
 645
 646     (case maybe_local of
 647         Just tc_id -> let
 648                         (tyvars, rho) = splitForAllTy (idType tc_id)
 649                       in
 650                       tcInstTyVars tyvars               `thenNF_Tc` \ (tyvars', arg_tys', tenv)  ->
 651                       tcInstTcType tenv rho             `thenNF_Tc` \ rho' ->
 652                       returnNF_Tc (TcId tc_id, arg_tys', rho')
 653
 654         Nothing ->    tcLookupGlobalValue name  `thenNF_Tc` \ id ->
 655                       let
 656                         (tyvars, rho) = splitForAllTy (idType id)
 657                       in
 658                       tcInstTyVars tyvars               `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
 659                       tcInstType tenv rho               `thenNF_Tc` \ rho' ->
 660                       returnNF_Tc (RealId id, arg_tys, rho')
 661
 662     )                                   `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) ->
 663
 664         -- Is it overloaded?
 665     case splitRhoTy rho of
 666       ([], tau)    ->   -- Not overloaded, so just make a type application
 667                         returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 668
 669       (theta, tau) ->   -- Overloaded, so make a Method inst
 670                         newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 671                                 tc_id_occ arg_tys rho           `thenNF_Tc` \ (lie, meth_id) ->
 672                         returnNF_Tc (HsVar meth_id, lie, tau)
 673 \end{code}
 674
 675
 676
 677 %************************************************************************
 678 %*                                                                      *
 679 \subsection{@tcQuals@ typchecks list comprehension qualifiers}
 680 %*                                                                      *
 681 %************************************************************************
 682
 683 \begin{code}
 684 tcListComp expr []
 685   = tcExpr expr         `thenTc` \ (expr', lie, ty) ->
 686     returnTc ((expr',[]), lie, mkListTy ty)
 687
 688 tcListComp expr (qual@(FilterQual filter) : quals)
 689   = tcAddErrCtxt (qualCtxt qual) (
 690         tcExpr filter                   `thenTc` \ (filter', filter_lie, filter_ty) ->
 691         unifyTauTy boolTy filter_ty     `thenTc_`
 692         returnTc (FilterQual filter', filter_lie)
 693     )                                   `thenTc` \ (qual', qual_lie) ->
 694
 695     tcListComp expr quals       `thenTc` \ ((expr',quals'), rest_lie, res_ty) ->
 696
 697     returnTc ((expr', qual' : quals'),
 698               qual_lie `plusLIE` rest_lie,
 699               res_ty)
 700
 701 tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
 702   = newMonoIds binder_names mkBoxedTypeKind (\ ids ->
 703
 704       tcAddErrCtxt (qualCtxt qual) (
 705         tcPat pat                               `thenTc` \ (pat',  lie_pat,  pat_ty)  ->
 706         tcExpr rhs                              `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
 707         unifyTauTy (mkListTy pat_ty) rhs_ty     `thenTc_`
 708         returnTc (GeneratorQual pat' rhs',
 709                   lie_pat `plusLIE` lie_rhs)
 710       )                                         `thenTc` \ (qual', lie_qual) ->
 711
 712       tcListComp expr quals                     `thenTc` \ ((expr',quals'), lie_rest, res_ty) ->
 713
 714       returnTc ((expr', qual' : quals'),
 715                 lie_qual `plusLIE` lie_rest,
 716                 res_ty)
 717     )
 718   where
 719     binder_names = collectPatBinders pat
 720
 721 tcListComp expr (LetQual binds : quals)
 722   = tcBindsAndThen              -- No error context, but a binding group is
 723         combine                 -- rather a large thing for an error context anyway
 724         binds
 725         (tcListComp expr quals)
 726   where
 727     combine binds' (expr',quals') = (expr', LetQual binds' : quals')
 728 \end{code}
 729
 730
 731 %************************************************************************
 732 %*                                                                      *
 733 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 734 %*                                                                      *
 735 %************************************************************************
 736
 737 \begin{code}
 738 tcDoStmts :: Bool                       -- True => require a monad
 739           -> TcType s                   -- m
 740           -> [RenamedStmt]
 741           -> TcM s (([TcStmt s],
 742                      Bool,              -- True => Monad
 743                      Bool),             -- True => MonadZero
 744                     LIE s,
 745                     TcType s)
 746
 747 tcDoStmts monad m [stmt@(ExprStmt exp src_loc)]
 748   = tcAddSrcLoc src_loc $
 749     tcSetErrCtxt (stmtCtxt stmt) $
 750     tcExpr exp                          `thenTc`    \ (exp', exp_lie, exp_ty) ->
 751     (if monad then
 752         newTyVarTy mkTypeKind           `thenNF_Tc` \ a ->
 753         unifyTauTy (mkAppTy m a) exp_ty
 754      else
 755         returnTc ()
 756     )                                   `thenTc_`
 757     returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty)
 758
 759 tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts)
 760   = tcAddSrcLoc src_loc                 (
 761     tcSetErrCtxt (stmtCtxt stmt)        (
 762         tcExpr exp                      `thenTc`    \ (exp', exp_lie, exp_ty) ->
 763         newTyVarTy mkTypeKind           `thenNF_Tc` \ a ->
 764         unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
 765         returnTc (ExprStmt exp' src_loc, exp_lie)
 766     ))                                  `thenTc` \ (stmt',  stmt_lie) ->
 767     tcDoStmts True m stmts              `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
 768     returnTc ((stmt':stmts', True, mzero),
 769               stmt_lie `plusLIE` stmts_lie,
 770               stmts_ty)
 771
 772 tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts)
 773   = tcAddSrcLoc src_loc                 (
 774     tcSetErrCtxt (stmtCtxt stmt)        (
 775         tcPat pat                       `thenTc`    \ (pat', pat_lie, pat_ty) ->
 776         tcExpr exp                      `thenTc`    \ (exp', exp_lie, exp_ty) ->
 777         newTyVarTy mkTypeKind           `thenNF_Tc` \ a ->
 778         unifyTauTy a pat_ty             `thenTc_`
 779         unifyTauTy (mkAppTy m a) exp_ty `thenTc_`
 780         returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat')
 781     ))                                  `thenTc` \ (stmt', stmt_lie, failure_free) ->
 782     tcDoStmts True m stmts              `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) ->
 783     returnTc ((stmt':stmts', True, mzero || not failure_free),
 784               stmt_lie `plusLIE` stmts_lie,
 785               stmts_ty)
 786
 787 tcDoStmts monad m (LetStmt binds : stmts)
 788    = tcBindsAndThen             -- No error context, but a binding group is
 789         combine                 -- rather a large thing for an error context anyway
 790         binds
 791         (tcDoStmts monad m stmts)
 792    where
 793      combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero)
 794
 795 \end{code}
 796
 797 Game plan for record bindings
 798 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 799 For each binding
 800         field = value
 801 1. look up "field", to find its selector Id, which must have type
 802         forall a1..an. T a1 .. an -> tau
 803    where tau is the type of the field.
 804
 805 2. Instantiate this type
 806
 807 3. Unify the (T a1 .. an) part with the "expected result type", which
 808    is passed in.  This checks that all the field labels come from the
 809    same type.
 810
 811 4. Type check the value using tcArg, passing tau as the expected
 812    argument type.
 813
 814 This extends OK when the field types are universally quantified.
 815
 816 Actually, to save excessive creation of fresh type variables,
 817 we
 818
 819 \begin{code}
 820 tcRecordBinds
 821         :: TcType s             -- Expected type of whole record
 822         -> RenamedRecordBinds
 823         -> TcM s (TcRecordBinds s, LIE s)
 824
 825 tcRecordBinds expected_record_ty rbinds
 826   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 827     returnTc (rbinds', plusLIEs lies)
 828   where
 829     do_bind (field_label, rhs, pun_flag)
 830       = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
 831         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 832
 833                 -- Record selectors all have type
 834                 --      forall a1..an.  T a1 .. an -> tau
 835         ASSERT( maybeToBool (getFunTy_maybe tau) )
 836         let
 837                 -- Selector must have type RecordType -> FieldType
 838           Just (record_ty, field_ty) = getFunTy_maybe tau
 839         in
 840         unifyTauTy expected_record_ty record_ty         `thenTc_`
 841         tcArg field_ty rhs                              `thenTc` \ (rhs', lie) ->
 842         returnTc ((RealId sel_id, rhs', pun_flag), lie)
 843
 844 checkRecordFields :: RenamedRecordBinds -> Id -> Bool   -- True iff all the fields in
 845                                                         -- RecordBinds are field of the
 846                                                         -- specified constructor
 847 checkRecordFields rbinds data_con
 848   = all ok rbinds
 849   where
 850     data_con_fields = dataConFieldLabels data_con
 851
 852     ok (field_name, _, _) = any (match (getName field_name)) data_con_fields
 853
 854     match field_name field_label = field_name == fieldLabelName field_label
 855 \end{code}
 856
 857 %************************************************************************
 858 %*                                                                      *
 859 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
 860 %*                                                                      *
 861 %************************************************************************
 862
 863 \begin{code}
 864 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
 865
 866 tcExprs [] = returnTc ([], emptyLIE, [])
 867 tcExprs (expr:exprs)
 868  = tcExpr  expr                 `thenTc` \ (expr',  lie1, ty) ->
 869    tcExprs exprs                `thenTc` \ (exprs', lie2, tys) ->
 870    returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
 871 \end{code}
 872
 873
 874 % =================================================
 875
 876 Errors and contexts
 877 ~~~~~~~~~~~~~~~~~~~
 878
 879 Mini-utils:
 880 \begin{code}
 881 pp_nest_hang :: String -> Pretty -> Pretty
 882 pp_nest_hang label stuff = ppNest 2 (ppHang (ppStr label) 4 stuff)
 883 \end{code}
 884
 885 Boring and alphabetical:
 886 \begin{code}
 887 arithSeqCtxt expr sty
 888   = ppHang (ppStr "In an arithmetic sequence:") 4 (ppr sty expr)
 889
 890 branchCtxt b1 b2 sty
 891   = ppSep [ppStr "In the branches of a conditional:",
 892            pp_nest_hang "`then' branch:" (ppr sty b1),
 893            pp_nest_hang "`else' branch:" (ppr sty b2)]
 894
 895 caseCtxt expr sty
 896   = ppHang (ppStr "In a case expression:") 4 (ppr sty expr)
 897
 898 exprSigCtxt expr sty
 899   = ppHang (ppStr "In an expression with a type signature:")
 900          4 (ppr sty expr)
 901
 902 listCtxt expr sty
 903   = ppHang (ppStr "In a list expression:") 4 (ppr sty expr)
 904
 905 predCtxt expr sty
 906   = ppHang (ppStr "In a predicate expression:") 4 (ppr sty expr)
 907
 908 sectionRAppCtxt expr sty
 909   = ppHang (ppStr "In a right section:") 4 (ppr sty expr)
 910
 911 sectionLAppCtxt expr sty
 912   = ppHang (ppStr "In a left section:") 4 (ppr sty expr)
 913
 914 funAppCtxt fun arg_no arg sty
 915   = ppHang (ppCat [ ppStr "In the", speakNth arg_no, ppStr "argument of", ppr sty fun])
 916          4 (ppCat [ppStr "namely", ppr sty arg])
 917
 918 qualCtxt qual sty
 919   = ppHang (ppStr "In a list-comprehension qualifer:")
 920          4 (ppr sty qual)
 921
 922 stmtCtxt stmt sty
 923   = ppHang (ppStr "In a do statement:")
 924          4 (ppr sty stmt)
 925
 926 tooManyArgsCtxt f sty
 927   = ppHang (ppStr "Too many arguments in an application of the function")
 928          4 (ppr sty f)
 929
 930 lurkingRank2Err fun fun_ty sty
 931   = ppHang (ppCat [ppStr "Illegal use of", ppr sty fun])
 932          4 (ppAboves [ppStr "It is applied to too few arguments,",
 933                       ppStr "so that the result type has for-alls in it"])
 934
 935 rank2ArgCtxt arg expected_arg_ty sty
 936   = ppHang (ppStr "In a polymorphic function argument:")
 937          4 (ppSep [ppBeside (ppr sty arg) (ppStr " ::"),
 938                    ppr sty expected_arg_ty])
 939
 940 badFieldsUpd rbinds sty
 941   = ppHang (ppStr "No constructor has all these fields:")
 942          4 (interpp'SP sty fields)
 943   where
 944     fields = [field | (field, _, _) <- rbinds]
 945
 946 recordUpdCtxt sty = ppStr "In a record update construct"
 947
 948 badFieldsCon con rbinds sty
 949   = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con])
 950          4 (ppBesides [ppStr "and fields:", interpp'SP sty fields])
 951   where
 952     fields = [field | (field, _, _) <- rbinds]
 953 \end{code}