HsExpr.lhs 29.8 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 HsPat		( LPat )
14
import HsLit		( HsLit(..), HsOverLit )
15
import HsTypes		( LHsType, PostTcType )
16
import HsImpExp		( isOperator, pprHsVar )
17
18
import HsBinds		( HsLocalBinds, DictBinds, isEmptyLocalBinds,
			  ExprCoFn, pprCoFn )
19
20

-- others:
21
import Type		( Type, pprParendType )
22
23
import Var		( TyVar, Id )
import Name		( Name )
24
import BasicTypes	( IPName, Boxity, tupleParens, Arity, Fixity(..) )
25
import SrcLoc		( Located(..), unLoc )
26
import Outputable	
27
import FastString
28
29
\end{code}

30

31
32
33
34
35
36
37
%************************************************************************
%*									*
\subsection{Expressions proper}
%*									*
%************************************************************************

\begin{code}
38
39
type LHsExpr id = Located (HsExpr id)

40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
-------------------------
-- PostTcExpr is an evidence expression attached to the
-- syntax tree by the type checker (c.f. postTcType)
-- We use a PostTcTable where there are a bunch of pieces of 
-- evidence, more than is convenient to keep individually
type PostTcExpr  = HsExpr Id
type PostTcTable = [(Name, Id)]

noPostTcExpr :: PostTcExpr
noPostTcExpr = HsLit (HsString FSLIT("noPostTcExpr"))

noPostTcTable :: PostTcTable
noPostTcTable = []

-------------------------
-- SyntaxExpr is like PostTcExpr, but it's filled in a little earlier,
-- by the renamer.  It's used for rebindable syntax.  
-- E.g. (>>=) is filled in before the renamer by the appropriate Name
--      for (>>=), and then instantiated by the type checker with its
--	type args tec

type SyntaxExpr id = HsExpr id

noSyntaxExpr :: SyntaxExpr id	-- Before renaming, and sometimes after,
				-- (if the syntax slot makes no sense)
noSyntaxExpr = HsLit (HsString FSLIT("noSyntaxExpr"))


type SyntaxTable id = [(Name, SyntaxExpr id)]
--	*** Currently used only for CmdTop (sigh) ***
-- * Before the renamer, this list is noSyntaxTable
--
-- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
--   For example, for the 'return' op of a monad
--	normal case:		(GHC.Base.return, HsVar GHC.Base.return)
--	with rebindable syntax:	(GHC.Base.return, return_22)
--		where return_22 is whatever "return" is in scope
--
-- * After the type checker, it takes the form [(std_name, <expression>)]
--	where <expression> is the evidence for the method

noSyntaxTable :: SyntaxTable id
noSyntaxTable = []


-------------------------
86
data HsExpr id
87
  = HsVar	id		-- variable
88
  | HsIPVar	(IPName id)	-- implicit parameter
89
  | HsOverLit	(HsOverLit id)	-- Overloaded literals
90
  | HsLit	HsLit		-- Simple (non-overloaded) literals
91

92
93
94
  | HsLam	(MatchGroup  id)	-- Currently always a single match

  | HsApp	(LHsExpr id)		-- Application
95
		(LHsExpr id)
96

97
  -- Operator applications:
98
99
  -- NB Bracketed ops such as (+) come out as Vars.

100
101
102
  -- 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.

103
104
  | OpApp	(LHsExpr id)	-- left operand
		(LHsExpr id)	-- operator
105
		Fixity		-- Renamer adds fixity; bottom until then
106
		(LHsExpr id)	-- right operand
107

108
  | NegApp	(LHsExpr id)	-- negated expr
109
		(SyntaxExpr id)	-- Name of 'negate'
110

111
  | HsPar	(LHsExpr id)	-- parenthesised expr
112

113
114
115
116
  | SectionL	(LHsExpr id)	-- operand
		(LHsExpr id)	-- operator
  | SectionR	(LHsExpr id)	-- operator
		(LHsExpr id)	-- operand
