HsExpr.lhs 24.6 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5 6 7 8
%
\section[HsExpr]{Abstract Haskell syntax: expressions}

\begin{code}
module HsExpr where

9
#include "HsVersions.h"
10 11

-- friends:
12
import HsDecls		( HsGroup )
13
import HsBinds		( HsBinds(..), nullBinds )
14
import HsPat		( Pat )
15
import HsLit		( HsLit, HsOverLit )
16
import HsTypes		( HsType, PostTcType, SyntaxName )
17
import HsImpExp		( isOperator, pprHsVar )
18 19

-- others:
20
import ForeignCall	( Safety )
21
import PprType		( pprParendType )
22
import Type		( Type, TyThing )
23 24
import Var		( TyVar, Id )
import Name		( Name )
25
import DataCon		( DataCon )
26
import CStrings		( CLabelString, pprCLabelString )
27
import BasicTypes	( IPName, Boxity, tupleParens, Fixity(..) )
28
import SrcLoc		( SrcLoc )
29
import Outputable	
30
import FastString
31 32 33 34 35 36 37 38 39
\end{code}

%************************************************************************
%*									*
\subsection{Expressions proper}
%*									*
%************************************************************************

\begin{code}
40
data HsExpr id
41
  = HsVar	id		-- variable
42
  | HsIPVar	(IPName id)	-- implicit parameter
43
  | HsOverLit	HsOverLit	-- Overloaded literals; eliminated by type checker
44
  | HsLit	HsLit		-- Simple (non-overloaded) literals
45

46 47 48
  | HsLam	(Match  id)	-- lambda
  | HsApp	(HsExpr id)	-- application
		(HsExpr id)
49

50
  -- Operator applications:
51 52
  -- NB Bracketed ops such as (+) come out as Vars.

53 54 55
  -- NB We need an expr for the operator in an OpApp/Section since
  -- the typechecker may need to apply the operator to a few types.

56 57
  | OpApp	(HsExpr id)	-- left operand
		(HsExpr id)	-- operator
58
		Fixity				-- Renamer adds fixity; bottom until then
59
		(HsExpr id)	-- right operand
60

61
  -- We preserve prefix negation and parenthesis for the precedence parser.
62
  -- They are eventually removed by the type checker.
63

64
  | NegApp	(HsExpr id)	-- negated expr
65
		SyntaxName	-- Name of 'negate' (see RnEnv.lookupSyntaxName)
66

67
  | HsPar	(HsExpr id)	-- parenthesised expr
68

69 70 71 72
  | SectionL	(HsExpr id)	-- operand
		(HsExpr id)	-- operator
  | SectionR	(HsExpr id)	-- operator
		(HsExpr id)	-- operand
73
				
74 75
  | HsCase	(HsExpr id)
		[Match id]
76 77
		SrcLoc

78 79 80
  | HsIf	(HsExpr id)	--  predicate
		(HsExpr id)	--  then part
		(HsExpr id)	--  else part
81 82
		SrcLoc

83 84
  | HsLet	(HsBinds id)	-- let(rec)
		(HsExpr  id)
85

86 87
  | HsDo	(HsStmtContext Name)	-- The parameterisation is unimportant
					-- because in this context we never use
88
					-- the PatGuard or ParStmt variant
89
		[Stmt id]	-- "do":one or more stmts
90
		[id]		-- Ids for [return,fail,>>=,>>]
91
				--	Brutal but simple
92 93
				-- Before type checking, used for rebindable syntax
		PostTcType	-- Type of the whole expression
94 95 96
		SrcLoc

  | ExplicitList		-- syntactic list
97
		PostTcType	-- Gives type of components of list
98
		[HsExpr id]
99

chak's avatar
chak committed
100 101
  | ExplicitPArr		-- syntactic parallel array: [:e1, ..., en:]
		PostTcType	-- type of elements of the parallel array
102
		[HsExpr id]
chak's avatar
chak committed
103

