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