117
				
118
  | HsCase	(LHsExpr id)
119
		(MatchGroup id)
120

121
122
123
  | HsIf	(LHsExpr id)	--  predicate
		(LHsExpr id)	--  then part
		(LHsExpr id)	--  else part
124

125
  | HsLet	(HsLocalBinds id) -- let(rec)
126
		(LHsExpr  id)
127

128
129
  | HsDo	(HsStmtContext Name)	-- The parameterisation is unimportant
					-- because in this context we never use
130
					-- the PatGuard or ParStmt variant
131
		[LStmt id]		-- "do":one or more stmts
132
133
134
		(LHsExpr id)		-- The body; the last expression in the 'do'
					--	     of [ body | ... ] in a list comp
		PostTcType		-- Type of the whole expression
135
136

  | ExplicitList		-- syntactic list
137
		PostTcType	-- Gives type of components of list
138
		[LHsExpr id]
139

chak's avatar
chak committed
140
141
  | ExplicitPArr		-- syntactic parallel array: [:e1, ..., en:]
		PostTcType	-- type of elements of the parallel array
142
		[LHsExpr id]
chak's avatar
chak committed
143

144
  | ExplicitTuple		-- tuple
145
		[LHsExpr id]
146
147
148
				-- NB: Unit is ExplicitTuple []
				-- for tuples, we can get the types
				-- direct from the components
149
		Boxity
150
151


152
	-- Record construction
153
  | RecordCon	(Located id)		-- The constructor.  After type checking
154
					-- it's the dataConWrapId of the constructor
155
		PostTcExpr		-- Data con Id applied to type args
156
		(HsRecordBinds id)
sof's avatar
sof committed
157

158
	-- Record update
159
  | RecordUpd	(LHsExpr id)
160
		(HsRecordBinds id)
161
162
		PostTcType		-- Type of *input* record
		PostTcType		-- Type of *result* record (may differ from
163
					-- 	type of input record)
164

165
  | ExprWithTySig			-- e :: type
166
167
		(LHsExpr id)
		(LHsType id)
168
169
170
171
172

  | ExprWithTySigOut			-- TRANSLATION
		(LHsExpr id)
		(LHsType Name)		-- Retain the signature for round-tripping purposes

173
174
  | ArithSeq				-- arithmetic sequence
		PostTcExpr
175
		(ArithSeqInfo id)
176
177
178

  | PArrSeq	           		-- arith. sequence for parallel array
		PostTcExpr		-- [:e1..e2:] or [:e1, e2..e3:]
179
		(ArithSeqInfo id)
180

181
  | HsSCC	FastString	-- "set cost centre" (_scc_) annotation
182
		(LHsExpr id) 	-- expr whose cost is to be measured
183
184

  | HsCoreAnn   FastString      -- hdaume: core annotation
185
                (LHsExpr id)
186
		
187
  -----------------------------------------------------------
188
  -- MetaHaskell Extensions
189
  | HsBracket    (HsBracket id)
190
191
192
193
194

  | 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

195
  | HsSpliceE (HsSplice id) 
196

197
198
199
  -----------------------------------------------------------
  -- Arrow notation extension

200
201
  | HsProc	(LPat id)		-- arrow abstraction, proc
		(LHsCmdTop id)		-- body of the abstraction
202
203
204
205
206
207
					-- always has an empty stack

  ---------------------------------------
  -- The following are commands, not expressions proper

  | HsArrApp	-- Arrow tail, or arrow application (f -< arg)
208
209
	(LHsExpr id)	-- arrow expression, f
	(LHsExpr id)	-- input expression, arg
210
211
212
213
214
215
	PostTcType	-- type of the arrow expressions f,
			-- of the form a t t', where arg :: t
	HsArrAppType	-- higher-order (-<<) or first-order (-<)
	Bool		-- True => right-to-left (f -< arg)
			-- False => left-to-right (arg >- f)