104
  | ExplicitTuple		-- tuple
105
		[HsExpr id]
106 107 108
				-- NB: Unit is ExplicitTuple []
				-- for tuples, we can get the types
				-- direct from the components
109
		Boxity
110 111


112 113
	-- Record construction
  | RecordCon	id				-- The constructor
114
		(HsRecordBinds id)
sof's avatar
sof committed
115

116
  | RecordConOut DataCon
117 118
		(HsExpr id)		-- Data con Id applied to type args
		(HsRecordBinds id)
119 120


121
	-- Record update
122 123
  | RecordUpd	(HsExpr id)
		(HsRecordBinds id)
124

125
  | RecordUpdOut (HsExpr id)	-- TRANSLATION
126
		 Type			-- Type of *input* record
127
		 Type			-- Type of *result* record (may differ from
128
					-- 	type of input record)
129
		 (HsRecordBinds id)
130

131
  | ExprWithTySig			-- signature binding
132
		(HsExpr id)
133
		(HsType id)
134
  | ArithSeqIn				-- arithmetic sequence
135
		(ArithSeqInfo id)
136
  | ArithSeqOut
137 138
		(HsExpr id)		-- (typechecked, of course)
		(ArithSeqInfo id)
chak's avatar
chak committed
139
  | PArrSeqIn           		-- arith. sequence for parallel array
140
		(ArithSeqInfo id)	-- [:e1..e2:] or [:e1, e2..e3:]
chak's avatar
chak committed
141
  | PArrSeqOut
142 143
		(HsExpr id)		-- (typechecked, of course)
		(ArithSeqInfo id)
144

145
  | HsCCall	CLabelString	-- call into the C world; string is
146
		[HsExpr id]	-- the C function; exprs are the
147
				-- arguments to pass.
148
		Safety		-- True <=> might cause Haskell
149 150 151 152 153 154
				-- garbage-collection (must generate
				-- more paranoid code)
		Bool		-- True <=> it's really a "casm"
				-- NOTE: this CCall is the *boxed*
				-- version; the desugarer will convert
				-- it into the unboxed "ccall#".
155
		PostTcType	-- The result type; will be *bottom*
156 157
				-- until the typechecker gets ahold of it

158
  | HsSCC	FastString	-- "set cost centre" (_scc_) annotation
159 160 161
		(HsExpr id) 	-- expr whose cost is to be measured
		
  -- MetaHaskell Extensions
162
  | HsBracket    (HsBracket id) SrcLoc
163 164 165 166 167

  | HsBracketOut (HsBracket Name)	-- Output of the type checker is the *original*
		 [PendingSplice]	-- renamed expression, plus *typechecked* splices
					-- to be pasted back in by the desugarer

168
  | HsSplice id (HsExpr id) SrcLoc	-- $z  or $(f 4)
169 170
					-- The id is just a unique name to 
					-- identify this splice point
171 172

  | HsReify (HsReify id)		-- reifyType t, reifyDecl i, reifyFixity
173 174
\end{code}

175

176
These constructors only appear temporarily in the parser.
177
The renamer translates them into the Right Thing.
178 179 180 181 182

\begin{code}
  | EWildPat			-- wildcard

  | EAsPat	id		-- as pattern
183
		(HsExpr id)
184

185
  | ELazyPat	(HsExpr id) -- ~ pattern
186 187

  | HsType      (HsType id)     -- Explicit type argument; e.g  f {| Int |} x y
188 189
\end{code}

190 191 192 193
Everything from here on appears only in typechecker output.

\begin{code}
  | TyLam			-- TRANSLATION
194
		[TyVar]
195
		(HsExpr id)
196
  | TyApp			-- TRANSLATION
197
		(HsExpr id) -- generated by Spec
198
		[Type]
199 200 201 202

  -- DictLam and DictApp are "inverses"
  |  DictLam
		[id]
203
		(HsExpr id)
