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, tcStmt, tcId ) where
  10
  11 IMP_Ubiq()
  12
  13 import HsSyn            ( HsExpr(..), Stmt(..), DoOrListComp(..),
  14                           HsBinds(..),  MonoBinds(..),
  15                           SYN_IE(RecFlag), nonRecursive,
  16                           ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
  17                           Match, Fake, InPat, OutPat, HsType, Fixity,
  18                           pprParendExpr, failureFreePat, collectPatBinders )
  19 import RnHsSyn          ( SYN_IE(RenamedHsExpr),
  20                           SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds)
  21                         )
  22 import TcHsSyn          ( SYN_IE(TcExpr), SYN_IE(TcStmt),
  23                           TcIdOcc(..), SYN_IE(TcRecordBinds),
  24                           mkHsTyApp
  25                         )
  26
  27 import TcMonad
  28 import Inst             ( Inst, InstOrigin(..), OverloadedLit(..),
  29                           SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
  30                           newMethod, newMethodWithGivenTy, newDicts )
  31 import TcBinds          ( tcBindsAndThen, checkSigTyVars )
  32 import TcEnv            ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey,
  33                           tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars,
  34                           tcExtendGlobalTyVars, tcLookupGlobalValueMaybe
  35                         )
  36 import SpecEnv          ( SpecEnv )
  37 import TcMatches        ( tcMatchesCase, tcMatch )
  38 import TcMonoType       ( tcHsType )
  39 import TcPat            ( tcPat )
  40 import TcSimplify       ( tcSimplifyAndCheck, tcSimplifyRank2 )
  41 import TcType           ( SYN_IE(TcType), TcMaybe(..),
  42                           tcInstId, tcInstType, tcInstSigTcType, tcInstTyVars,
  43                           tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy,
  44                           newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
  45 import TcKind           ( TcKind )
  46
  47 import Class            ( SYN_IE(Class), classSig )
  48 import FieldLabel       ( fieldLabelName, fieldLabelType )
  49 import Id               ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
  50                           isRecordSelector,
  51                           SYN_IE(Id), GenId
  52                         )
  53 import FieldLabel       ( FieldLabel )
  54 import Kind             ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
  55 import Name             ( Name{-instance Eq-} )
  56 import Type             ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
  57                           getTyVar_maybe, getFunTy_maybe, instantiateTy, applyTyCon,
  58                           splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
  59                           isTauTy, mkFunTys, tyVarsOfType, tyVarsOfTypes, getForAllTy_maybe,
  60                           getAppDataTyCon, maybeAppDataTyCon
  61                         )
  62 import TyVar            ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, elementOfTyVarSet, mkTyVarSet )
  63 import TysPrim          ( intPrimTy, charPrimTy, doublePrimTy,
  64                           floatPrimTy, addrPrimTy, realWorldTy
  65                         )
  66 import TysWiredIn       ( addrTy,
  67                           boolTy, charTy, stringTy, mkListTy,
  68                           mkTupleTy, mkPrimIoTy, stDataCon
  69                         )
  70 import Unify            ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
  71 import Unique           ( Unique, cCallableClassKey, cReturnableClassKey,
  72                           enumFromClassOpKey, enumFromThenClassOpKey,
  73                           enumFromToClassOpKey, enumFromThenToClassOpKey,
  74                           thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
  75                         )
  76 import Outputable       ( speakNth, interpp'SP, Outputable(..) )
  77 import PprType          ( GenType, GenTyVar )   -- Instances
  78 import Maybes           ( maybeToBool )
  79 import Pretty
  80 import ListSetOps       ( minusList )
  81 import Util
  82 \end{code}
  83
  84 \begin{code}
  85 tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
  86 \end{code}
  87
  88 %************************************************************************
  89 %*                                                                      *
  90 \subsection{The TAUT rules for variables}
  91 %*                                                                      *
  92 %************************************************************************
  93
  94 \begin{code}
  95 tcExpr (HsVar name)
  96   = tcId name           `thenNF_Tc` \ (expr', lie, res_ty) ->
  97
  98     -- Check that the result type doesn't have any nested for-alls.
  99     -- For example, a "build" on its own is no good; it must be
 100     -- applied to something.
 101     checkTc (isTauTy res_ty)
 102             (lurkingRank2Err name res_ty) `thenTc_`
 103
 104     returnTc (expr', lie, res_ty)
 105 \end{code}
 106
 107 %************************************************************************
 108 %*                                                                      *
 109 \subsection{Literals}
 110 %*                                                                      *
 111 %************************************************************************
 112
 113 Overloaded literals.
 114
 115 \begin{code}
 116 tcExpr (HsLit (HsInt i))
 117   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 118
 119     newOverloadedLit (LiteralOrigin (HsInt i))
 120                      (OverloadedIntegral i)
 121                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 122
 123     returnTc (HsVar over_lit_id, lie, ty)
 124
 125 tcExpr (HsLit (HsFrac f))
 126   = newTyVarTy mkBoxedTypeKind  `thenNF_Tc` \ ty ->
 127
 128     newOverloadedLit (LiteralOrigin (HsFrac f))
 129                      (OverloadedFractional f)
 130                      ty                                 `thenNF_Tc` \ (lie, over_lit_id) ->
 131
 132     returnTc (HsVar over_lit_id, lie, ty)
 133
 134 tcExpr (HsLit lit@(HsLitLit s))
 135   = tcLookupClassByKey cCallableClassKey                `thenNF_Tc` \ cCallableClass ->
 136     newTyVarTy mkBoxedTypeKind                          `thenNF_Tc` \ ty ->
 137     newDicts (LitLitOrigin (_UNPK_ s))
 138              [(cCallableClass, ty)]                     `thenNF_Tc` \ (dicts, _) ->
 139     returnTc (HsLitOut lit ty, dicts, ty)
 140 \end{code}
 141
 142 Primitive literals:
 143
 144 \begin{code}
 145 tcExpr (HsLit lit@(HsCharPrim c))
 146   = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
 147
 148 tcExpr (HsLit lit@(HsStringPrim s))
 149   = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
 150
 151 tcExpr (HsLit lit@(HsIntPrim i))
 152   = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
 153
 154 tcExpr (HsLit lit@(HsFloatPrim f))
 155   = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
 156
 157 tcExpr (HsLit lit@(HsDoublePrim d))
 158   = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
 159 \end{code}
 160
 161 Unoverloaded literals:
 162
 163 \begin{code}
 164 tcExpr (HsLit lit@(HsChar c))
 165   = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
 166
 167 tcExpr (HsLit lit@(HsString str))
 168   = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
 169 \end{code}
 170
 171 %************************************************************************
 172 %*                                                                      *
 173 \subsection{Other expression forms}
 174 %*                                                                      *
 175 %************************************************************************
 176
 177 \begin{code}
 178 tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
 179   = tcExpr expr
 180
 181 tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
 182
 183 tcExpr (HsLam match)
 184   = tcMatch match       `thenTc` \ (match',lie,ty) ->
 185     returnTc (HsLam match', lie, ty)
 186
 187 tcExpr (HsApp e1 e2) = accum e1 [e2]
 188   where
 189     accum (HsApp e1 e2) args = accum e1 (e2:args)
 190     accum fun args
 191       = tcApp fun args  `thenTc` \ (fun', args', lie, res_ty) ->
 192         returnTc (foldl HsApp fun' args', lie, res_ty)
 193
 194 -- equivalent to (op e1) e2:
 195 tcExpr (OpApp arg1 op fix arg2)
 196   = tcApp op [arg1,arg2]        `thenTc` \ (op', [arg1', arg2'], lie, res_ty) ->
 197     returnTc (OpApp arg1' op' fix arg2', lie, res_ty)
 198 \end{code}
 199
 200 Note that the operators in sections are expected to be binary, and
 201 a type error will occur if they aren't.
 202
 203 \begin{code}
 204 -- Left sections, equivalent to
 205 --      \ x -> e op x,
 206 -- or
 207 --      \ x -> op e x,
 208 -- or just
 209 --      op e
 210
 211 tcExpr in_expr@(SectionL arg op)
 212   = tcApp op [arg]              `thenTc` \ (op', [arg'], lie, res_ty) ->
 213
 214         -- Check that res_ty is a function type
 215         -- Without this check we barf in the desugarer on
 216         --      f op = (3 `op`)
 217         -- because it tries to desugar to
 218         --      f op = \r -> 3 op r
 219         -- so (3 `op`) had better be a function!
 220     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty1 ->
 221     newTyVarTy mkTypeKind               `thenNF_Tc` \ ty2 ->
 222     tcAddErrCtxt (sectionLAppCtxt in_expr) $
 223     unifyTauTy (mkFunTy ty1 ty2) res_ty `thenTc_`
 224
 225     returnTc (SectionL arg' op', lie, res_ty)
 226
 227 -- Right sections, equivalent to \ x -> x op expr, or
 228 --      \ x -> op x expr
 229
 230 tcExpr in_expr@(SectionR op expr)
 231   = tcExpr op                   `thenTc`    \ (op',  lie1, op_ty) ->
 232     tcExpr expr                 `thenTc`    \ (expr',lie2, expr_ty) ->
 233
 234     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty1 ->
 235     newTyVarTy mkTypeKind       `thenNF_Tc` \ ty2 ->
 236     tcAddErrCtxt (sectionRAppCtxt in_expr) $
 237     unifyTauTy (mkFunTys [ty1, expr_ty] ty2) op_ty      `thenTc_`
 238
 239     returnTc (SectionR op' expr', lie1 `plusLIE` lie2, mkFunTy ty1 ty2)
 240 \end{code}
 241
 242 The interesting thing about @ccall@ is that it is just a template
 243 which we instantiate by filling in details about the types of its
 244 argument and result (ie minimal typechecking is performed).  So, the
 245 basic story is that we allocate a load of type variables (to hold the
 246 arg/result types); unify them with the args/result; and store them for
 247 later use.
 248
 249 \begin{code}
 250 tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
 251   =     -- Get the callable and returnable classes.
 252     tcLookupClassByKey cCallableClassKey        `thenNF_Tc` \ cCallableClass ->
 253     tcLookupClassByKey cReturnableClassKey      `thenNF_Tc` \ cReturnableClass ->
 254
 255     let
 256         new_arg_dict (arg, arg_ty)
 257           = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
 258                      [(cCallableClass, arg_ty)]         `thenNF_Tc` \ (arg_dicts, _) ->
 259             returnNF_Tc arg_dicts       -- Actually a singleton bag
 260
 261         result_origin = CCallOrigin (_UNPK_ lbl) Nothing {- Not an arg -}
 262     in
 263
 264         -- Arguments
 265     tcExprs args                        `thenTc` \ (args', args_lie, arg_tys) ->
 266
 267         -- The argument types can be unboxed or boxed; the result
 268         -- type must, however, be boxed since it's an argument to the PrimIO
 269         -- type constructor.
 270     newTyVarTy mkBoxedTypeKind                  `thenNF_Tc` \ result_ty ->
 271
 272         -- Construct the extra insts, which encode the
 273         -- constraints on the argument and result types.
 274     mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
 275     newDicts result_origin [(cReturnableClass, result_ty)]          `thenNF_Tc` \ (ccres_dict, _) ->
 276
 277     returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
 278                     (CCall lbl args' may_gc is_asm result_ty),
 279                       -- do the wrapping in the newtype constructor here
 280               foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
 281               mkPrimIoTy result_ty)
 282 \end{code}
 283
 284 \begin{code}
 285 tcExpr (HsSCC label expr)
 286   = tcExpr expr         `thenTc` \ (expr', lie, expr_ty) ->
 287          -- No unification. Give SCC the type of expr
 288     returnTc (HsSCC label expr', lie, expr_ty)
 289
 290 tcExpr (HsLet binds expr)
 291   = tcBindsAndThen
 292         combiner
 293         binds                   -- Bindings to check
 294         (tc_expr expr)  `thenTc` \ ((expr', ty), lie) ->
 295     returnTc (expr', lie, ty)
 296   where
 297     tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
 298                    returnTc ((expr',ty), lie)
 299     combiner bind (expr, ty) = (HsLet bind expr, ty)
 300
 301 tcExpr in_expr@(HsCase expr matches src_loc)
 302   = tcAddSrcLoc src_loc $
 303     tcExpr expr                 `thenTc`    \ (expr',lie1,expr_ty) ->
 304     newTyVarTy mkTypeKind       `thenNF_Tc` \ result_ty ->
 305
 306     tcAddErrCtxt (caseCtxt in_expr) $
 307     tcMatchesCase (mkFunTy expr_ty result_ty) matches
 308                                 `thenTc`    \ (matches',lie2) ->
 309
 310     returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
 311
 312 tcExpr (HsIf pred b1 b2 src_loc)
 313   = tcAddSrcLoc src_loc $
 314     tcExpr pred                 `thenTc`    \ (pred',lie1,predTy) ->
 315
 316     tcAddErrCtxt (predCtxt pred) (
 317       unifyTauTy boolTy predTy
 318     )                           `thenTc_`
 319
 320     tcExpr b1                   `thenTc`    \ (b1',lie2,result_ty) ->
 321     tcExpr b2                   `thenTc`    \ (b2',lie3,b2Ty) ->
 322
 323     tcAddErrCtxt (branchCtxt b1 b2) $
 324     unifyTauTy result_ty b2Ty                           `thenTc_`
 325
 326     returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
 327 \end{code}
 328
 329 \begin{code}
 330 tcExpr expr@(HsDo do_or_lc stmts src_loc)
 331   = tcDoStmts do_or_lc stmts src_loc
 332 \end{code}
 333
 334 \begin{code}
 335 tcExpr (ExplicitList [])
 336   = newTyVarTy mkBoxedTypeKind          `thenNF_Tc` \ tyvar_ty ->
 337     returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
 338
 339
 340 tcExpr in_expr@(ExplicitList exprs)     -- Non-empty list
 341   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
 342     tcAddErrCtxt (listCtxt in_expr) $
 343     unifyTauTyList tys                  `thenTc_`
 344     returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)
 345
 346 tcExpr (ExplicitTuple exprs)
 347   = tcExprs exprs                       `thenTc` \ (exprs', lie, tys) ->
 348     returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)
 349
 350 tcExpr (RecordCon (HsVar con) rbinds)
 351   = tcId con                            `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
 352     let
 353         (_, record_ty) = splitFunTy con_tau
 354     in
 355         -- Con is syntactically constrained to be a data constructor
 356     ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
 357
 358         -- Check that the record bindings match the constructor
 359     tcLookupGlobalValue con                             `thenNF_Tc` \ con_id ->
 360     let
 361         bad_fields = badFields rbinds con_id
 362     in
 363     checkTc (null bad_fields) (badFieldsCon con bad_fields)     `thenTc_`
 364
 365         -- Typecheck the record bindings
 366         -- (Do this after checkRecordFields in case there's a field that
 367         --  doesn't match the constructor.)
 368     tcRecordBinds record_ty rbinds              `thenTc` \ (rbinds', rbinds_lie) ->
 369
 370     returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)
 371
 372
 373 -- The main complication with RecordUpd is that we need to explicitly
 374 -- handle the *non-updated* fields.  Consider:
 375 --
 376 --      data T a b = MkT1 { fa :: a, fb :: b }
 377 --                 | MkT2 { fa :: a, fc :: Int -> Int }
 378 --                 | MkT3 { fd :: a }
 379 --
 380 --      upd :: T a b -> c -> T a c
 381 --      upd t x = t { fb = x}
 382 --
 383 -- The type signature on upd is correct (i.e. the result should not be (T a b))
 384 -- because upd should be equivalent to:
 385 --
 386 --      upd t x = case t of
 387 --                      MkT1 p q -> MkT1 p x
 388 --                      MkT2 a b -> MkT2 p b
 389 --                      MkT3 d   -> error ...
 390 --
 391 -- So we need to give a completely fresh type to the result record,
 392 -- and then constrain it by the fields that are *not* updated ("p" above).
 393 --
 394 -- Note that because MkT3 doesn't contain all the fields being updated,
 395 -- its RHS is simply an error, so it doesn't impose any type constraints
 396 --
 397 -- All this is done in STEP 4 below.
 398
 399 tcExpr (RecordUpd record_expr rbinds)
 400   = tcAddErrCtxt recordUpdCtxt                  $
 401
 402         -- STEP 1
 403         -- Figure out the tycon and data cons from the first field name
 404     ASSERT( not (null rbinds) )
 405     let
 406         ((first_field_name, _, _) : rest) = rbinds
 407     in
 408     tcLookupGlobalValueMaybe first_field_name   `thenNF_Tc` \ maybe_sel_id ->
 409     (case maybe_sel_id of
 410         Just sel_id | isRecordSelector sel_id -> returnTc sel_id
 411         other                                 -> failTc (notSelector first_field_name)
 412     )                                           `thenTc` \ sel_id ->
 413     let
 414         (_, tau)                  = splitForAllTy (idType sel_id)
 415         Just (data_ty, _)         = getFunTy_maybe tau  -- Must succeed since sel_id is a selector
 416         (tycon, _, data_cons)     = getAppDataTyCon data_ty
 417         (con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 418     in
 419     tcInstTyVars con_tyvars                     `thenNF_Tc` \ (_, result_inst_tys, result_inst_env) ->
 420
 421         -- STEP 2
 422         -- Check for bad fields
 423     checkTc (any (null . badFields rbinds) data_cons)
 424             (badFieldsUpd rbinds)               `thenTc_`
 425
 426         -- STEP 3
 427         -- Typecheck the update bindings.
 428         -- (Do this after checking for bad fields in case there's a field that
 429         --  doesn't match the constructor.)
 430     let
 431         result_record_ty = applyTyCon tycon result_inst_tys
 432     in
 433     tcRecordBinds result_record_ty rbinds       `thenTc` \ (rbinds', rbinds_lie) ->
 434
 435         -- STEP 4
 436         -- Use the un-updated fields to find a vector of booleans saying
 437         -- which type arguments must be the same in updatee and result.
 438         --
 439         -- WARNING: this code assumes that all data_cons in a common tycon
 440         -- have FieldLabels abstracted over the same tyvars.
 441     let
 442         upd_field_lbls      = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
 443         con_field_lbls_s    = map dataConFieldLabels data_cons
 444
 445                 -- A constructor is only relevant to this process if
 446                 -- it contains all the fields that are being updated
 447         relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
 448         is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls
 449
 450         non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
 451         common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)
 452
 453         mk_inst_ty (tyvar, result_inst_ty)
 454           | tyvar `elementOfTyVarSet` common_tyvars = returnNF_Tc result_inst_ty        -- Same as result type
 455           | otherwise                               = newTyVarTy mkBoxedTypeKind        -- Fresh type
 456     in
 457     mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)        `thenNF_Tc` \ inst_tys ->
 458
 459         -- STEP 5
 460         -- Typecheck the expression to be updated
 461     tcExpr record_expr                                  `thenTc` \ (record_expr', record_lie, record_ty) ->
 462     unifyTauTy (applyTyCon tycon inst_tys) record_ty    `thenTc_`
 463
 464
 465         -- STEP 6
 466         -- Figure out the LIE we need.  We have to generate some
 467         -- dictionaries for the data type context, since we are going to
 468         -- do some construction.
 469         --
 470         -- What dictionaries do we need?  For the moment we assume that all
 471         -- data constructors have the same context, and grab it from the first
 472         -- constructor.  If they have varying contexts then we'd have to
 473         -- union the ones that could participate in the update.
 474     let
 475         (tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
 476         inst_env = zipEqual "tcExpr:RecordUpd" tyvars result_inst_tys
 477     in
 478     tcInstTheta inst_env theta                  `thenNF_Tc` \ theta' ->
 479     newDicts RecordUpdOrigin theta'             `thenNF_Tc` \ (con_lie, dicts) ->
 480
 481         -- Phew!
 482     returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds',
 483               con_lie `plusLIE` record_lie `plusLIE` rbinds_lie,
 484               result_record_ty)
 485
 486
 487 tcExpr (ArithSeqIn seq@(From expr))
 488   = tcExpr expr                                 `thenTc`    \ (expr', lie1, ty) ->
 489
 490     tcLookupGlobalValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
 491     newMethod (ArithSeqOrigin seq)
 492               (RealId sel_id) [ty]              `thenNF_Tc` \ (lie2, enum_from_id) ->
 493
 494     returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
 495               lie1 `plusLIE` lie2,
 496               mkListTy ty)
 497
 498 tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
 499   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 500     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 501
 502     tcAddErrCtxt (arithSeqCtxt in_expr) $
 503     unifyTauTyList [ty1, ty2]                           `thenTc_`
 504
 505     tcLookupGlobalValueByKey enumFromThenClassOpKey     `thenNF_Tc` \ sel_id ->
 506     newMethod (ArithSeqOrigin seq)
 507               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie3, enum_from_then_id) ->
 508
 509     returnTc (ArithSeqOut (HsVar enum_from_then_id)
 510                            (FromThen expr1' expr2'),
 511               lie1 `plusLIE` lie2 `plusLIE` lie3,
 512               mkListTy ty1)
 513
 514 tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
 515   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 516     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 517
 518     tcAddErrCtxt (arithSeqCtxt in_expr) $
 519     unifyTauTyList [ty1,ty2]    `thenTc_`
 520
 521     tcLookupGlobalValueByKey enumFromToClassOpKey       `thenNF_Tc` \ sel_id ->
 522     newMethod (ArithSeqOrigin seq)
 523               (RealId sel_id) [ty1]             `thenNF_Tc` \ (lie3, enum_from_to_id) ->
 524
 525     returnTc (ArithSeqOut (HsVar enum_from_to_id)
 526                           (FromTo expr1' expr2'),
 527               lie1 `plusLIE` lie2 `plusLIE` lie3,
 528                mkListTy ty1)
 529
 530 tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
 531   = tcExpr expr1                `thenTc`    \ (expr1',lie1,ty1) ->
 532     tcExpr expr2                `thenTc`    \ (expr2',lie2,ty2) ->
 533     tcExpr expr3                `thenTc`    \ (expr3',lie3,ty3) ->
 534
 535     tcAddErrCtxt  (arithSeqCtxt in_expr) $
 536     unifyTauTyList [ty1,ty2,ty3]                        `thenTc_`
 537
 538     tcLookupGlobalValueByKey enumFromThenToClassOpKey   `thenNF_Tc` \ sel_id ->
 539     newMethod (ArithSeqOrigin seq)
 540               (RealId sel_id) [ty1]                     `thenNF_Tc` \ (lie4, eft_id) ->
 541
 542     returnTc (ArithSeqOut (HsVar eft_id)
 543                            (FromThenTo expr1' expr2' expr3'),
 544               lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
 545               mkListTy ty1)
 546 \end{code}
 547
 548 %************************************************************************
 549 %*                                                                      *
 550 \subsection{Expressions type signatures}
 551 %*                                                                      *
 552 %************************************************************************
 553
 554 \begin{code}
 555 tcExpr in_expr@(ExprWithTySig expr poly_ty)
 556  = tcExpr expr                  `thenTc` \ (texpr, lie, tau_ty) ->
 557    tcHsType  poly_ty            `thenTc` \ sigma_sig ->
 558
 559         -- Check the tau-type part
 560    tcSetErrCtxt (exprSigCtxt in_expr)   $
 561    tcInstSigType sigma_sig              `thenNF_Tc` \ sigma_sig' ->
 562    let
 563         (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
 564    in
 565    unifyTauTy sig_tau' tau_ty           `thenTc_`
 566
 567         -- Check the type variables of the signature
 568    checkSigTyVars sig_tyvars' sig_tau'  `thenTc_`
 569
 570         -- Check overloading constraints
 571    newDicts SignatureOrigin sig_theta'          `thenNF_Tc` \ (sig_dicts, _) ->
 572    tcSimplifyAndCheck
 573         (mkTyVarSet sig_tyvars')
 574         sig_dicts lie                           `thenTc_`
 575
 576         -- If everything is ok, return the stuff unchanged, except for
 577         -- the effect of any substutions etc.  We simply discard the
 578         -- result of the tcSimplifyAndCheck, except for any default
 579         -- resolution it may have done, which is recorded in the
 580         -- substitution.
 581    returnTc (texpr, lie, tau_ty)
 582 \end{code}
 583
 584 %************************************************************************
 585 %*                                                                      *
 586 \subsection{@tcApp@ typchecks an application}
 587 %*                                                                      *
 588 %************************************************************************
 589
 590 \begin{code}
 591 tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
 592       -> TcM s (TcExpr s, [TcExpr s],       -- Translated fun and args
 593                 LIE s,
 594                 TcType s)                   -- Type of the application
 595
 596 tcApp fun args
 597   =     -- First type-check the function
 598         -- In the HsVar case we go straight to tcId to avoid hitting the
 599         -- rank-2 check, which we check later here anyway
 600     (case fun of
 601         HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff
 602         other      -> tcExpr fun
 603     )                                   `thenTc` \ (fun', lie_fun, fun_ty) ->
 604
 605     tcApp_help fun 1 fun_ty args        `thenTc` \ (args', lie_args, res_ty) ->
 606
 607     -- Check that the result type doesn't have any nested for-alls.
 608     -- For example, a "build" on its own is no good; it must be applied to something.
 609     checkTc (isTauTy res_ty)
 610             (lurkingRank2Err fun fun_ty) `thenTc_`
 611
 612     returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
 613
 614
 615 tcApp_help :: RenamedHsExpr -> Int      -- Function and arg position, used in error message(s)
 616            -> TcType s                  -- The type of the function
 617            -> [RenamedHsExpr]           -- Arguments
 618            -> TcM s ([TcExpr s],                -- Typechecked args
 619                      LIE s,
 620                      TcType s)          -- Result type of the application
 621
 622 tcApp_help orig_fun arg_no fun_ty []
 623   = returnTc ([], emptyLIE, fun_ty)
 624
 625 tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
 626   =     -- Expect the function to have type A->B
 627     tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
 628             unifyFunTy fun_ty
 629     )                                                   `thenTc` \ (expected_arg_ty, result_ty) ->
 630
 631         -- Type check the argument
 632     tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
 633                 tcArg expected_arg_ty arg
 634     )                                                   `thenTc` \ (arg', lie_arg) ->
 635
 636         -- Do the other args
 637     tcApp_help orig_fun (arg_no+1) result_ty args       `thenTc` \ (args', lie_args, res_ty) ->
 638
 639         -- Done
 640     returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
 641
 642 \end{code}
 643
 644 \begin{code}
 645 tcArg :: TcType s                       -- Expected arg type
 646       -> RenamedHsExpr                  -- Actual argument
 647       -> TcM s (TcExpr s, LIE s)        -- Resulting argument and LIE
 648
 649 tcArg expected_arg_ty arg
 650   | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
 651   =     -- The ordinary, non-rank-2 polymorphic case
 652     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 653     unifyTauTy expected_arg_ty actual_arg_ty    `thenTc_`
 654     returnTc (arg', lie_arg)
 655
 656   | otherwise
 657   =     -- Ha!  The argument type of the function is a for-all type,
 658         -- An example of rank-2 polymorphism.
 659
 660         -- No need to instantiate the argument type... it's must be the result
 661         -- of instantiating a function involving rank-2 polymorphism, so there
 662         -- isn't any danger of using the same tyvars twice
 663         -- The argument type shouldn't be overloaded type (hence ASSERT)
 664
 665         -- To ensure that the forall'd type variables don't get unified with each
 666         -- other or any other types, we make fresh *signature* type variables
 667         -- and unify them with the tyvars.
 668     tcInstSigTcType expected_arg_ty     `thenNF_Tc` \ (sig_tyvars, sig_rho) ->
 669     let
 670         (sig_theta, sig_tau) = splitRhoTy sig_rho
 671     in
 672     ASSERT( null sig_theta )    -- And expected_tyvars are all DontBind things
 673
 674         -- Type-check the arg and unify with expected type
 675     tcExpr arg                                  `thenTc` \ (arg', lie_arg, actual_arg_ty) ->
 676     unifyTauTy sig_tau actual_arg_ty            `thenTc_`
 677
 678         -- Check that the arg_tyvars havn't been constrained
 679         -- The interesting bit here is that we must include the free variables
 680         -- of the expected arg ty.  Here's an example:
 681         --       runST (newVar True)
 682         -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
 683         -- for (newVar True), with s fresh.  Then we unify with the runST's arg type
 684         -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
 685         -- So now s' isn't unconstrained because it's linked to a.
 686         -- Conclusion: include the free vars of the expected arg type in the
 687         -- list of "free vars" for the signature check.
 688
 689     tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
 690         tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
 691                 checkSigTyVars sig_tyvars sig_tau
 692         )                                               `thenTc_`
 693
 694             -- Check that there's no overloading involved
 695             -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
 696             -- but which, on simplification, don't actually need a dictionary involving
 697             -- the tyvar.  So we have to do a proper simplification right here.
 698         tcSimplifyRank2 (mkTyVarSet sig_tyvars)
 699                         lie_arg                         `thenTc` \ (free_insts, inst_binds) ->
 700
 701             -- This HsLet binds any Insts which came out of the simplification.
 702             -- It's a bit out of place here, but using AbsBind involves inventing
 703             -- a couple of new names which seems worse.
 704         returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
 705     )
 706   where
 707     mk_binds inst_binds = MonoBind inst_binds [] nonRecursive
 708 \end{code}
 709
 710 %************************************************************************
 711 %*                                                                      *
 712 \subsection{@tcId@ typchecks an identifier occurrence}
 713 %*                                                                      *
 714 %************************************************************************
 715
 716 \begin{code}
 717 tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
 718
 719 tcId name
 720   =     -- Look up the Id and instantiate its type
 721     tcLookupLocalValue name     `thenNF_Tc` \ maybe_local ->
 722
 723     case maybe_local of
 724       Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
 725
 726       Nothing ->    tcLookupGlobalValue name    `thenNF_Tc` \ id ->
 727                     tcInstType [] (idType id)   `thenNF_Tc` \ inst_ty ->
 728                     let
 729                         (tyvars, rho) = splitForAllTy inst_ty
 730                     in
 731                     instantiate_it2 (RealId id) tyvars rho
 732
 733   where
 734         -- The instantiate_it loop runs round instantiating the Id.
 735         -- It has to be a loop because we are now prepared to entertain
 736         -- types like
 737         --              f:: forall a. Eq a => forall b. Baz b => tau
 738         -- We want to instantiate this to
 739         --              f2::tau         {f2 = f1 b (Baz b), f1 = f a (Eq a)}
 740     instantiate_it tc_id_occ ty
 741       = tcInstTcType ty         `thenNF_Tc` \ (tyvars, rho) ->
 742         instantiate_it2 tc_id_occ tyvars rho
 743
 744     instantiate_it2 tc_id_occ tyvars rho
 745       = tcSplitRhoTy rho                                `thenNF_Tc` \ (theta, tau) ->
 746         if null theta then      -- Is it overloaded?
 747                 returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
 748         else
 749                 -- Yes, it's overloaded
 750         newMethodWithGivenTy (OccurrenceOf tc_id_occ)
 751                              tc_id_occ arg_tys rho      `thenNF_Tc` \ (lie1, meth_id) ->
 752         instantiate_it meth_id tau                      `thenNF_Tc` \ (expr, lie2, final_tau) ->
 753         returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
 754
 755       where
 756         arg_tys       = mkTyVarTys tyvars
 757 \end{code}
 758
 759 %************************************************************************
 760 %*                                                                      *
 761 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
 762 %*                                                                      *
 763 %************************************************************************
 764
 765 \begin{code}
 766 tcDoStmts do_or_lc stmts src_loc
 767   =     -- get the Monad and MonadZero classes
 768         -- create type consisting of a fresh monad tyvar
 769     ASSERT( not (null stmts) )
 770     tcAddSrcLoc src_loc $
 771     newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind)    `thenNF_Tc` \ m ->
 772
 773     let
 774       tc_stmts []           = returnTc (([], error "tc_stmts"), emptyLIE)
 775       tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
 776                               tc_stmts stmts
 777
 778       combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
 779       combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
 780       combine_stmts stmt                _         ([], _) = panic "Bad last stmt tcDoStmts"
 781       combine_stmts stmt                _     (stmts, ty) = (stmt:stmts, ty)
 782     in
 783     tc_stmts stmts      `thenTc` \ ((stmts', result_ty), final_lie) ->
 784
 785         -- Build the then and zero methods in case we need them
 786         -- It's important that "then" and "return" appear just once in the final LIE,
 787         -- not only for typechecker efficiency, but also because otherwise during
 788         -- simplification we end up with silly stuff like
 789         --      then = case d of (t,r) -> t
 790         --      then = then
 791         -- where the second "then" sees that it already exists in the "available" stuff.
 792         --
 793     tcLookupGlobalValueByKey returnMClassOpKey  `thenNF_Tc` \ return_sel_id ->
 794     tcLookupGlobalValueByKey thenMClassOpKey    `thenNF_Tc` \ then_sel_id ->
 795     tcLookupGlobalValueByKey zeroClassOpKey     `thenNF_Tc` \ zero_sel_id ->
 796     newMethod DoOrigin
 797               (RealId return_sel_id) [m]        `thenNF_Tc` \ (return_lie, return_id) ->
 798     newMethod DoOrigin
 799               (RealId then_sel_id) [m]          `thenNF_Tc` \ (then_lie, then_id) ->
 800     newMethod DoOrigin
 801               (RealId zero_sel_id) [m]          `thenNF_Tc` \ (zero_lie, zero_id) ->
 802     let
 803       monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
 804       perhaps_zero_lie | all failure_free stmts' = emptyLIE
 805                        | otherwise               = zero_lie
 806
 807       failure_free (BindStmt pat _ _) = failureFreePat pat
 808       failure_free (GuardStmt _ _)    = False
 809       failure_free other_stmt         = True
 810     in
 811     returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id result_ty src_loc,
 812               final_lie `plusLIE` monad_lie,
 813               result_ty)
 814 \end{code}
 815
 816 \begin{code}
 817 tcStmt :: (RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s))  -- This is tcExpr
 818                                 -- The sole, disgusting, reason for this parameter
 819                                 -- is to get the effect of polymorphic recursion
 820                                 -- ToDo: rm when booting with Haskell 1.3
 821        -> DoOrListComp
 822        -> (TcType s -> TcType s)                -- Relationship type of pat and rhs in pat <- rhs
 823        -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
 824        -> RenamedStmt
 825        -> TcM s (thing, LIE s)
 826        -> TcM s (thing, LIE s)
 827
 828 tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
 829   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
 830     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 831         tc_expr exp                      `thenTc`    \ (exp', exp_lie, exp_ty) ->
 832         returnTc (ReturnStmt exp', exp_lie, m exp_ty)
 833     )                                   `thenTc` \ (stmt', stmt_lie, stmt_ty) ->
 834     do_next                             `thenTc` \ (thing', thing_lie) ->
 835     returnTc (combine stmt' (Just stmt_ty) thing',
 836               stmt_lie `plusLIE` thing_lie)
 837
 838 tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
 839   = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
 840     tcAddSrcLoc src_loc                 (
 841     tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
 842         tc_expr exp                     `thenTc`    \ (exp', exp_lie, exp_ty) ->
 843         unifyTauTy boolTy exp_ty        `thenTc_`
 844         returnTc (GuardStmt exp' src_loc, exp_lie)
 845     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 846     do_next                             `thenTc` \ (thing', thing_lie) ->
 847     returnTc (combine stmt' Nothing thing',
 848               stmt_lie `plusLIE` thing_lie)
 849
 850 tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
 851   = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } )
 852     tcAddSrcLoc src_loc                 (
 853     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 854         tc_expr exp                     `thenTc`    \ (exp', exp_lie, exp_ty) ->
 855         -- Check that exp has type (m tau) for some tau (doesn't matter what)
 856         newTyVarTy mkTypeKind           `thenNF_Tc` \ tau ->
 857         unifyTauTy (m tau) exp_ty       `thenTc_`
 858         returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
 859     ))                                  `thenTc` \ (stmt',  stmt_lie, stmt_ty) ->
 860     do_next                             `thenTc` \ (thing', thing_lie) ->
 861     returnTc (combine stmt' (Just stmt_ty) thing',
 862               stmt_lie `plusLIE` thing_lie)
 863
 864 tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
 865   = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
 866     tcAddSrcLoc src_loc         (
 867     tcSetErrCtxt (stmtCtxt do_or_lc stmt)       (
 868         tcPat pat                       `thenTc`    \ (pat', pat_lie, pat_ty) ->
 869         tc_expr exp                     `thenTc`    \ (exp', exp_lie, exp_ty) ->
 870         unifyTauTy (m pat_ty) exp_ty    `thenTc_`
 871
 872         -- NB: the environment has been extended with the new binders
 873         -- which the rhs can't "see", but the renamer should have made
 874         -- sure that everything is distinct by now, so there's no problem.
 875         -- Putting the tcExpr before the newMonoIds messes up the nesting
 876         -- of error contexts, so I didn't  bother
 877
 878         returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
 879     ))                                  `thenTc` \ (stmt', stmt_lie) ->
 880     do_next                             `thenTc` \ (thing', thing_lie) ->
 881     returnTc (combine stmt' Nothing thing',
 882               stmt_lie `plusLIE` thing_lie)
 883
 884 tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
 885      = tcBindsAndThen           -- No error context, but a binding group is
 886         combine'                -- rather a large thing for an error context anyway
 887         binds
 888         do_next
 889      where
 890         combine' binds' thing' = combine (LetStmt binds') Nothing thing'
 891 \end{code}
 892
 893 %************************************************************************
 894 %*                                                                      *
 895 \subsection{Record bindings}
 896 %*                                                                      *
 897 %************************************************************************
 898
 899 Game plan for record bindings
 900 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 901 For each binding
 902         field = value
 903 1. look up "field", to find its selector Id, which must have type
 904         forall a1..an. T a1 .. an -> tau
 905    where tau is the type of the field.
 906
 907 2. Instantiate this type
 908
 909 3. Unify the (T a1 .. an) part with the "expected result type", which
 910    is passed in.  This checks that all the field labels come from the
 911    same type.
 912
 913 4. Type check the value using tcArg, passing tau as the expected
 914    argument type.
 915
 916 This extends OK when the field types are universally quantified.
 917
 918 Actually, to save excessive creation of fresh type variables,
 919 we
 920
 921 \begin{code}
 922 tcRecordBinds
 923         :: TcType s             -- Expected type of whole record
 924         -> RenamedRecordBinds
 925         -> TcM s (TcRecordBinds s, LIE s)
 926
 927 tcRecordBinds expected_record_ty rbinds
 928   = mapAndUnzipTc do_bind rbinds        `thenTc` \ (rbinds', lies) ->
 929     returnTc (rbinds', plusLIEs lies)
 930   where
 931     do_bind (field_label, rhs, pun_flag)
 932       = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id ->
 933         ASSERT( isRecordSelector sel_id )
 934                 -- This lookup and assertion will surely succeed, because
 935                 -- we check that the fields are indeed record selectors
 936                 -- before calling tcRecordBinds
 937
 938         tcInstId sel_id                 `thenNF_Tc` \ (_, _, tau) ->
 939
 940                 -- Record selectors all have type
 941                 --      forall a1..an.  T a1 .. an -> tau
 942         ASSERT( maybeToBool (getFunTy_maybe tau) )
 943         let
 944                 -- Selector must have type RecordType -> FieldType
 945           Just (record_ty, field_ty) = getFunTy_maybe tau
 946         in
 947         unifyTauTy expected_record_ty record_ty         `thenTc_`
 948         tcArg field_ty rhs                              `thenTc` \ (rhs', lie) ->
 949         returnTc ((RealId sel_id, rhs', pun_flag), lie)
 950
 951 badFields rbinds data_con
 952   = [field_name | (field_name, _, _) <- rbinds,
 953                   not (field_name `elem` field_names)
 954     ]
 955   where
 956     field_names = map fieldLabelName (dataConFieldLabels data_con)
 957 \end{code}
 958
 959 %************************************************************************
 960 %*                                                                      *
 961 \subsection{@tcExprs@ typechecks a {\em list} of expressions}
 962 %*                                                                      *
 963 %************************************************************************
 964
 965 \begin{code}
 966 tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])
 967
 968 tcExprs [] = returnTc ([], emptyLIE, [])
 969 tcExprs (expr:exprs)
 970  = tcExpr  expr                 `thenTc` \ (expr',  lie1, ty) ->
 971    tcExprs exprs                `thenTc` \ (exprs', lie2, tys) ->
 972    returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
 973 \end{code}
 974
 975
 976 % =================================================
 977
 978 Errors and contexts
 979 ~~~~~~~~~~~~~~~~~~~
 980
 981 Mini-utils:
 982 \begin{code}
 983 pp_nest_hang :: String -> Doc -> Doc
 984 pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
 985 \end{code}
 986
 987 Boring and alphabetical:
 988 \begin{code}
 989 arithSeqCtxt expr sty
 990   = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr sty expr)
 991
 992 branchCtxt b1 b2 sty
 993   = sep [ptext SLIT("In the branches of a conditional:"),
 994            pp_nest_hang "`then' branch:" (ppr sty b1),
 995            pp_nest_hang "`else' branch:" (ppr sty b2)]
 996
 997 caseCtxt expr sty
 998   = hang (ptext SLIT("In a case expression:")) 4 (ppr sty expr)
 999
1000 exprSigCtxt expr sty
1001   = hang (ptext SLIT("In an expression with a type signature:"))
1002          4 (ppr sty expr)
1003
1004 listCtxt expr sty
1005   = hang (ptext SLIT("In a list expression:")) 4 (ppr sty expr)
1006
1007 predCtxt expr sty
1008   = hang (ptext SLIT("In a predicate expression:")) 4 (ppr sty expr)
1009
1010 sectionRAppCtxt expr sty
1011   = hang (ptext SLIT("In a right section:")) 4 (ppr sty expr)
1012
1013 sectionLAppCtxt expr sty
1014   = hang (ptext SLIT("In a left section:")) 4 (ppr sty expr)
1015
1016 funAppCtxt fun arg_no arg sty
1017   = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"),
1018                     ppr sty fun <> text ", namely"])
1019          4 (pprParendExpr sty arg)
1020
1021 stmtCtxt ListComp stmt sty
1022   = hang (ptext SLIT("In a list-comprehension qualifer:"))
1023          4 (ppr sty stmt)
1024
1025 stmtCtxt DoStmt stmt sty
1026   = hang (ptext SLIT("In a do statement:"))
1027          4 (ppr sty stmt)
1028
1029 tooManyArgsCtxt f sty
1030   = hang (ptext SLIT("Too many arguments in an application of the function"))
1031          4 (ppr sty f)
1032
1033 lurkingRank2Err fun fun_ty sty
1034   = hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun])
1035          4 (vcat [text "It is applied to too few arguments,",
1036                       ptext SLIT("so that the result type has for-alls in it")])
1037
1038 rank2ArgCtxt arg expected_arg_ty sty
1039   = hang (ptext SLIT("In a polymorphic function argument:"))
1040          4 (sep [(<>) (ppr sty arg) (ptext SLIT(" ::")),
1041                    ppr sty expected_arg_ty])
1042
1043 badFieldsUpd rbinds sty
1044   = hang (ptext SLIT("No constructor has all these fields:"))
1045          4 (interpp'SP sty fields)
1046   where
1047     fields = [field | (field, _, _) <- rbinds]
1048
1049 recordUpdCtxt sty = ptext SLIT("In a record update construct")
1050
1051 badFieldsCon con fields sty
1052   = hsep [ptext SLIT("Constructor"),            ppr sty con,
1053            ptext SLIT("does not have field(s)"), interpp'SP sty fields]
1054
1055 notSelector field sty
1056   = hsep [ppr sty field, ptext SLIT("is not a record selector")]
1057 \end{code}