ross's avatar
ross committed
216
  | HsArrForm	-- Command formation,  (| e cmd1 .. cmdn |)
217
	(LHsExpr id)	-- the operator
218
219
220
221
			-- after type-checking, a type abstraction to be
			-- applied to the type of the local environment tuple
	(Maybe Fixity)	-- fixity (filled in by the renamer), for forms that
			-- were converted from OpApp's by the renamer
222
	[LHsCmdTop id]	-- argument commands
223
224
\end{code}

225

226
These constructors only appear temporarily in the parser.
227
The renamer translates them into the Right Thing.
228
229
230
231

\begin{code}
  | EWildPat			-- wildcard

232
233
  | EAsPat	(Located id)	-- as pattern
		(LHsExpr id)
234

235
  | ELazyPat	(LHsExpr id) -- ~ pattern
236

237
  | HsType      (LHsType id)     -- Explicit type argument; e.g  f {| Int |} x y
238
239
\end{code}

240
241
242
Everything from here on appears only in typechecker output.

\begin{code}
243
244
245
  |  HsCoerce	ExprCoFn 	-- TRANSLATION
		(HsExpr id)

246
type PendingSplice = (Name, LHsExpr Id)	-- Typechecked splices, waiting to be 
247
					-- pasted back in by the desugarer
248
249
250
251
252
253
254
255
256
\end{code}

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}
257
instance OutputableBndr id => Outputable (HsExpr id) where
258
    ppr expr = pprExpr expr
259
260
261
\end{code}

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

264
pprExpr  e = pprDeeper (ppr_expr e)
265

266
267
pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
pprBinds b = pprDeeper (ppr b)
268
269
270

ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
271

272
ppr_expr (HsVar v)	 = pprHsVar v
273
ppr_expr (HsIPVar v)     = ppr v
274
275
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
276
277
278
279
ppr_expr (HsPar e)	 = parens (ppr_lexpr e)

ppr_expr (HsCoreAnn s e)
  = vcat [ptext SLIT("HsCoreAnn") <+> ftext s, ppr_lexpr e]
280

281
282
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
283
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
284
  where
285
286
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
287

288
ppr_expr (OpApp e1 op fixity e2)
289
  = case unLoc op of
290
291
292
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
293
294
    pp_e1 = pprParendExpr e1		-- Add parens to make precedence clear
    pp_e2 = pprParendExpr e2
295
296

    pp_prefixly
297
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
298
299

    pp_infixly v
300
      = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
301

302
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
303

304
ppr_expr (SectionL expr op)
305
  = case unLoc op of
306
307
308
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
309
    pp_expr = pprParendExpr expr
310

311
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
sof's avatar
sof committed
312
		       4 (hsep [pp_expr, ptext SLIT("x_ )")])
313
    pp_infixly v = parens (sep [pp_expr, pprInfix v])
314

315
ppr_expr (SectionR op expr)
316
  = case unLoc op of
317
318
319
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
320
    pp_expr = pprParendExpr expr
321

322
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
sof's avatar
sof committed
323
		       4 ((<>) pp_expr rparen)
324
    pp_infixly v
325
      = parens (sep [pprInfix v, pp_expr])
326

327
328
329
ppr_expr (HsLam matches) 
  = pprMatches LambdaExpr matches

330
331
ppr_expr (HsCase expr matches)
  = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
332
	    nest 2 (pprMatches CaseAlt matches) ]
333

334
335
336
ppr_expr (HsIf e1 e2 e3)
  = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")],
	   nest 4 (ppr e2),
sof's avatar
sof committed
337
	   ptext SLIT("else"),
338
	   nest 4 (ppr e3)]
339
340

-- special case: let ... in let ...
341
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
342
  = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
343
	 ppr_lexpr expr]
344

345
ppr_expr (HsLet binds expr)
346
  = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
347
	 hang (ptext SLIT("in"))  2 (ppr expr)]