204
  |  DictApp
205
		(HsExpr id)
206 207
		[id]

208 209
type PendingSplice = (Name, HsExpr Id)	-- Typechecked splices, waiting to be 
					-- pasted back in by the desugarer
210 211
\end{code}

212

213 214 215 216 217 218 219
A @Dictionary@, unless of length 0 or 1, becomes a tuple.  A
@ClassDictLam dictvars methods expr@ is, therefore:
\begin{verbatim}
\ x -> case x of ( dictvars-and-methods-tuple ) -> expr
\end{verbatim}

\begin{code}
220
instance OutputableBndr id => Outputable (HsExpr id) where
221
    ppr expr = pprExpr expr
222 223 224
\end{code}

\begin{code}
225
pprExpr :: OutputableBndr id => HsExpr id -> SDoc
sof's avatar
sof committed
226

227
pprExpr  e = pprDeeper (ppr_expr e)
228
pprBinds b = pprDeeper (ppr b)
229

230
ppr_expr (HsVar v)	 = pprHsVar v
231
ppr_expr (HsIPVar v)     = ppr v
232 233
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
234

235
ppr_expr (HsLam match) = pprMatch LambdaExpr match
236 237

ppr_expr expr@(HsApp e1 e2)
238
  = let (fun, args) = collect_args expr [] in
239
    (ppr_expr fun) <+> (sep (map ppr_expr args))
240 241 242 243
  where
    collect_args (HsApp fun arg) args = collect_args fun (arg:args)
    collect_args fun		 args = (fun, args)

244
ppr_expr (OpApp e1 op fixity e2)
245 246 247 248
  = case op of
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
249 250
    pp_e1 = pprParendExpr e1		-- Add parens to make precedence clear
    pp_e2 = pprParendExpr e2
251 252

    pp_prefixly
253
      = hang (pprExpr op) 4 (sep [pp_e1, pp_e2])
254 255

    pp_infixly v
256
      = sep [pp_e1, hsep [pp_v_op, pp_e2]]
257
      where
258 259 260
	ppr_v = ppr v
        pp_v_op | isOperator ppr_v = ppr_v
		| otherwise        = char '`' <> ppr_v <> char '`'
261
	        -- Put it in backquotes if it's not an operator already
262

263
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
264

265
ppr_expr (HsPar e) = parens (ppr_expr e)
266

267
ppr_expr (SectionL expr op)
268 269 270 271
  = case op of
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
272
    pp_expr = pprParendExpr expr
273

274
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
sof's avatar
sof committed
275
		       4 (hsep [pp_expr, ptext SLIT("x_ )")])
276
    pp_infixly v = parens (sep [pp_expr, ppr v])
277

278
ppr_expr (SectionR op expr)
279 280 281 282
  = case op of
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
283
    pp_expr = pprParendExpr expr
284

285
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
sof's avatar
sof committed
286
		       4 ((<>) pp_expr rparen)
287
    pp_infixly v
288
      = parens (sep [ppr v, pp_expr])
289

290
ppr_expr (HsCase expr matches _)
291
  = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")],
292
	    nest 2 (pprMatches CaseAlt matches) ]
293

294
ppr_expr (HsIf e1 e2 e3 _)
295 296
  = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")],
	   nest 4 (pprExpr e2),
sof's avatar
sof committed
297
	   ptext SLIT("else"),
298
	   nest 4 (pprExpr e3)]
299 300

-- special case: let ... in let ...
301
ppr_expr (HsLet binds expr@(HsLet _ _))
302
  = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
303
	 pprExpr expr]
304

305
ppr_expr (HsLet binds expr)
306
  = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
307
	 hang (ptext SLIT("in"))  2 (ppr expr)]
308

