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