348

349
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
350

351
ppr_expr (ExplicitList _ exprs)
352
  = brackets (fsep (punctuate comma (map ppr_lexpr exprs)))
353

chak's avatar
chak committed
354
ppr_expr (ExplicitPArr _ exprs)
355
  = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
356

357
ppr_expr (ExplicitTuple exprs boxity)
358
  = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
359

360
ppr_expr (RecordCon con_id con_expr rbinds)
361
  = pp_rbinds (ppr con_id) rbinds
362

363
ppr_expr (RecordUpd aexp rbinds _ _)
364
365
366
  = pp_rbinds (pprParendExpr aexp) rbinds

ppr_expr (ExprWithTySig expr sig)
367
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
368
	 4 (ppr sig)
369
370
371
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
	 4 (ppr sig)
372

373
374
ppr_expr (ArithSeq expr info) = brackets (ppr info)
ppr_expr (PArrSeq expr info)  = pa_brackets (ppr info)
chak's avatar
chak committed
375

376
ppr_expr EWildPat     = char '_'
377
378
379
380
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e

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

383
384
ppr_expr (HsCoerce co_fn e) = pprCoFn (ppr_expr e) co_fn
ppr_expr (HsType id)	    = ppr id
chak's avatar
chak committed
385

386
387
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
388
389
ppr_expr (HsBracketOut e []) = ppr e	
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps
390

391
392
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
  = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
393

394
395
396
397
398
399
400
401
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True)
  = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg]
ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False)
  = hsep [ppr_lexpr arg, ptext SLIT(">-"), ppr_lexpr arrow]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
  = hsep [ppr_lexpr arrow, ptext SLIT("-<<"), ppr_lexpr arg]
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
  = hsep [ppr_lexpr arg, ptext SLIT(">>-"), ppr_lexpr arrow]
402

403
404
405
406
407
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
  = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm op _ args)
  = hang (ptext SLIT("(|") <> ppr_lexpr op)
	 4 (sep (map (pprCmdArg.unLoc) args) <> ptext SLIT("|)"))
408
409

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
410
411
412
413
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
414
415
416
417
418
419
420
421

-- Put a var in backquotes if it's not an operator already
pprInfix :: Outputable name => name -> SDoc
pprInfix v | isOperator ppr_v = ppr_v
	   | otherwise        = char '`' <> ppr_v <> char '`'
	   where
	     ppr_v = ppr v

chak's avatar
chak committed
422
423
-- add parallel array brackets around a document
--
424
425
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")    
426
427
428
429
\end{code}

Parenthesize unless very simple:
\begin{code}
430
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
431
pprParendExpr expr
432
  = let
433
	pp_as_was = ppr_lexpr expr
434
435
	-- Using ppr_expr here avoids the call to 'deeper'
	-- Not sure if that's always right.
436
    in
437
    case unLoc expr of
438
439
440
441
442
443
444
445
446
      HsLit l		-> ppr l
      HsOverLit l 	-> ppr l
			
      HsVar _		-> pp_as_was
      HsIPVar _		-> pp_as_was
      ExplicitList _ _  -> pp_as_was
      ExplicitPArr _ _  -> pp_as_was
      ExplicitTuple _ _	-> pp_as_was
      HsPar _		-> pp_as_was
447
448
      HsBracket _	-> pp_as_was
      HsBracketOut _ []	-> pp_as_was
449
450
			
      _			-> parens pp_as_was
451
452
\end{code}

453
454
455
456
457
458
459
460
461
462
463
%************************************************************************
%*									*
\subsection{Commands (in arrow abstractions)}
%*									*
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

464
465
type LHsCmd id = LHsExpr id

466
467
468
469
470
471
472
473
474
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}

The legal constructors for commands are:

  = HsArrApp ...		-- as above

  | HsArrForm ...		-- as above

ross's avatar
ross committed
475
476
477
  | HsApp	(HsCmd id)
		(HsExpr id)