309
ppr_expr (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts
310

311
ppr_expr (ExplicitList _ exprs)
312
  = brackets (fsep (punctuate comma (map ppr_expr exprs)))
313

chak's avatar
chak committed
314
ppr_expr (ExplicitPArr _ exprs)
315
  = pa_brackets (fsep (punctuate comma (map ppr_expr exprs)))
chak's avatar
chak committed
316

317 318
ppr_expr (ExplicitTuple exprs boxity)
  = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs)))
319 320 321 322

ppr_expr (RecordCon con_id rbinds)
  = pp_rbinds (ppr con_id) rbinds
ppr_expr (RecordConOut data_con con rbinds)
323 324 325 326
  = pp_rbinds (ppr con) rbinds

ppr_expr (RecordUpd aexp rbinds)
  = pp_rbinds (pprParendExpr aexp) rbinds
327
ppr_expr (RecordUpdOut aexp _ _ rbinds)
328 329 330
  = pp_rbinds (pprParendExpr aexp) rbinds

ppr_expr (ExprWithTySig expr sig)
331
  = hang (nest 2 (ppr_expr expr) <+> dcolon)
332 333 334 335 336 337 338
	 4 (ppr sig)

ppr_expr (ArithSeqIn info)
  = brackets (ppr info)
ppr_expr (ArithSeqOut expr info)
  = brackets (ppr info)

chak's avatar
chak committed
339
ppr_expr (PArrSeqIn info)
340
  = pa_brackets (ppr info)
chak's avatar
chak committed
341
ppr_expr (PArrSeqOut expr info)
342
  = pa_brackets (ppr info)
chak's avatar
chak committed
343

344 345 346 347
ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e

348
ppr_expr (HsCCall fun args _ is_asm result_ty)
349
  = hang (if is_asm
350 351
	  then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''")
	  else ptext SLIT("_ccall_") <+> pprCLabelString fun)
352
       4 (sep (map pprParendExpr args))
353

354
ppr_expr (HsSCC lbl expr)
355
  = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
356

357
ppr_expr (TyLam tyvars expr)
358 359 360
  = hang (hsep [ptext SLIT("/\\"), 
		hsep (map (pprBndr LambdaBind) tyvars), 
		ptext SLIT("->")])
361
	 4 (ppr_expr expr)
362

363
ppr_expr (TyApp expr [ty])
364
  = hang (ppr_expr expr) 4 (pprParendType ty)
365

366
ppr_expr (TyApp expr tys)
367
  = hang (ppr_expr expr)
368
	 4 (brackets (interpp'SP tys))
369

370
ppr_expr (DictLam dictvars expr)
371 372 373
  = hang (hsep [ptext SLIT("\\{-dict-}"), 
	  	hsep (map (pprBndr LambdaBind) dictvars), 
		ptext SLIT("->")])
374
	 4 (ppr_expr expr)
375

376
ppr_expr (DictApp expr [dname])
377
  = hang (ppr_expr expr) 4 (ppr dname)
378

379
ppr_expr (DictApp expr dnames)
380
  = hang (ppr_expr expr)
381
	 4 (brackets (interpp'SP dnames))
382

383
ppr_expr (HsType id) = ppr id
chak's avatar
chak committed
384

385 386
ppr_expr (HsSplice n e _)    = char '$' <> brackets (ppr n) <> pprParendExpr e
ppr_expr (HsBracket b _)     = pprHsBracket b
387
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps
388
ppr_expr (HsReify r)	     = ppr r
389

chak's avatar
chak committed
390 391
-- add parallel array brackets around a document
--
392 393
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")    
394 395 396 397
\end{code}

Parenthesize unless very simple:
\begin{code}
398
pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc
399

400
pprParendExpr expr
401
  = let
402
	pp_as_was = pprExpr expr
403 404
    in
    case expr of
405
      HsLit l		    -> ppr l
406
      HsOverLit l 	    -> ppr l
407

408
      HsVar _		    -> pp_as_was
409
      HsIPVar _		    -> pp_as_was
410
      ExplicitList _ _      -> pp_as_was
chak's avatar
chak committed
411
      ExplicitPArr _ _      -> pp_as_was
412
      ExplicitTuple _ _	    -> pp_as_was
413 414
      HsPar _		    -> pp_as_was

sof's avatar
sof committed
415
      _			    -> parens pp_as_was
416 417 418 419 420 421 422 423 424
\end{code}

%************************************************************************
%*									*
\subsection{Record binds}
%*									*
%************************************************************************

\begin{code}
425 426 427 428 429 430
type HsRecordBinds id = [(id, HsExpr id)]

recBindFields :: HsRecordBinds id -> [id]
recBindFields rbinds = [field | (field,_) <- rbinds]

pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
431

432
pp_rbinds thing rbinds
sof's avatar
sof committed
433
  = hang thing 
434
	 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds))))
