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