478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
  | HsLam	(Match  id)	-- kappa

  -- the renamer turns this one into HsArrForm
  | OpApp	(HsExpr id)	-- left operand
		(HsCmd id)	-- operator
		Fixity		-- Renamer adds fixity; bottom until then
		(HsCmd id)	-- right operand

  | HsPar	(HsCmd id)	-- parenthesised command

  | HsCase	(HsExpr id)
		[Match id]	-- bodies are HsCmd's
		SrcLoc

  | HsIf	(HsExpr id)	--  predicate
		(HsCmd id)	--  then part
		(HsCmd id)	--  else part
		SrcLoc

497
  | HsLet	(HsLocalBinds id)	-- let(rec)
498
499
500
501
502
503
504
505
506
507
508
509
510
511
		(HsCmd  id)

  | HsDo	(HsStmtContext Name)	-- The parameterisation is unimportant
					-- because in this context we never use
					-- the PatGuard or ParStmt variant
		[Stmt id]	-- HsExpr's are really HsCmd's
		PostTcType	-- Type of the whole expression
		SrcLoc

Top-level command, introducing a new arrow.
This may occur inside a proc (where the stack is empty) or as an
argument of a command-forming operator.

\begin{code}
512
513
type LHsCmdTop id = Located (HsCmdTop id)

514
data HsCmdTop id
515
  = HsCmdTop	(LHsCmd id)
516
517
		[PostTcType]	-- types of inputs on the command's stack
		PostTcType	-- return type of the command
518
		(SyntaxTable id)
519
520
521
522
				-- after type checking:
				-- names used in the command's desugaring
\end{code}

523
524
525
526
527
528
529
%************************************************************************
%*									*
\subsection{Record binds}
%*									*
%************************************************************************

\begin{code}
530
type HsRecordBinds id = [(Located id, LHsExpr id)]
531
532

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

pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
536
pp_rbinds thing rbinds
sof's avatar
sof committed
537
  = hang thing 
538
	 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds))))
539
  where
540
    pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e]
541
542
\end{code}

543
544


545
546
%************************************************************************
%*									*
547
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
548
549
550
%*									*
%************************************************************************

551
552
553
554
555
556
557
558
559
560
561
562
563
564
@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.

565
\begin{code}
566
567
568
569
570
571
572
data MatchGroup id 
  = MatchGroup 
	[LMatch id] 	-- The alternatives
	PostTcType	-- The type is the type of the entire group
			-- 	t1 -> ... -> tn -> tr
			-- where there are n patterns

573
574
type LMatch id = Located (Match id)

575
data Match id
576
  = Match
577
578
	[LPat id]		-- The patterns
	(Maybe (LHsType id))	-- A type signature for the result of the match
579
				--	Nothing after typechecking
580
	(GRHSs id)
581

582
matchGroupArity :: MatchGroup id -> Arity
583
584
matchGroupArity (MatchGroup [] _) 
  = panic "matchGroupArity"	-- MatchGroup is never empty
585
586
587
588
589
590
591
matchGroupArity (MatchGroup (match:matches) _)
  = ASSERT( all ((== n_pats) . length . hsLMatchPats) matches )
	-- Assertion just checks that all the matches have the same number of pats
    n_pats
  where
    n_pats = length (hsLMatchPats match)

592
593
594
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

595
-- GRHSs are used both for pattern bindings and for Matches
596
data GRHSs id	
597
  = GRHSs [LGRHS id]		-- Guarded RHSs
598
	  (HsLocalBinds id)	-- The where clause
599

600
type LGRHS id = Located (GRHS id)
601

602
603
data GRHS id = GRHS [LStmt id]		-- Guards
		    (LHsExpr id)	-- Right hand side
604
\end{code}
605

606
We know the list must have at least one @Match@ in it.
607

