TcExpr.lhs 36.8 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3
%
4
\section[TcExpr]{Typecheck an expression}
5 6 7 8

\begin{code}
#include "HsVersions.h"

sof's avatar
sof committed
9
module TcExpr ( tcExpr, tcStmt, tcId ) where
10

11
IMP_Ubiq()
12

13
import HsSyn		( HsExpr(..), Stmt(..), DoOrListComp(..), 
sof's avatar
sof committed
14 15
			  HsBinds(..),  MonoBinds(..), 
			  SYN_IE(RecFlag), nonRecursive,
16
			  ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
17 18
			  Match, Fake, InPat, OutPat, HsType, Fixity,
			  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 25
			  mkHsTyApp
			)
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,
sof's avatar
sof committed
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(..),
sof's avatar
sof committed
42 43 44
			  tcInstId, tcInstType, tcInstSigTcType, tcInstTyVars,
			  tcInstSigType, tcInstTcType, tcInstTheta, tcSplitRhoTy,
			  newTyVarTy, newTyVarTys, zonkTcTyVars, zonkTcType )
45
import TcKind		( TcKind )
46

47
import Class		( SYN_IE(Class), classSig )
sof's avatar
sof committed
48
import FieldLabel	( FieldLabel, fieldLabelName, fieldLabelType )
sof's avatar
sof committed
49 50 51 52
import Id		( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
			  isRecordSelector,
			  SYN_IE(Id), GenId
			)