435
  where
436
    pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e]
437 438
\end{code}

439 440


441 442
%************************************************************************
%*									*
443
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
444 445 446
%*									*
%************************************************************************

447 448 449 450 451 452 453 454 455 456 457 458 459 460
@Match@es are sets of pattern bindings and right hand sides for
functions, patterns or case branches. For example, if a function @g@
is defined as:
\begin{verbatim}
g (x,y) = y
g ((x:ys),y) = y+1,
\end{verbatim}
then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@.

It is always the case that each element of an @[Match]@ list has the
same number of @pats@s inside it.  This corresponds to saying that
a function defined by pattern matching must have the same number of
patterns in each equation.

461
\begin{code}
462
data Match id
463
  = Match
464
	[Pat id]		-- The patterns
465 466 467
	(Maybe (HsType id))	-- A type signature for the result of the match
				--	Nothing after typechecking

468
	(GRHSs id)
469 470

-- GRHSs are used both for pattern bindings and for Matches
471 472 473
data GRHSs id	
  = GRHSs [GRHS id]		-- Guarded RHSs
	  (HsBinds id)		-- The where clause
474
	  PostTcType		-- Type of RHS (after type checking)
475

476 477
data GRHS id
  = GRHS  [Stmt id]		-- The RHS is the final ResultStmt
478 479
	  SrcLoc

480
mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id
481
mkSimpleMatch pats rhs rhs_ty locn
482
  = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty)
483

484
unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id]
485
unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
486 487
\end{code}

488 489 490 491
@getMatchLoc@ takes a @Match@ and returns the
source-location gotten from the GRHS inside.
THis is something of a nuisance, but no more.

492
\begin{code}
493
getMatchLoc :: Match id -> SrcLoc
494
getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
495
\end{code}
496

497
We know the list must have at least one @Match@ in it.
498

499
\begin{code}
500
pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc
501 502 503
pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches)

-- Exported to HsBinds, which can't see the defn of HsMatchContext
504
pprFunBind :: (OutputableBndr id) => id -> [Match id] -> SDoc
505 506 507
pprFunBind fun matches = pprMatches (FunRhs fun) matches

-- Exported to HsBinds, which can't see the defn of HsMatchContext
508 509
pprPatBind :: (OutputableBndr id)
	   => Pat id -> GRHSs id -> SDoc
510
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
511 512


513
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
514
pprMatch ctxt (Match pats maybe_ty grhss)
515 516 517
  = pp_name ctxt <+> sep [sep (map ppr pats), 
		     ppr_maybe_ty,
		     nest 2 (pprGRHSs ctxt grhss)]
518
  where
519 520
    pp_name (FunRhs fun) = ppr fun	-- Not pprBndr; the AbsBinds will
					-- have printed the signature
521
    pp_name LambdaExpr   = char '\\'
522
    pp_name other	 = empty
523

524 525 526 527 528
    ppr_maybe_ty = case maybe_ty of
			Just ty -> dcolon <+> ppr ty
			Nothing -> empty


529
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
530
pprGRHSs ctxt (GRHSs grhss binds ty)
531
  = vcat (map (pprGRHS ctxt) grhss)