608
\begin{code}
609
pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
610
pprMatches ctxt (MatchGroup matches ty) = (ppr ty) $$ vcat (map (pprMatch ctxt) (map unLoc matches))
611
612

-- Exported to HsBinds, which can't see the defn of HsMatchContext
613
pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
614
615
616
pprFunBind fun matches = pprMatches (FunRhs fun) matches

-- Exported to HsBinds, which can't see the defn of HsMatchContext
617
618
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
	   => LPat bndr -> GRHSs id -> SDoc
619
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
620
621


622
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
623
pprMatch ctxt (Match pats maybe_ty grhss)
624
  = pp_name ctxt <+> sep [sep (map ppr pats), 
625
		     ppr_maybe_ty, 
626
		     nest 2 (pprGRHSs ctxt grhss)]
627
  where
628
629
    pp_name (FunRhs fun) = ppr fun	-- Not pprBndr; the AbsBinds will
					-- have printed the signature
630
    pp_name LambdaExpr   = char '\\'
631
    pp_name other	 = empty
632

633
634
635
636
637
    ppr_maybe_ty = case maybe_ty of
			Just ty -> dcolon <+> ppr ty
			Nothing -> empty


638
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
639
pprGRHSs ctxt (GRHSs grhss binds)
640
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
641
    $$
642
    (if isEmptyLocalBinds binds then empty
643
     else text "where" $$ nest 4 (pprBinds binds))
644

645
pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
646

647
pprGRHS ctxt (GRHS [] expr)
648
 =  pp_rhs ctxt expr
649

650
pprGRHS ctxt (GRHS guards expr)
651
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
652

653
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
654
\end{code}
655

656
657
658
659
660
661
662
%************************************************************************
%*									*
\subsection{Do stmts and list comprehensions}
%*									*
%************************************************************************

\begin{code}
663
664
type LStmt id = Located (Stmt id)

665
666
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax.  Otherwise they are unused.
667
data Stmt id
668
669
670
671
672
673
674
675
676
677
678
  = BindStmt	(LPat id)		
		(LHsExpr id) 
		(SyntaxExpr id)		-- The (>>=) operator
		(SyntaxExpr id)		-- The fail operator 
		-- The fail operator is noSyntaxExpr 
		-- if the pattern match can't fail

  | ExprStmt	(LHsExpr id)
		(SyntaxExpr id)		-- The (>>) operator
		PostTcType		-- Element type of the RHS (used for arrows)

679
  | LetStmt	(HsLocalBinds id)	
680
681

	-- ParStmts only occur in a list comprehension
682
  | ParStmt	[([LStmt id], [id])]	-- After renaming, the ids are the binders
683
684
					-- bound by the stmts and used subsequently

685
	-- Recursive statement (see Note [RecStmt] below)
686
  | RecStmt  [LStmt id] 
687
688
689
690
691
692
693
694
		--- The next two fields are only valid after renaming
	     [id] 	-- The ids are a subset of the variables bound by the stmts
	     	 	-- that are used in stmts that follow the RecStmt

	     [id]	-- Ditto, but these variables are the "recursive" ones, that 
			-- are used before they are bound in the stmts of the RecStmt
			-- From a type-checking point of view, these ones have to be monomorphic

695
696
		--- These fields are only valid after typechecking
	     [PostTcExpr]	-- These expressions correspond
