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