532 533 534 535 536
    $$
    (if nullBinds binds then empty
     else text "where" $$ nest 4 (pprDeeper (ppr binds)))


537
pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
538

539 540
pprGRHS ctxt (GRHS [ResultStmt expr _] locn)
 =  pp_rhs ctxt expr
541

542 543
pprGRHS ctxt (GRHS guarded locn)
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
544
 where
545 546 547
    ResultStmt expr _ = last guarded	-- Last stmt should be a ResultStmt for guards
    guards	      = init guarded

548
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
549
\end{code}
550 551


552

553 554 555 556 557 558 559
%************************************************************************
%*									*
\subsection{Do stmts and list comprehensions}
%*									*
%************************************************************************

\begin{code}
560 561 562 563 564
data Stmt id
  = BindStmt	(Pat id) (HsExpr id) SrcLoc
  | LetStmt	(HsBinds id)
  | ResultStmt	(HsExpr id)	SrcLoc			-- See notes that follow
  | ExprStmt	(HsExpr id)	PostTcType SrcLoc	-- See notes that follow
565
	-- The type is the *element type* of the expression
566 567 568 569 570 571 572 573 574 575

	-- ParStmts only occur in a list comprehension
  | ParStmt	[[Stmt id]]		-- List comp only: parallel set of quals
  | ParStmtOut	[([id], [Stmt id])]	-- PLC after renaming; the ids are the binders
					-- bound by the stmts

	-- mdo-notation (only exists after renamer)
	-- The ids are a subset of the variables bound by the stmts that
	-- either (a) are used before they are bound in the stmts
	-- or     (b) are used in stmts that follow the RecStmt
576
  | RecStmt  [id]
577
	     [Stmt id] 
578 579 580 581 582
	     [HsExpr id]	-- Post type-checking only; these expressions correspond
				-- 1-to-1 with the [id], and are the expresions that should
				-- be returned by the recursion.  They may not quite be the
				-- Ids themselves, because the Id may be polymorphic, but
				-- the returned thing has to be monomorphic.
583 584
\end{code}

585 586
ExprStmts and ResultStmts are a bit tricky, because what they mean
depends on the context.  Consider the following contexts:
587 588 589

	A do expression of type (m res_ty)
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
590
	* ExprStmt E any_ty:   do { ....; E; ... }
591 592 593
		E :: m any_ty
	  Translation: E >> ...
	
594
	* ResultStmt E:   do { ....; E }
595 596 597 598 599
		E :: m res_ty
	  Translation: E
	
	A list comprehensions of type [elt_ty]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
600
	* ExprStmt E Bool:   [ .. | .... E ]
601 602
			[ .. | ..., E, ... ]
			[ .. | .... | ..., E | ... ]
603 604
		E :: Bool
	  Translation: if E then fail else ...
605 606

	* ResultStmt E:   [ E | ... ]
607 608 609 610 611
		E :: elt_ty
	  Translation: return E
	
	A guard list, guarding a RHS of type rhs_ty
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
612
	* ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
613 614 615
		E :: Bool
	  Translation: if E then fail else ...
	
616
	* ResultStmt E:   f x | ...guards... = E
617 618 619
		E :: rhs_ty
	  Translation: E

chak's avatar
chak committed
620
Array comprehensions are handled like list comprehensions -=chak
621

622
\begin{code}
623
consLetStmt :: HsBinds id -> [Stmt id] -> [Stmt id]
624 625
consLetStmt EmptyBinds stmts = stmts
consLetStmt binds      stmts = LetStmt binds : stmts
626 627 628
\end{code}

\begin{code}
629
instance OutputableBndr id => Outputable (Stmt id) where
630 631
    ppr stmt = pprStmt stmt

632 633
pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
pprStmt (LetStmt binds)       = hsep [ptext SLIT("let"), pprBinds binds]
634
pprStmt (ExprStmt expr _ _)   = ppr expr
635
pprStmt (ResultStmt expr _)   = ppr expr
636 637 638 639
pprStmt (ParStmt stmtss)
 = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (ParStmtOut stmtss)
 = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