697
698
699
700
				-- 1-to-1 with the "recursive" [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*.
701
702
	     (DictBinds id)	-- Method bindings of Ids bound by the RecStmt,
				-- and used afterwards
703
704
\end{code}

705
ExprStmts are a bit tricky, because what they mean
706
depends on the context.  Consider the following contexts:
707
708
709

	A do expression of type (m res_ty)
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
710
	* ExprStmt E any_ty:   do { ....; E; ... }
711
712
713
714
715
		E :: m any_ty
	  Translation: E >> ...
	
	A list comprehensions of type [elt_ty]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
716
	* ExprStmt E Bool:   [ .. | .... E ]
717
718
			[ .. | ..., E, ... ]
			[ .. | .... | ..., E | ... ]
719
720
		E :: Bool
	  Translation: if E then fail else ...
721

722
723
	A guard list, guarding a RHS of type rhs_ty
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
724
	* ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
725
726
727
		E :: Bool
	  Translation: if E then fail else ...
	
chak's avatar
chak committed
728
Array comprehensions are handled like list comprehensions -=chak
729

730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
Note [RecStmt]
~~~~~~~~~~~~~~
Example:
	HsDo [ BindStmt x ex

	     , RecStmt [a::forall a. a -> a, b] 
		       [a::Int -> Int,       c] 
		       [ BindStmt b (return x)
		       , LetStmt a = ea
		       , BindStmt c ec ]

	     , return (a b) ]

Here, the RecStmt binds a,b,c; but 
  - Only a,b are used in the stmts *following* the RecStmt, 
	This 'a' is *polymorphic'
  - Only a,c are used in the stmts *inside* the RecStmt
	*before* their bindings
	This 'a' is monomorphic

Nota Bene: the two a's have different types, even though they
have the same Name.


754
\begin{code}
755
instance OutputableBndr id => Outputable (Stmt id) where
756
757
    ppr stmt = pprStmt stmt

758
759
760
761
762
763
764
pprStmt (BindStmt pat expr _ _)	  = hsep [ppr pat, ptext SLIT("<-"), ppr expr]
pprStmt (LetStmt binds)       	  = hsep [ptext SLIT("let"), pprBinds binds]
pprStmt (ExprStmt expr _ _)   	  = ppr expr
pprStmt (ParStmt stmtss)          = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss)
pprStmt (RecStmt segment _ _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment))

pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc
765
766
pprDo DoExpr      stmts body = ptext SLIT("do")  <+> (vcat (map ppr stmts) $$ ppr body)
pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> (vcat (map ppr stmts) $$ ppr body)
767
768
pprDo ListComp    stmts body = pprComp brackets    stmts body
pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
769
pprDo other	  stmts body = panic "pprDo" 	-- PatGuard, ParStmtCxt
770
771
772

pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
773
  = brack $
774
	hang (ppr body <+> char '|')