53
import Kind		( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
54
import Name		( Name{-instance Eq-} )
55
import Type		( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy,
sof's avatar
sof committed
56
			  getTyVar_maybe, getFunTy_maybe, instantiateTy, applyTyCon,
57
			  splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy,
sof's avatar
sof committed
58
			  isTauTy, mkFunTys, tyVarsOfType, tyVarsOfTypes, getForAllTy_maybe,
59
			  getAppDataTyCon, maybeAppDataTyCon
60
			)
sof's avatar
sof committed
61
import TyVar		( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, elementOfTyVarSet, mkTyVarSet )
62
import TysPrim		( intPrimTy, charPrimTy, doublePrimTy,
63
			  floatPrimTy, addrPrimTy, realWorldTy
64 65 66
			)
import TysWiredIn	( addrTy,
			  boolTy, charTy, stringTy, mkListTy,
67
			  mkTupleTy, mkPrimIoTy, stDataCon
68
			)
69
import Unify		( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy )
70 71 72
import Unique		( Unique, cCallableClassKey, cReturnableClassKey, 
			  enumFromClassOpKey, enumFromThenClassOpKey,
			  enumFromToClassOpKey, enumFromThenToClassOpKey,
73
			  thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
74
			)
sof's avatar
sof committed
75
import Outputable	( speakNth, interpp'SP, Outputable(..) )
76 77 78
import PprType		( GenType, GenTyVar )	-- Instances
import Maybes		( maybeToBool )
import Pretty
sof's avatar
sof committed
79
import ListSetOps	( minusList )
80
import Util
81
\end{code}
82

83 84
\begin{code}
tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s)
85 86 87 88 89 90 91 92 93
\end{code}

%************************************************************************
%*									*
\subsection{The TAUT rules for variables}
%*									*
%************************************************************************

\begin{code}
94
tcExpr (HsVar name)
95
  = tcId name		`thenNF_Tc` \ (expr', lie, res_ty) ->
96

97 98 99 100 101
    -- Check that the result type doesn't have any nested for-alls.
    -- For example, a "build" on its own is no good; it must be
    -- applied to something.
    checkTc (isTauTy res_ty)
	    (lurkingRank2Err name res_ty) `thenTc_`
102

103
    returnTc (expr', lie, res_ty)
104 105 106 107 108 109 110 111 112 113 114
\end{code}

%************************************************************************
%*									*
\subsection{Literals}
%*									*
%************************************************************************

Overloaded literals.

\begin{code}
115 116
tcExpr (HsLit (HsInt i))
  = newTyVarTy mkBoxedTypeKind	`thenNF_Tc` \ ty ->
117

118 119 120
    newOverloadedLit (LiteralOrigin (HsInt i))
		     (OverloadedIntegral i)
		     ty					`thenNF_Tc` \ (lie, over_lit_id) ->
121

122
    returnTc (HsVar over_lit_id, lie, ty)
123

124 125
tcExpr (HsLit (HsFrac f))
  = newTyVarTy mkBoxedTypeKind	`thenNF_Tc` \ ty ->
126

127 128 129 130 131
    newOverloadedLit (LiteralOrigin (HsFrac f))
		     (OverloadedFractional f)
		     ty					`thenNF_Tc` \ (lie, over_lit_id) ->

    returnTc (HsVar over_lit_id, lie, ty)
132

133 134 135 136 137 138
tcExpr (HsLit lit@(HsLitLit s))
  = tcLookupClassByKey cCallableClassKey		`thenNF_Tc` \ cCallableClass ->
    newTyVarTy mkBoxedTypeKind				`thenNF_Tc` \ ty ->
    newDicts (LitLitOrigin (_UNPK_ s))
	     [(cCallableClass, ty)]			`thenNF_Tc` \ (dicts, _) ->
    returnTc (HsLitOut lit ty, dicts, ty)
139 140 141 142 143
\end{code}

Primitive literals:

\begin{code}
144 145
tcExpr (HsLit lit@(HsCharPrim c))
  = returnTc (HsLitOut lit charPrimTy, emptyLIE, charPrimTy)
146

147 148
tcExpr (HsLit lit@(HsStringPrim s))
  = returnTc (HsLitOut lit addrPrimTy, emptyLIE, addrPrimTy)
149

150 151
tcExpr (HsLit lit@(HsIntPrim i))
  = returnTc (HsLitOut lit intPrimTy, emptyLIE, intPrimTy)
152

153 154
tcExpr (HsLit lit@(HsFloatPrim f))
  = returnTc (HsLitOut lit floatPrimTy, emptyLIE, floatPrimTy)
155

156 157
tcExpr (HsLit lit@(HsDoublePrim d))
  = returnTc (HsLitOut lit doublePrimTy, emptyLIE, doublePrimTy)
158 159 160 161 162
\end{code}

Unoverloaded literals:

\begin{code}
163 164
tcExpr (HsLit lit@(HsChar c))
  = returnTc (HsLitOut lit charTy, emptyLIE, charTy)
165

166 167
tcExpr (HsLit lit@(HsString str))
  = returnTc (HsLitOut lit stringTy, emptyLIE, stringTy)
168 169 170 171 172 173 174 175 176
\end{code}

%************************************************************************
%*									*
\subsection{Other expression forms}
%*									*
%************************************************************************

\begin{code}
177 178
tcExpr (HsPar expr) -- preserve parens so printing needn't guess where they go
  = tcExpr expr
179

180
tcExpr (NegApp expr neg) = tcExpr (HsApp neg expr)
181

182 183 184
tcExpr (HsLam match)
  = tcMatch match	`thenTc` \ (match',lie,ty) ->
    returnTc (HsLam match', lie, ty)
185

186 187 188 189 190 191
tcExpr (HsApp e1 e2) = accum e1 [e2]
  where
    accum (HsApp e1 e2) args = accum e1 (e2:args)
    accum fun args
      = tcApp fun args 	`thenTc` \ (fun', args', lie, res_ty) ->
	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 198 199 200 201 202
\end{code}

Note that the operators in sections are expected to be binary, and
a type error will occur if they aren't.

\begin{code}
203 204
-- Left sections, equivalent to
--	\ x -> e op x,
205
-- or
206
--	\ x -> op e x,
207 208 209
-- or just
-- 	op e

210 211 212 213 214 215 216 217 218 219 220 221 222
tcExpr in_expr@(SectionL arg op)
  = tcApp op [arg] 		`thenTc` \ (op', [arg'], lie, res_ty) ->

	-- Check that res_ty is a function type
	-- Without this check we barf in the desugarer on
	-- 	f op = (3 `op`)
	-- because it tries to desugar to
	--	f op = \r -> 3 op r
	-- so (3 `op`) had better be a function!
    newTyVarTy mkTypeKind		`thenNF_Tc` \ ty1 ->
    newTyVarTy mkTypeKind		`thenNF_Tc` \ ty2 ->
    tcAddErrCtxt (sectionLAppCtxt in_expr) $
    unifyTauTy (mkFunTy ty1 ty2) res_ty	`thenTc_`
223

224 225 226
    returnTc (SectionL arg' op', lie, res_ty)

-- Right sections, equivalent to \ x -> x op expr, or
227 228
--	\ x -> op x expr

229 230 231 232 233 234 235
tcExpr in_expr@(SectionR op expr)
  = tcExpr op			`thenTc`    \ (op',  lie1, op_ty) ->
    tcExpr expr			`thenTc`    \ (expr',lie2, expr_ty) ->

    newTyVarTy mkTypeKind	`thenNF_Tc` \ ty1 ->
    newTyVarTy mkTypeKind	`thenNF_Tc` \ ty2 ->
    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 240 241 242 243 244 245 246 247 248
\end{code}

The interesting thing about @ccall@ is that it is just a template
which we instantiate by filling in details about the types of its
argument and result (ie minimal typechecking is performed).  So, the
basic story is that we allocate a load of type variables (to hold the
arg/result types); unify them with the args/result; and store them for
later use.

\begin{code}
249 250 251 252
tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty)
  = 	-- Get the callable and returnable classes.
    tcLookupClassByKey cCallableClassKey	`thenNF_Tc` \ cCallableClass ->
    tcLookupClassByKey cReturnableClassKey	`thenNF_Tc` \ cReturnableClass ->
253

254 255 256 257 258
    let
	new_arg_dict (arg, arg_ty)
	  = newDicts (CCallOrigin (_UNPK_ lbl) (Just arg))
		     [(cCallableClass, arg_ty)]		`thenNF_Tc` \ (arg_dicts, _) ->
	    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 272

	-- Construct the extra insts, which encode the
	-- constraints on the argument and result types.
273 274
    mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys)    `thenNF_Tc` \ ccarg_dicts_s ->
    newDicts result_origin [(cReturnableClass, result_ty)]	    `thenNF_Tc` \ (ccres_dict, _) ->
275

276 277 278
    returnTc (HsApp (HsVar (RealId stDataCon) `TyApp` [realWorldTy, result_ty])
		    (CCall lbl args' may_gc is_asm result_ty),
		      -- do the wrapping in the newtype constructor here
279
	      foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie,
280 281 282 283
	      mkPrimIoTy result_ty)
\end{code}

\begin{code}
284 285
tcExpr (HsSCC label expr)
  = tcExpr expr		`thenTc` \ (expr', lie, expr_ty) ->
286
	 -- No unification. Give SCC the type of expr
287 288 289 290
    returnTc (HsSCC label expr', lie, expr_ty)

tcExpr (HsLet binds expr)
  = tcBindsAndThen
sof's avatar
sof committed
291
	combiner
292
	binds 			-- Bindings to check
sof's avatar
sof committed
293 294 295 296 297 298
	(tc_expr expr)	`thenTc` \ ((expr', ty), lie) ->
    returnTc (expr', lie, ty)
  where
    tc_expr expr = tcExpr expr `thenTc` \ (expr', lie, ty) ->
	   	   returnTc ((expr',ty), lie)
    combiner bind (expr, ty) = (HsLet bind expr, ty)
299

300 301 302 303
tcExpr in_expr@(HsCase expr matches src_loc)
  = tcAddSrcLoc src_loc	$
    tcExpr expr			`thenTc`    \ (expr',lie1,expr_ty) ->
    newTyVarTy mkTypeKind	`thenNF_Tc` \ result_ty ->
304

305 306 307
    tcAddErrCtxt (caseCtxt in_expr) $
    tcMatchesCase (mkFunTy expr_ty result_ty) matches	
				`thenTc`    \ (matches',lie2) ->
308

309
    returnTc (HsCase expr' matches' src_loc, plusLIE lie1 lie2, result_ty)
310

311 312 313
tcExpr (HsIf pred b1 b2 src_loc)
  = tcAddSrcLoc src_loc	$
    tcExpr pred			`thenTc`    \ (pred',lie1,predTy) ->
314

315
    tcAddErrCtxt (predCtxt pred) (
316
      unifyTauTy boolTy predTy
317
    )				`thenTc_`
318

319 320
    tcExpr b1			`thenTc`    \ (b1',lie2,result_ty) ->
    tcExpr b2			`thenTc`    \ (b2',lie3,b2Ty) ->
321

322 323
    tcAddErrCtxt (branchCtxt b1 b2) $
    unifyTauTy result_ty b2Ty				`thenTc_`
324

325 326
    returnTc (HsIf pred' b1' b2' src_loc, plusLIE lie1 (plusLIE lie2 lie3), result_ty)
\end{code}
327

328
\begin{code}
329 330
tcExpr expr@(HsDo do_or_lc stmts src_loc)
  = tcDoStmts do_or_lc stmts src_loc
331 332 333
\end{code}

\begin{code}
334 335 336
tcExpr (ExplicitList [])
  = newTyVarTy mkBoxedTypeKind		`thenNF_Tc` \ tyvar_ty ->
    returnTc (ExplicitListOut tyvar_ty [], emptyLIE, mkListTy tyvar_ty)
337 338


339 340 341 342
tcExpr in_expr@(ExplicitList exprs)	-- Non-empty list
  = tcExprs exprs			`thenTc` \ (exprs', lie, tys@(elt_ty:_)) ->
    tcAddErrCtxt (listCtxt in_expr) $
    unifyTauTyList tys 			`thenTc_`
343 344
    returnTc (ExplicitListOut elt_ty exprs', lie, mkListTy elt_ty)

345 346
tcExpr (ExplicitTuple exprs)
  = tcExprs exprs			`thenTc` \ (exprs', lie, tys) ->
347 348
    returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys)

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 354 355 356
    in
	-- Con is syntactically constrained to be a data constructor
    ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )

357
	-- Check that the record bindings match the constructor
sof's avatar
sof committed
358 359 360 361 362 363 364 365 366 367
    tcLookupGlobalValue con				`thenNF_Tc` \ con_id ->
    let
	bad_fields = badFields rbinds con_id
    in
    checkTc (null bad_fields) (badFieldsCon con bad_fields)	`thenTc_`

	-- Typecheck the record bindings
	-- (Do this after checkRecordFields in case there's a field that
	--  doesn't match the constructor.)
    tcRecordBinds record_ty rbinds		`thenTc` \ (rbinds', rbinds_lie) ->
368

369 370
    returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty)

sof's avatar
sof committed
371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388

-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields.  Consider:
--
--	data T a b = MkT1 { fa :: a, fb :: b }
--		   | MkT2 { fa :: a, fc :: Int -> Int }
--		   | MkT3 { fd :: a }
--	
--	upd :: T a b -> c -> T a c
--	upd t x = t { fb = x}
--
-- The type signature on upd is correct (i.e. the result should not be (T a b))
-- because upd should be equivalent to:
--
--	upd t x = case t of 
--			MkT1 p q -> MkT1 p x
--			MkT2 a b -> MkT2 p b
--			MkT3 d   -> error ...
389
--
sof's avatar
sof committed
390 391 392 393 394 395 396
-- So we need to give a completely fresh type to the result record,
-- and then constrain it by the fields that are *not* updated ("p" above).
--
-- Note that because MkT3 doesn't contain all the fields being updated,
-- its RHS is simply an error, so it doesn't impose any type constraints
--
-- All this is done in STEP 4 below.
397 398

tcExpr (RecordUpd record_expr rbinds)
sof's avatar
sof committed
399
  = tcAddErrCtxt recordUpdCtxt			$
400

sof's avatar
sof committed
401 402 403 404 405 406 407 408 409 410 411
	-- STEP 1
	-- Figure out the tycon and data cons from the first field name
    ASSERT( not (null rbinds) )
    let 
	((first_field_name, _, _) : rest) = rbinds
    in
    tcLookupGlobalValueMaybe first_field_name	`thenNF_Tc` \ maybe_sel_id ->
    (case maybe_sel_id of
	Just sel_id | isRecordSelector sel_id -> returnTc sel_id
	other				      -> failTc (notSelector first_field_name)
    )						`thenTc` \ sel_id ->
412
    let
sof's avatar
sof committed
413 414 415 416
	(_, tau)	      	  = splitForAllTy (idType sel_id)
	Just (data_ty, _)     	  = getFunTy_maybe tau	-- Must succeed since sel_id is a selector
	(tycon, _, data_cons) 	  = getAppDataTyCon data_ty
	(con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
417
    in
sof's avatar
sof committed
418 419 420 421 422
    tcInstTyVars con_tyvars			`thenNF_Tc` \ (_, result_inst_tys, result_inst_env) ->

	-- STEP 2
	-- Check for bad fields
    checkTc (any (null . badFields rbinds) data_cons)
423
	    (badFieldsUpd rbinds)		`thenTc_`
sof's avatar
sof committed
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480
	-- STEP 3
	-- Typecheck the update bindings.
	-- (Do this after checking for bad fields in case there's a field that
	--  doesn't match the constructor.)
    let
	result_record_ty = applyTyCon tycon result_inst_tys
    in
    tcRecordBinds result_record_ty rbinds	`thenTc` \ (rbinds', rbinds_lie) ->

	-- STEP 4
	-- Use the un-updated fields to find a vector of booleans saying
	-- which type arguments must be the same in updatee and result.
	--
	-- WARNING: this code assumes that all data_cons in a common tycon
	-- have FieldLabels abstracted over the same tyvars.
    let
	upd_field_lbls      = [recordSelectorFieldLabel sel_id | (RealId sel_id, _, _) <- rbinds']
	con_field_lbls_s    = map dataConFieldLabels data_cons

		-- A constructor is only relevant to this process if
		-- it contains all the fields that are being updated
	relevant_field_lbls_s      = filter is_relevant con_field_lbls_s
	is_relevant con_field_lbls = all (`elem` con_field_lbls) upd_field_lbls

	non_upd_field_lbls  = concat relevant_field_lbls_s `minusList` upd_field_lbls
	common_tyvars       = tyVarsOfTypes (map fieldLabelType non_upd_field_lbls)

	mk_inst_ty (tyvar, result_inst_ty) 
	  | tyvar `elementOfTyVarSet` common_tyvars = returnNF_Tc result_inst_ty	-- Same as result type
	  | otherwise			            = newTyVarTy mkBoxedTypeKind	-- Fresh type
    in
    mapNF_Tc mk_inst_ty (zip con_tyvars result_inst_tys)	`thenNF_Tc` \ inst_tys ->

	-- STEP 5
	-- Typecheck the expression to be updated
    tcExpr record_expr					`thenTc` \ (record_expr', record_lie, record_ty) ->
    unifyTauTy (applyTyCon tycon inst_tys) record_ty	`thenTc_`
    

	-- STEP 6
	-- Figure out the LIE we need.  We have to generate some 
	-- dictionaries for the data type context, since we are going to
	-- do some construction.
	--
	-- What dictionaries do we need?  For the moment we assume that all
	-- data constructors have the same context, and grab it from the first
	-- constructor.  If they have varying contexts then we'd have to 
	-- union the ones that could participate in the update.
    let
	(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
	inst_env = zipEqual "tcExpr:RecordUpd" tyvars result_inst_tys
    in
    tcInstTheta inst_env theta			`thenNF_Tc` \ theta' ->
    newDicts RecordUpdOrigin theta'		`thenNF_Tc` \ (con_lie, dicts) ->

	-- Phew!
    returnTc (RecordUpdOut record_expr' result_record_ty dicts rbinds', 
481
	      con_lie `plusLIE` record_lie `plusLIE` rbinds_lie, 
sof's avatar
sof committed
482 483
	      result_record_ty)

484

485 486
tcExpr (ArithSeqIn seq@(From expr))
  = tcExpr expr					`thenTc`    \ (expr', lie1, ty) ->
487

488 489 490
    tcLookupGlobalValueByKey enumFromClassOpKey	`thenNF_Tc` \ sel_id ->
    newMethod (ArithSeqOrigin seq)
	      (RealId sel_id) [ty]		`thenNF_Tc` \ (lie2, enum_from_id) ->
491

492 493 494
    returnTc (ArithSeqOut (HsVar enum_from_id) (From expr'),
	      lie1 `plusLIE` lie2,
	      mkListTy ty)
495

496 497 498 499 500 501 502 503 504 505 506 507
tcExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2))
  = tcExpr expr1		`thenTc`    \ (expr1',lie1,ty1) ->
    tcExpr expr2		`thenTc`    \ (expr2',lie2,ty2) ->

    tcAddErrCtxt (arithSeqCtxt in_expr) $
    unifyTauTyList [ty1, ty2] 				`thenTc_`

    tcLookupGlobalValueByKey enumFromThenClassOpKey	`thenNF_Tc` \ sel_id ->
    newMethod (ArithSeqOrigin seq)
	      (RealId sel_id) [ty1]			`thenNF_Tc` \ (lie3, enum_from_then_id) ->

    returnTc (ArithSeqOut (HsVar enum_from_then_id)
508
			   (FromThen expr1' expr2'),
509
	      lie1 `plusLIE` lie2 `plusLIE` lie3,
510 511
	      mkListTy ty1)

512 513 514
tcExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2))
  = tcExpr expr1		`thenTc`    \ (expr1',lie1,ty1) ->
    tcExpr expr2		`thenTc`    \ (expr2',lie2,ty2) ->
515

516 517 518 519 520 521 522 523 524 525
    tcAddErrCtxt (arithSeqCtxt in_expr) $
    unifyTauTyList [ty1,ty2]	`thenTc_`

    tcLookupGlobalValueByKey enumFromToClassOpKey	`thenNF_Tc` \ sel_id ->
    newMethod (ArithSeqOrigin seq)
	      (RealId sel_id) [ty1] 		`thenNF_Tc` \ (lie3, enum_from_to_id) ->

    returnTc (ArithSeqOut (HsVar enum_from_to_id)
			  (FromTo expr1' expr2'),
	      lie1 `plusLIE` lie2 `plusLIE` lie3,
526 527
	       mkListTy ty1)

528 529 530 531
tcExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3))
  = tcExpr expr1		`thenTc`    \ (expr1',lie1,ty1) ->
    tcExpr expr2		`thenTc`    \ (expr2',lie2,ty2) ->
    tcExpr expr3		`thenTc`    \ (expr3',lie3,ty3) ->
532

533 534
    tcAddErrCtxt  (arithSeqCtxt in_expr) $
    unifyTauTyList [ty1,ty2,ty3]			`thenTc_`
535

536 537 538 539 540
    tcLookupGlobalValueByKey enumFromThenToClassOpKey	`thenNF_Tc` \ sel_id ->
    newMethod (ArithSeqOrigin seq)
	      (RealId sel_id) [ty1]			`thenNF_Tc` \ (lie4, eft_id) ->

    returnTc (ArithSeqOut (HsVar eft_id)
541
			   (FromThenTo expr1' expr2' expr3'),
542 543
	      lie1 `plusLIE` lie2 `plusLIE` lie3 `plusLIE` lie4,
	      mkListTy ty1)
544 545 546 547 548 549 550 551 552
\end{code}

%************************************************************************
%*									*
\subsection{Expressions type signatures}
%*									*
%************************************************************************

\begin{code}
553 554
tcExpr in_expr@(ExprWithTySig expr poly_ty)
 = 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 561 562
   let
	(sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig'
   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 575 576 577 578 579 580 581 582 583

	-- If everything is ok, return the stuff unchanged, except for
	-- the effect of any substutions etc.  We simply discard the
	-- result of the tcSimplifyAndCheck, except for any default
	-- resolution it may have done, which is recorded in the
	-- substitution.
   returnTc (texpr, lie, tau_ty)
\end{code}

%************************************************************************
%*									*
584
\subsection{@tcApp@ typchecks an application}
585 586 587
%*									*
%************************************************************************

588 589 590 591 592
\begin{code}
tcApp :: RenamedHsExpr -> [RenamedHsExpr]   -- Function and args
      -> TcM s (TcExpr s, [TcExpr s],	    -- Translated fun and args
		LIE s,
		TcType s)		    -- Type of the application
593

594 595 596 597 598
tcApp fun args
  = 	-- First type-check the function
	-- In the HsVar case we go straight to tcId to avoid hitting the
	-- rank-2 check, which we check later here anyway
    (case fun of
599
	HsVar name -> tcId name	`thenNF_Tc` \ stuff -> returnTc stuff
600 601
	other	   -> tcExpr fun
    )					`thenTc` \ (fun', lie_fun, fun_ty) ->
602

603
    tcApp_help fun 1 fun_ty args	`thenTc` \ (args', lie_args, res_ty) ->
604

605 606 607 608
    -- Check that the result type doesn't have any nested for-alls.
    -- For example, a "build" on its own is no good; it must be applied to something.
    checkTc (isTauTy res_ty)
	    (lurkingRank2Err fun fun_ty) `thenTc_`
609

610
    returnTc (fun', args', lie_fun `plusLIE` lie_args, res_ty)
611 612


613 614 615 616 617 618
tcApp_help :: RenamedHsExpr -> Int	-- Function and arg position, used in error message(s)
	   -> TcType s			-- The type of the function
	   -> [RenamedHsExpr]		-- Arguments
	   -> TcM s ([TcExpr s],		-- Typechecked args
		     LIE s,
		     TcType s)		-- Result type of the application
619

620 621
tcApp_help orig_fun arg_no fun_ty []
  = returnTc ([], emptyLIE, fun_ty)
622

623 624 625 626 627 628 629
tcApp_help orig_fun arg_no fun_ty all_args@(arg:args)
  = 	-- Expect the function to have type A->B
    tcAddErrCtxt (tooManyArgsCtxt orig_fun) (
	    unifyFunTy fun_ty
    )							`thenTc` \ (expected_arg_ty, result_ty) ->

	-- Type check the argument
630
    tcAddErrCtxt (funAppCtxt orig_fun arg_no arg) (
631 632
		tcArg expected_arg_ty arg
    )					 		`thenTc` \ (arg', lie_arg) ->
633

634
	-- Do the other args
635 636
    tcApp_help orig_fun (arg_no+1) result_ty args	`thenTc` \ (args', lie_args, res_ty) ->

637 638
	-- Done
    returnTc (arg':args', lie_arg `plusLIE` lie_args, res_ty)
639

640 641 642
\end{code}

\begin{code}
643 644 645 646 647 648 649 650 651 652 653 654 655 656
tcArg :: TcType s			-- Expected arg type
      -> RenamedHsExpr			-- Actual argument
      -> TcM s (TcExpr s, LIE s)	-- Resulting argument and LIE

tcArg expected_arg_ty arg
  | not (maybeToBool (getForAllTy_maybe expected_arg_ty))
  = 	-- The ordinary, non-rank-2 polymorphic case
    tcExpr arg					`thenTc` \ (arg', lie_arg, actual_arg_ty) ->
    unifyTauTy expected_arg_ty actual_arg_ty	`thenTc_`
    returnTc (arg', lie_arg)

  | otherwise
  = 	-- Ha!  The argument type of the function is a for-all type,
	-- An example of rank-2 polymorphism.
657

658 659 660 661
	-- No need to instantiate the argument type... it's must be the result
	-- of instantiating a function involving rank-2 polymorphism, so there
	-- isn't any danger of using the same tyvars twice
	-- The argument type shouldn't be overloaded type (hence ASSERT)
662 663 664 665

	-- To ensure that the forall'd type variables don't get unified with each
	-- other or any other types, we make fresh *signature* type variables
	-- 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 673
	-- Type-check the arg and unify with expected type
    tcExpr arg					`thenTc` \ (arg', lie_arg, actual_arg_ty) ->
674
    unifyTauTy sig_tau actual_arg_ty		`thenTc_`
675 676 677 678 679 680 681 682 683 684 685

	-- Check that the arg_tyvars havn't been constrained
	-- The interesting bit here is that we must include the free variables
	-- of the expected arg ty.  Here's an example:
	--	 runST (newVar True)
	-- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))
	-- for (newVar True), with s fresh.  Then we unify with the runST's arg type
	-- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.
	-- So now s' isn't unconstrained because it's linked to a.
	-- Conclusion: include the free vars of the expected arg type in the
	-- list of "free vars" for the signature check.
686

687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702
    tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) (
	tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) (
		checkSigTyVars sig_tyvars sig_tau
	)						`thenTc_`

	    -- Check that there's no overloading involved
	    -- Even if there isn't, there may be some Insts which mention the expected_tyvars,
	    -- but which, on simplification, don't actually need a dictionary involving
	    -- the tyvar.  So we have to do a proper simplification right here.
	tcSimplifyRank2 (mkTyVarSet sig_tyvars) 
			lie_arg				`thenTc` \ (free_insts, inst_binds) ->

	    -- This HsLet binds any Insts which came out of the simplification.
	    -- It's a bit out of place here, but using AbsBind involves inventing
	    -- a couple of new names which seems worse.
	returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts)
703 704
    )
  where
sof's avatar
sof committed
705
    mk_binds inst_binds = MonoBind inst_binds [] nonRecursive
706 707 708 709 710 711 712 713 714
\end{code}

%************************************************************************
%*									*
\subsection{@tcId@ typchecks an identifier occurrence}
%*									*
%************************************************************************

\begin{code}
715
tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
716

717 718
tcId name
  = 	-- Look up the Id and instantiate its type
719 720
    tcLookupLocalValue name	`thenNF_Tc` \ maybe_local ->

721 722
    case maybe_local of
      Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id)
723

724 725 726 727 728 729
      Nothing ->    tcLookupGlobalValue name	`thenNF_Tc` \ id ->
		    tcInstType [] (idType id)	`thenNF_Tc` \ inst_ty ->
		    let
			(tyvars, rho) = splitForAllTy inst_ty 
		    in
		    instantiate_it2 (RealId id) tyvars rho
730

731 732 733 734 735 736 737 738 739 740 741 742
  where
	-- The instantiate_it loop runs round instantiating the Id.
	-- It has to be a loop because we are now prepared to entertain
	-- types like
	--		f:: forall a. Eq a => forall b. Baz b => tau
	-- We want to instantiate this to
	--		f2::tau		{f2 = f1 b (Baz b), f1 = f a (Eq a)}
    instantiate_it tc_id_occ ty
      = tcInstTcType ty		`thenNF_Tc` \ (tyvars, rho) ->
	instantiate_it2 tc_id_occ tyvars rho

    instantiate_it2 tc_id_occ tyvars rho
sof's avatar
sof committed
743 744 745 746 747 748
      = tcSplitRhoTy rho				`thenNF_Tc` \ (theta, tau) ->
	if null theta then 	-- Is it overloaded?
		returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
	else
		-- Yes, it's overloaded
	newMethodWithGivenTy (OccurrenceOf tc_id_occ)
749 750 751 752 753 754 755
			     tc_id_occ arg_tys rho	`thenNF_Tc` \ (lie1, meth_id) ->
	instantiate_it meth_id tau			`thenNF_Tc` \ (expr, lie2, final_tau) ->
	returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)

      where
	arg_tys	      = mkTyVarTys tyvars
\end{code}
756

757 758 759 760 761 762 763
%************************************************************************
%*									*
\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
%*									*
%************************************************************************

\begin{code}
764
tcDoStmts do_or_lc stmts src_loc
765 766
  =	-- get the Monad and MonadZero classes
	-- create type consisting of a fresh monad tyvar
sof's avatar
sof committed
767
    ASSERT( not (null stmts) )
768 769 770
    tcAddSrcLoc src_loc	$
    newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind)	`thenNF_Tc` \ m ->

sof's avatar
sof committed
771 772 773 774 775 776 777 778 779 780 781
    let
      tc_stmts []	    = returnTc (([], error "tc_stmts"), emptyLIE)
      tc_stmts (stmt:stmts) = tcStmt tcExpr do_or_lc (mkAppTy m) combine_stmts stmt $
			      tc_stmts stmts

      combine_stmts stmt@(ReturnStmt _) (Just ty) ([], _) = ([stmt], ty)
      combine_stmts stmt@(ExprStmt e _) (Just ty) ([], _) = ([stmt], ty)
      combine_stmts stmt 		_ 	  ([], _) = panic "Bad last stmt tcDoStmts"
      combine_stmts stmt		_     (stmts, ty) = (stmt:stmts, ty)
    in
    tc_stmts stmts	`thenTc` \ ((stmts', result_ty), final_lie) ->
782 783

	-- Build the then and zero methods in case we need them
sof's avatar
sof committed
784 785 786 787 788 789 790
	-- It's important that "then" and "return" appear just once in the final LIE,
	-- not only for typechecker efficiency, but also because otherwise during
	-- simplification we end up with silly stuff like
	--	then = case d of (t,r) -> t
	--	then = then
	-- where the second "then" sees that it already exists in the "available" stuff.
	--
791
    tcLookupGlobalValueByKey returnMClassOpKey	`thenNF_Tc` \ return_sel_id ->
792 793 794
    tcLookupGlobalValueByKey thenMClassOpKey	`thenNF_Tc` \ then_sel_id ->
    tcLookupGlobalValueByKey zeroClassOpKey	`thenNF_Tc` \ zero_sel_id ->
    newMethod DoOrigin
795 796 797
	      (RealId return_sel_id) [m]	`thenNF_Tc` \ (return_lie, return_id) ->
    newMethod DoOrigin
	      (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
sof's avatar
sof committed
801 802 803
      monad_lie = then_lie `plusLIE` return_lie `plusLIE` perhaps_zero_lie
      perhaps_zero_lie | all failure_free stmts' = emptyLIE
		       | otherwise		 = zero_lie
804

sof's avatar
sof committed
805 806 807 808
      failure_free (BindStmt pat _ _) = failureFreePat pat
      failure_free (GuardStmt _ _)    = False
      failure_free other_stmt	      = True
    in
809
    returnTc (HsDoOut do_or_lc stmts' return_id then_id zero_id result_ty src_loc,
sof's avatar
sof committed
810
	      final_lie `plusLIE` monad_lie,
811
	      result_ty)
812 813
\end{code}

sof's avatar
sof committed
814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890
\begin{code}
tcStmt :: (RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s))	-- This is tcExpr
				-- The sole, disgusting, reason for this parameter
				-- is to get the effect of polymorphic recursion
				-- ToDo: rm when booting with Haskell 1.3
       -> DoOrListComp
       -> (TcType s -> TcType s)		-- Relationship type of pat and rhs in pat <- rhs
       -> (TcStmt s -> Maybe (TcType s) -> thing -> thing)
       -> RenamedStmt
       -> TcM s (thing, LIE s)
       -> TcM s (thing, LIE s)

tcStmt tc_expr do_or_lc m combine stmt@(ReturnStmt exp) do_next
  = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
    tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
	tc_expr exp			 `thenTc`    \ (exp', exp_lie, exp_ty) ->
	returnTc (ReturnStmt exp', exp_lie, m exp_ty)
    )					`thenTc` \ (stmt', stmt_lie, stmt_ty) ->
    do_next				`thenTc` \ (thing', thing_lie) ->
    returnTc (combine stmt' (Just stmt_ty) thing',
  	      stmt_lie `plusLIE` thing_lie)

tcStmt tc_expr do_or_lc m combine stmt@(GuardStmt exp src_loc) do_next
  = ASSERT( case do_or_lc of { DoStmt -> False; ListComp -> True } )
    tcAddSrcLoc src_loc 		(
    tcSetErrCtxt (stmtCtxt do_or_lc stmt) (
  	tc_expr exp	 		`thenTc`    \ (exp', exp_lie, exp_ty) ->
  	unifyTauTy boolTy exp_ty	`thenTc_`
  	returnTc (GuardStmt exp' src_loc, exp_lie)
    ))					`thenTc` \ (stmt', stmt_lie) ->
    do_next				`thenTc` \ (thing', thing_lie) ->
    returnTc (combine stmt' Nothing thing',
  	      stmt_lie `plusLIE` thing_lie)

tcStmt tc_expr do_or_lc m combine stmt@(ExprStmt exp src_loc) do_next
  = ASSERT( case do_or_lc of { DoStmt -> True; ListComp -> False } )
    tcAddSrcLoc src_loc 		(
    tcSetErrCtxt (stmtCtxt do_or_lc stmt)	(
  	tc_expr exp			`thenTc`    \ (exp', exp_lie, exp_ty) ->
  	-- Check that exp has type (m tau) for some tau (doesn't matter what)
  	newTyVarTy mkTypeKind		`thenNF_Tc` \ tau ->
        unifyTauTy (m tau) exp_ty	`thenTc_`
  	returnTc (ExprStmt exp' src_loc, exp_lie, exp_ty)
    ))					`thenTc` \ (stmt',  stmt_lie, stmt_ty) ->
    do_next				`thenTc` \ (thing', thing_lie) ->
    returnTc (combine stmt' (Just stmt_ty) thing',
  	      stmt_lie `plusLIE` thing_lie)

tcStmt tc_expr do_or_lc m combine stmt@(BindStmt pat exp src_loc) do_next
  = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ ->
    tcAddSrcLoc src_loc		(
    tcSetErrCtxt (stmtCtxt do_or_lc stmt)	(
  	tcPat pat			`thenTc`    \ (pat', pat_lie, pat_ty) ->  
      	tc_expr exp			`thenTc`    \ (exp', exp_lie, exp_ty) ->
  	unifyTauTy (m pat_ty) exp_ty	`thenTc_`

  	-- NB: the environment has been extended with the new binders
  	-- which the rhs can't "see", but the renamer should have made
  	-- sure that everything is distinct by now, so there's no problem.
  	-- Putting the tcExpr before the newMonoIds messes up the nesting
  	-- of error contexts, so I didn't  bother

  	returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie)
    ))					`thenTc` \ (stmt', stmt_lie) ->
    do_next				`thenTc` \ (thing', thing_lie) ->
    returnTc (combine stmt' Nothing thing',
  	      stmt_lie `plusLIE` thing_lie)

tcStmt tc_expr do_or_lc m combine (LetStmt binds) do_next
     = tcBindsAndThen		-- No error context, but a binding group is
  	combine'		-- rather a large thing for an error context anyway
  	binds
  	do_next
     where
      	combine' binds' thing' = combine (LetStmt binds') Nothing thing'
\end{code}

891 892 893 894 895 896
%************************************************************************
%*									*
\subsection{Record bindings}
%*									*
%************************************************************************

897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929
Game plan for record bindings
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
For each binding 
	field = value
1. look up "field", to find its selector Id, which must have type
	forall a1..an. T a1 .. an -> tau
   where tau is the type of the field.  

2. Instantiate this type

3. Unify the (T a1 .. an) part with the "expected result type", which
   is passed in.  This checks that all the field labels come from the
   same type.

4. Type check the value using tcArg, passing tau as the expected
   argument type.

This extends OK when the field types are universally quantified.

Actually, to save excessive creation of fresh type variables,
we 
	
\begin{code}
tcRecordBinds
	:: TcType s		-- Expected type of whole record
	-> RenamedRecordBinds
	-> TcM s (TcRecordBinds s, LIE s)

tcRecordBinds expected_record_ty rbinds
  = mapAndUnzipTc do_bind rbinds	`thenTc` \ (rbinds', lies) ->
    returnTc (rbinds', plusLIEs lies)
  where
    do_bind (field_label, rhs, pun_flag)
930
      = tcLookupGlobalValue field_label	`thenNF_Tc` \ sel_id ->
sof's avatar
sof committed
931 932 933 934 935
	ASSERT( isRecordSelector sel_id )
		-- This lookup and assertion will surely succeed, because
		-- we check that the fields are indeed record selectors
		-- before calling tcRecordBinds

936
	tcInstId sel_id			`thenNF_Tc` \ (_, _, tau) ->
937 938 939 940 941 942 943 944 945 946 947 948

		-- Record selectors all have type
		-- 	forall a1..an.  T a1 .. an -> tau
	ASSERT( maybeToBool (getFunTy_maybe tau) )
	let
		-- Selector must have type RecordType -> FieldType
	  Just (record_ty, field_ty) = getFunTy_maybe tau
	in
	unifyTauTy expected_record_ty record_ty		`thenTc_`
	tcArg field_ty rhs				`thenTc` \ (rhs', lie) ->
	returnTc ((RealId sel_id, rhs', pun_flag), lie)

sof's avatar
sof committed
949 950 951 952 953 954
badFields rbinds data_con
  = [field_name | (field_name, _, _) <- rbinds,
		  not (field_name `elem` field_names)
    ]
  where
    field_names = map fieldLabelName (dataConFieldLabels data_con)
955 956
\end{code}

957 958 959 960 961
%************************************************************************
%*									*
\subsection{@tcExprs@ typechecks a {\em list} of expressions}
%*									*
%************************************************************************
962 963

\begin{code}
964 965 966 967 968 969 970 971
tcExprs :: [RenamedHsExpr] -> TcM s ([TcExpr s], LIE s, [TcType s])

tcExprs [] = returnTc ([], emptyLIE, [])
tcExprs (expr:exprs)
 = tcExpr  expr			`thenTc` \ (expr',  lie1, ty) ->
   tcExprs exprs		`thenTc` \ (exprs', lie2, tys) ->
   returnTc (expr':exprs', lie1 `plusLIE` lie2, ty:tys)
\end{code}
972

973 974 975 976 977 978 979 980

% =================================================

Errors and contexts
~~~~~~~~~~~~~~~~~~~

Mini-utils:
\begin{code}
sof's avatar
sof committed
981 982
pp_nest_hang :: String -> Doc -> Doc
pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
983
\end{code}
984 985 986 987

Boring and alphabetical:
\begin{code}
arithSeqCtxt expr sty
sof's avatar
sof committed
988
  = hang (ptext SLIT("In an arithmetic sequence:")) 4 (ppr sty expr)
989 990

branchCtxt b1 b2 sty
sof's avatar
sof committed
991
  = sep [ptext SLIT("In the branches of a conditional:"),
992 993 994 995
	   pp_nest_hang "`then' branch:" (ppr sty b1),
	   pp_nest_hang "`else' branch:" (ppr sty b2)]

caseCtxt expr sty
sof's avatar
sof committed
996
  = hang (ptext SLIT("In a case expression:")) 4 (ppr sty expr)
997 998

exprSigCtxt expr sty
sof's avatar
sof committed
999
  = hang (ptext SLIT("In an expression with a type signature:"))
1000 1001 1002
	 4 (ppr sty expr)

listCtxt expr sty
sof's avatar
sof committed
1003
  = hang (ptext SLIT("In a list expression:")) 4 (ppr sty expr)
1004 1005

predCtxt expr sty
sof's avatar
sof committed
1006
  = hang (ptext SLIT("In a predicate expression:")) 4 (ppr sty expr)
1007 1008

sectionRAppCtxt expr sty
sof's avatar
sof committed
1009
  = hang (ptext SLIT("In a right section:")) 4 (ppr sty expr)
1010 1011

sectionLAppCtxt expr sty
sof's avatar
sof committed
1012
  = hang (ptext SLIT("In a left section:")) 4 (ppr sty expr)
1013 1014

funAppCtxt fun arg_no arg sty
sof's avatar
sof committed
1015 1016
  = hang (hsep [ ptext SLIT("In the"), speakNth arg_no, ptext SLIT("argument of"), 
		    ppr sty fun <> text ", namely"])
1017
	 4 (pprParendExpr sty arg)
1018

1019
stmtCtxt ListComp stmt sty
sof's avatar
sof committed
1020
  = hang (ptext SLIT("In a list-comprehension qualifer:")) 
1021
         4 (ppr sty stmt)
1022

1023
stmtCtxt DoStmt stmt sty
sof's avatar
sof committed
1024
  = hang (ptext SLIT("In a do statement:")) 
1025 1026
         4 (ppr sty stmt)

1027
tooManyArgsCtxt f sty
sof's avatar
sof committed
1028
  = hang (ptext SLIT("Too many arguments in an application of the function"))
1029 1030 1031
	 4 (ppr sty f)

lurkingRank2Err fun fun_ty sty
sof's avatar
sof committed
1032 1033 1034
  = hang (hsep [ptext SLIT("Illegal use of"), ppr sty fun])
	 4 (vcat [text "It is applied to too few arguments,", 
		      ptext SLIT("so that the result type has for-alls in it")])
1035 1036

rank2ArgCtxt arg expected_arg_ty sty
sof's avatar
sof committed
1037 1038
  = hang (ptext SLIT("In a polymorphic function argument:"))
	 4 (sep [(<>) (ppr sty arg) (ptext SLIT(" ::")),
1039 1040
		   ppr sty expected_arg_ty])

1041
badFieldsUpd rbinds sty
sof's avatar
sof committed
1042
  = hang (ptext SLIT("No constructor has all these fields:"))
1043 1044 1045 1046
	 4 (interpp'SP sty fields)
  where
    fields = [field | (field, _, _) <- rbinds]

sof's avatar
sof committed
1047
recordUpdCtxt sty = ptext SLIT("In a record update construct")
1048

sof's avatar
sof committed
1049 1050 1051 1052 1053 1054
badFieldsCon con fields sty
  = hsep [ptext SLIT("Constructor"), 		ppr sty con,
	   ptext SLIT("does not have field(s)"), interpp'SP sty fields]

notSelector field sty
  = hsep [ppr sty field, ptext SLIT("is not a record selector")]
1055
\end{code}