640
pprStmt (RecStmt _ segment _) = vcat (map ppr segment)
641

642
pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc
643
pprDo DoExpr stmts   = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts))
644
pprDo MDoExpr stmts  = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts))
chak's avatar
chak committed
645
pprDo ListComp stmts = pprComp brackets   stmts
646
pprDo PArrComp stmts = pprComp pa_brackets stmts
chak's avatar
chak committed
647

648
pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [Stmt id] -> SDoc
chak's avatar
chak committed
649 650 651 652 653 654
pprComp brack stmts = brack $
		      hang (pprExpr expr <+> char '|')
			 4 (interpp'SP quals)
		    where
		      ResultStmt expr _ = last stmts  -- Last stmt should
		      quals	        = init stmts  -- be an ResultStmt
655 656
\end{code}

657 658 659 660 661 662 663 664 665
%************************************************************************
%*									*
		Template Haskell quotation brackets
%*									*
%************************************************************************

\begin{code}
data HsBracket id = ExpBr (HsExpr id)
		  | PatBr (Pat id)
666
		  | DecBr (HsGroup id)
667 668 669 670 671 672 673 674
		  | TypBr (HsType id)

instance OutputableBndr id => Outputable (HsBracket id) where
  ppr = pprHsBracket


pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
675
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
676 677 678 679 680
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)


thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> 
			     pp_body <+> ptext SLIT("|]")
681 682

data HsReify id = Reify    ReifyFlavour id	-- Pre typechecking
683 684 685
		| ReifyOut ReifyFlavour Name	-- Post typechecking
						-- The Name could be the name of
						-- an Id, TyCon, or Class
686 687 688 689 690 691 692 693 694 695 696

data ReifyFlavour = ReifyDecl | ReifyType | ReifyFixity

instance Outputable id => Outputable (HsReify id) where
   ppr (Reify flavour id) = ppr flavour <+> ppr id
   ppr (ReifyOut flavour thing) = ppr flavour <+> ppr thing

instance Outputable ReifyFlavour where
   ppr ReifyDecl   = ptext SLIT("reifyDecl")
   ppr ReifyType   = ptext SLIT("reifyType")
   ppr ReifyFixity = ptext SLIT("reifyFixity")
697 698
\end{code}

699 700 701 702 703 704 705
%************************************************************************
%*									*
\subsection{Enumerations and list comprehensions}
%*									*
%************************************************************************

\begin{code}
706 707 708 709 710 711 712 713 714
data ArithSeqInfo id
  = From	    (HsExpr id)
  | FromThen 	    (HsExpr id)
		    (HsExpr id)
  | FromTo	    (HsExpr id)
		    (HsExpr id)
  | FromThenTo	    (HsExpr id)
		    (HsExpr id)
		    (HsExpr id)
715 716 717
\end{code}

\begin{code}
718
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
719 720 721 722 723
    ppr (From e1)		= hcat [ppr e1, pp_dotdot]
    ppr (FromThen e1 e2)	= hcat [ppr e1, comma, space, ppr e2, pp_dotdot]
    ppr (FromTo e1 e3)	= hcat [ppr e1, pp_dotdot, ppr e3]
    ppr (FromThenTo e1 e2 e3)
      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]
724

sof's avatar
sof committed
725
pp_dotdot = ptext SLIT(" .. ")
726
\end{code}
727 728 729 730 731 732 733 734 735


%************************************************************************
%*									*
\subsection{HsMatchCtxt}
%*									*
%************************************************************************