775
	     4 (interpp'SP quals)
776
777
\end{code}

778
779
780
781
782
783
784
%************************************************************************
%*									*
		Template Haskell quotation brackets
%*									*
%************************************************************************

\begin{code}
785
data HsSplice id  = HsSplice 	--  $z  or $(f 4)
786
787
788
789
790
791
792
793
794
795
			id 		-- The id is just a unique name to 
			(LHsExpr id) 	-- identify this splice point
					
instance OutputableBndr id => Outputable (HsSplice id) where
  ppr = pprSplice

pprSplice :: OutputableBndr id => HsSplice id -> SDoc
pprSplice (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e


796
797
data HsBracket id = ExpBr (LHsExpr id)		-- [|  expr  |]
		  | PatBr (LPat id)		-- [p| pat   |]
798
		  | DecBr (HsGroup id)		-- [d| decls |]
799
		  | TypBr (LHsType id)		-- [t| type  |]
800
		  | VarBr id			-- 'x, ''T
801
802
803
804
805
806
807

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


pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
808
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
809
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
810
811
812
813
814
pprHsBracket (VarBr n) = char '\'' <> ppr n
	-- Infelicity: can't show ' vs '', because
	-- we can't ask n what its OccName is, because the 
	-- pretty-printer for HsExpr doesn't ask for NamedThings
	-- But the pretty-printer for names will show the OccName class
815
816
817
818
819

thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> 
			     pp_body <+> ptext SLIT("|]")
\end{code}

820
821
822
823
824
825
826
%************************************************************************
%*									*
\subsection{Enumerations and list comprehensions}
%*									*
%************************************************************************

\begin{code}
827
data ArithSeqInfo id
828
829
830
831
832
833
834
835
  = From	    (LHsExpr id)
  | FromThen 	    (LHsExpr id)
		    (LHsExpr id)
  | FromTo	    (LHsExpr id)
		    (LHsExpr id)
  | FromThenTo	    (LHsExpr id)
		    (LHsExpr id)
		    (LHsExpr id)
836
837
838
\end{code}

\begin{code}
839
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
840
841
842
843
844
    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]
845

sof's avatar
sof committed
846
pp_dotdot = ptext SLIT(" .. ")
847
\end{code}
848
849
850
851
852
853
854
855
856


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

\begin{code}
857
858
859
860
data HsMatchContext id	-- Context of a Match
  = FunRhs id			-- Function binding for f
  | CaseAlt			-- Guard on a case alternative
  | LambdaExpr			-- Pattern of a lambda
861
  | ProcExpr			-- Pattern of a proc
862
863
864
865
  | 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
866
867
  deriving ()

868
869
870
data HsStmtContext id
  = ListComp 
  | DoExpr 
871
872
873
  | MDoExpr PostTcTable			-- Recursive do-expression
					-- (tiresomely, it needs table
					--  of its return/bind ops)
874
875
  | PArrComp				-- Parallel array comprehension
  | PatGuard (HsMatchContext id)	-- Pattern guard for specified thing
876
  | ParStmtCtxt (HsStmtContext id)	-- A branch of a parallel stmt 
877
878
879
\end{code}

\begin{code}
880
isDoExpr :: HsStmtContext id -> Bool
881
882
883
isDoExpr DoExpr      = True
isDoExpr (MDoExpr _) = True
isDoExpr other       = False
884
885
886
\end{code}

\begin{code}
887
888
889
matchSeparator (FunRhs _)   = ptext SLIT("=")
matchSeparator CaseAlt      = ptext SLIT("->") 
matchSeparator LambdaExpr   = ptext SLIT("->") 
890
matchSeparator ProcExpr     = ptext SLIT("->") 
891
matchSeparator PatBindRhs   = ptext SLIT("=") 
892
893
matchSeparator (StmtCtxt _) = ptext SLIT("<-")  
matchSeparator RecUpd       = panic "unused"
894
895
896
\end{code}

\begin{code}
897
898
899
900
901
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")
902
pprMatchContext ProcExpr   	  = ptext SLIT("an arrow abstraction")
903
904
pprMatchContext (StmtCtxt ctxt)   = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt

905
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
906
907
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr          = ptext SLIT("a 'do' expression")
908
pprStmtContext (MDoExpr _)     = ptext SLIT("an 'mdo' expression")
909
910
911
pprStmtContext ListComp        = ptext SLIT("a list comprehension")
pprStmtContext PArrComp        = ptext SLIT("an array comprehension")

912
913
914
915
916
917
918
919
{- 
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 ProcExpr	= ptext SLIT("the body of a proc")
pprMatchRhsContext other	= panic "pprMatchRhsContext"	-- RecUpd, StmtCtxt

920
921
922
923
924
-- 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
925
-}
926
927

-- Used to generate the string for a *runtime* error message
928
929
930
931
932
matchContextErrString (FunRhs fun)    	      	 = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt	      	      	 = "case"
matchContextErrString PatBindRhs      	      	 = "pattern binding"
matchContextErrString RecUpd	      	      	 = "record update"
matchContextErrString LambdaExpr      	      	 = "lambda"
933
matchContextErrString ProcExpr      	      	 = "proc"
934
935
936
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) 	 = "pattern guard"
matchContextErrString (StmtCtxt DoExpr)       	 = "'do' expression"
937
matchContextErrString (StmtCtxt (MDoExpr _))   	 = "'mdo' expression"
938
939
matchContextErrString (StmtCtxt ListComp)     	 = "list comprehension"
matchContextErrString (StmtCtxt PArrComp)     	 = "array comprehension"
940
\end{code}