\begin{code}
736 737 738 739 740 741 742 743
data HsMatchContext id	-- Context of a Match
  = FunRhs id			-- Function binding for f
  | CaseAlt			-- Guard on a case alternative
  | LambdaExpr			-- Pattern of a lambda
  | PatBindRhs			-- Pattern binding
  | RecUpd			-- Record update [used only in DsExpr to tell matchWrapper
				-- 	what sort of runtime error message to generate]
  | StmtCtxt (HsStmtContext id)	-- Pattern of a do-stmt or list comprehension
744 745
  deriving ()

746 747 748 749 750 751
data HsStmtContext id
  = ListComp 
  | DoExpr 
  | MDoExpr				-- Recursive do-expression
  | PArrComp				-- Parallel array comprehension
  | PatGuard (HsMatchContext id)	-- Pattern guard for specified thing
752
  | ParStmtCtxt (HsStmtContext id)	-- A branch of a parallel stmt 
753 754 755
\end{code}

\begin{code}
756
isDoExpr :: HsStmtContext id -> Bool
757 758 759
isDoExpr DoExpr  = True
isDoExpr MDoExpr = True
isDoExpr other   = False
760 761 762
\end{code}

\begin{code}
763 764 765 766
matchSeparator (FunRhs _)   = ptext SLIT("=")
matchSeparator CaseAlt      = ptext SLIT("->") 
matchSeparator LambdaExpr   = ptext SLIT("->") 
matchSeparator PatBindRhs   = ptext SLIT("=") 
767 768
matchSeparator (StmtCtxt _) = ptext SLIT("<-")  
matchSeparator RecUpd       = panic "unused"
769 770 771
\end{code}

\begin{code}
772 773 774 775 776 777 778 779 780 781 782 783 784
pprMatchContext (FunRhs fun) 	  = ptext SLIT("the definition of") <+> quotes (ppr fun)
pprMatchContext CaseAlt	     	  = ptext SLIT("a case alternative")
pprMatchContext RecUpd	     	  = ptext SLIT("a record-update construct")
pprMatchContext PatBindRhs   	  = ptext SLIT("a pattern binding")
pprMatchContext LambdaExpr   	  = ptext SLIT("a lambda abstraction")
pprMatchContext (StmtCtxt ctxt)   = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt

pprMatchRhsContext (FunRhs fun) = ptext SLIT("a right-hand side of function") <+> quotes (ppr fun)
pprMatchRhsContext CaseAlt	= ptext SLIT("the body of a case alternative")
pprMatchRhsContext PatBindRhs	= ptext SLIT("the right-hand side of a pattern binding")
pprMatchRhsContext LambdaExpr	= ptext SLIT("the body of a lambda")
pprMatchRhsContext RecUpd	= panic "pprMatchRhsContext"

785
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
786 787 788 789 790 791 792 793 794 795 796 797
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr          = ptext SLIT("a 'do' expression")
pprStmtContext MDoExpr         = ptext SLIT("an 'mdo' expression")
pprStmtContext ListComp        = ptext SLIT("a list comprehension")
pprStmtContext PArrComp        = ptext SLIT("an array comprehension")

-- Used for the result statement of comprehension
-- e.g. the 'e' in	[ e | ... ]
--	or the 'r' in   f x = r
pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt
pprStmtResultContext other	     = ptext SLIT("the result of") <+> pprStmtContext other

798 799

-- Used to generate the string for a *runtime* error message
800 801 802 803 804 805 806 807 808 809 810
matchContextErrString (FunRhs fun)    	      	 = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt	      	      	 = "case"
matchContextErrString PatBindRhs      	      	 = "pattern binding"
matchContextErrString RecUpd	      	      	 = "record update"
matchContextErrString LambdaExpr      	      	 = "lambda"
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) 	 = "pattern guard"
matchContextErrString (StmtCtxt DoExpr)       	 = "'do' expression"
matchContextErrString (StmtCtxt MDoExpr)      	 = "'mdo' expression"
matchContextErrString (StmtCtxt ListComp)     	 = "list comprehension"
matchContextErrString (StmtCtxt PArrComp)     	 = "array comprehension"
811
\end{code}