HsExpr.lhs 31.6 KB
Newer Older
1
%
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
5
6

HsExpr: Abstract Haskell syntax: expressions
7
8
9
10

\begin{code}
module HsExpr where

11
#include "HsVersions.h"
12
13

-- friends:
14
15
16
17
18
19
import HsDecls
import HsPat
import HsLit
import HsTypes
import HsImpExp
import HsBinds
20
21

-- others:
22
23
24
import Var
import Name
import BasicTypes
25
import DataCon
26
import SrcLoc
27
import Outputable	
28
import FastString
29
30
\end{code}

31

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

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

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
86
-------------------------
-- 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 = []


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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


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

159
	-- Record update
160
  | RecordUpd	(LHsExpr id)
161
		(HsRecordBinds id)
162
163
164
165
166
		[DataCon]		-- Filled in by the type checker to the *non-empty*
					-- list of DataCons that have all the upd'd fields
		[PostTcType]		-- Argument types of *input* record type
		[PostTcType]		-- 		and  *output* record type
	-- For a type family, the arg types are of the *instance* tycon, not the family tycon
167

168
  | ExprWithTySig			-- e :: type
169
170
		(LHsExpr id)
		(LHsType id)
171
172
173
174
175

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

176
177
  | ArithSeq				-- arithmetic sequence
		PostTcExpr
178
		(ArithSeqInfo id)
179
180
181

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

184
  | HsSCC	FastString	-- "set cost centre" (_scc_) annotation
185
		(LHsExpr id) 	-- expr whose cost is to be measured
186
187

  | HsCoreAnn   FastString      -- hdaume: core annotation
188
                (LHsExpr id)
189
		
190
  -----------------------------------------------------------
191
  -- MetaHaskell Extensions
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
192

193
  | HsBracket    (HsBracket id)
194
195
196
197
198

  | 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

199
  | HsSpliceE (HsSplice id) 
200

201
202
203
  -----------------------------------------------------------
  -- Arrow notation extension

204
205
  | HsProc	(LPat id)		-- arrow abstraction, proc
		(LHsCmdTop id)		-- body of the abstraction
206
207
208
209
210
211
					-- always has an empty stack

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

  | HsArrApp	-- Arrow tail, or arrow application (f -< arg)
212
213
	(LHsExpr id)	-- arrow expression, f
	(LHsExpr id)	-- input expression, arg
214
215
216
217
218
219
	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
220
  | HsArrForm	-- Command formation,  (| e cmd1 .. cmdn |)
221
	(LHsExpr id)	-- the operator
222
223
224
225
			-- 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
226
	[LHsCmdTop id]	-- argument commands
227

228

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
229
230
231
232
233
  ---------------------------------------
  -- Haskell program coverage (Hpc) Support

  | HsTick 
     Int				-- module-local tick number
234
     [id]                               -- variables in scope
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
235
236
237
238
239
240
241
242
243
244
245
246
247
248
     (LHsExpr id)			-- sub-expression

  | HsBinTick
     Int				-- module-local tick number for True
     Int				-- module-local tick number for False
     (LHsExpr id)			-- sub-expression

  | HsTickPragma			-- A pragma introduced tick
     (FastString,(Int,Int),(Int,Int))   -- external span for this tick    
     (LHsExpr id)     

  ---------------------------------------
  -- These constructors only appear temporarily in the parser.
  -- The renamer translates them into the Right Thing.
249
250
251

  | EWildPat			-- wildcard

252
253
  | EAsPat	(Located id)	-- as pattern
		(LHsExpr id)
254

255
  | ELazyPat	(LHsExpr id) -- ~ pattern
256

257
  | HsType      (LHsType id)     -- Explicit type argument; e.g  f {| Int |} x y
258

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
259
260
  ---------------------------------------
  -- Finally, HsWrap appears only in typechecker output
261

262
  |  HsWrap	HsWrapper 	-- TRANSLATION
263
264
		(HsExpr id)

265
type PendingSplice = (Name, LHsExpr Id)	-- Typechecked splices, waiting to be 
266
					-- pasted back in by the desugarer
267
268
269
270
271
272
273
274
275
\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}
276
instance OutputableBndr id => Outputable (HsExpr id) where
277
    ppr expr = pprExpr expr
278
279
280
\end{code}

\begin{code}
281
282
-----------------------
-- pprExpr, pprLExpr, pprBinds call pprDeeper; 
283
284
-- the underscore versions do not
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
285
286
287
288
289
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
pprExpr e | isAtomicHsExpr e = ppr_expr e	-- Never replace 'x' by "..."
	  | otherwise	     = pprDeeper (ppr_expr e)
290

291
292
pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
pprBinds b = pprDeeper (ppr b)
293

294
-----------------------
295
296
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
297

298
ppr_expr (HsVar v)	 = pprHsVar v
299
ppr_expr (HsIPVar v)     = ppr v
300
301
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
302
303
304
305
ppr_expr (HsPar e)	 = parens (ppr_lexpr e)

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

307
308
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
309
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
310
  where
311
312
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
313

314
ppr_expr (OpApp e1 op fixity e2)
315
  = case unLoc op of
316
317
318
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
319
320
    pp_e1 = pprParendExpr e1		-- Add parens to make precedence clear
    pp_e2 = pprParendExpr e2
321
322

    pp_prefixly
323
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
324
325

    pp_infixly v
326
      = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
327

328
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
329

330
ppr_expr (SectionL expr op)
331
  = case unLoc op of
332
333
334
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
335
    pp_expr = pprParendExpr expr
336

337
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
sof's avatar
sof committed
338
		       4 (hsep [pp_expr, ptext SLIT("x_ )")])
339
    pp_infixly v = parens (sep [pp_expr, pprInfix v])
340

341
ppr_expr (SectionR op expr)
342
  = case unLoc op of
343
344
345
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
346
    pp_expr = pprParendExpr expr
347

348
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
sof's avatar
sof committed
349
		       4 ((<>) pp_expr rparen)
350
    pp_infixly v
351
      = parens (sep [pprInfix v, pp_expr])
352

353
354
355
ppr_expr (HsLam matches) 
  = pprMatches LambdaExpr matches

356
357
ppr_expr (HsCase expr matches)
  = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
358
	    nest 2 (pprMatches CaseAlt matches) ]
359

360
361
362
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
363
	   ptext SLIT("else"),
364
	   nest 4 (ppr e3)]
365
366

-- special case: let ... in let ...
367
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
368
  = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
369
	 ppr_lexpr expr]
370

371
ppr_expr (HsLet binds expr)
372
  = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
373
	 hang (ptext SLIT("in"))  2 (ppr expr)]
374

375
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
376

377
ppr_expr (ExplicitList _ exprs)
378
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
379

chak's avatar
chak committed
380
ppr_expr (ExplicitPArr _ exprs)
381
  = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
382

383
ppr_expr (ExplicitTuple exprs boxity)
384
  = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
385

386
ppr_expr (RecordCon con_id con_expr rbinds)
387
  = pp_rbinds (ppr con_id) rbinds
388

389
ppr_expr (RecordUpd aexp rbinds _ _ _)
390
391
392
  = pp_rbinds (pprParendExpr aexp) rbinds

ppr_expr (ExprWithTySig expr sig)
393
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
394
	 4 (ppr sig)
395
396
397
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
	 4 (ppr sig)
398

399
400
ppr_expr (ArithSeq expr info) = brackets (ppr info)
ppr_expr (PArrSeq expr info)  = pa_brackets (ppr info)
chak's avatar
chak committed
401

402
ppr_expr EWildPat     = char '_'
403
404
405
406
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e

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

409
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
410
ppr_expr (HsType id)	    = ppr id
chak's avatar
chak committed
411

412
413
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
414
415
ppr_expr (HsBracketOut e []) = ppr e	
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps
416

417
418
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
  = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
419

420
421
ppr_expr (HsTick tickId vars exp)
  = hcat [ptext SLIT("tick<"), ppr tickId,ptext SLIT(">("), hsep (map pprHsVar vars), ppr exp,ptext SLIT(")")]
andy@galois.com's avatar
andy@galois.com committed
422
423
424
425
426
427
428
ppr_expr (HsBinTick tickIdTrue tickIdFalse exp)
  = hcat [ptext SLIT("bintick<"), 
	  ppr tickIdTrue,
	  ptext SLIT(","),
	  ppr tickIdFalse,
	  ptext SLIT(">("), 
	  ppr exp,ptext SLIT(")")]
andy@galois.com's avatar
andy@galois.com committed
429
430
ppr_expr (HsTickPragma externalSrcLoc exp)
  = hcat [ptext SLIT("tickpragma<"), ppr externalSrcLoc,ptext SLIT(">("), ppr exp,ptext SLIT(")")]
andy@galois.com's avatar
andy@galois.com committed
431

432
433
434
435
436
437
438
439
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]
440

441
442
443
444
445
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("|)"))
446
447

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
448
449
450
451
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
452
453
454
455
456
457
458
459

-- 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
460
461
-- add parallel array brackets around a document
--
462
463
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")    
464
465
466
467
\end{code}

Parenthesize unless very simple:
\begin{code}
468
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
469
pprParendExpr expr
470
  = let
471
472
473
	pp_as_was = pprLExpr expr
	-- Using pprLExpr makes sure that we go 'deeper'
	-- I think that is usually (always?) right
474
    in
475
    case unLoc expr of
476
477
      HsLit l		-> pp_as_was
      HsOverLit l 	-> pp_as_was
478
479
480
481
482
483
      HsVar _		-> pp_as_was
      HsIPVar _		-> pp_as_was
      ExplicitList _ _  -> pp_as_was
      ExplicitPArr _ _  -> pp_as_was
      ExplicitTuple _ _	-> pp_as_was
      HsPar _		-> pp_as_was
484
485
      HsBracket _	-> pp_as_was
      HsBracketOut _ []	-> pp_as_was
486
      _			-> parens pp_as_was
487
488
489
490
491
492
493
494
495

isAtomicHsExpr :: HsExpr id -> Bool	-- A single token
isAtomicHsExpr (HsVar {})     = True
isAtomicHsExpr (HsLit {})     = True
isAtomicHsExpr (HsOverLit {}) = True
isAtomicHsExpr (HsIPVar {})   = True
isAtomicHsExpr (HsWrap _ e)   = isAtomicHsExpr e
isAtomicHsExpr (HsPar e)      = isAtomicHsExpr (unLoc e)
isAtomicHsExpr e	      = False
496
497
\end{code}

498
499
500
501
502
503
504
505
506
507
508
%************************************************************************
%*									*
\subsection{Commands (in arrow abstractions)}
%*									*
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

509
510
type LHsCmd id = LHsExpr id

511
512
513
514
515
516
517
518
519
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}

The legal constructors for commands are:

  = HsArrApp ...		-- as above

  | HsArrForm ...		-- as above

ross's avatar
ross committed
520
521
522
  | HsApp	(HsCmd id)
		(HsExpr id)

523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
  | 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

542
  | HsLet	(HsLocalBinds id)	-- let(rec)
543
544
545
546
547
548
549
550
551
552
553
554
555
556
		(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}
557
558
type LHsCmdTop id = Located (HsCmdTop id)

559
data HsCmdTop id
560
  = HsCmdTop	(LHsCmd id)
561
562
		[PostTcType]	-- types of inputs on the command's stack
		PostTcType	-- return type of the command
563
		(SyntaxTable id)
564
565
566
567
				-- after type checking:
				-- names used in the command's desugaring
\end{code}

568
569
570
571
572
573
574
%************************************************************************
%*									*
\subsection{Record binds}
%*									*
%************************************************************************

\begin{code}
575
data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)]
576
577

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

pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
581
pp_rbinds thing (HsRecordBinds rbinds)
sof's avatar
sof committed
582
  = hang thing 
583
	 4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds))))
584
  where
585
    pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e]
586
587
\end{code}

588
589


590
591
%************************************************************************
%*									*
592
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
593
594
595
%*									*
%************************************************************************

596
597
598
599
600
601
602
603
604
605
606
607
608
609
@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.

610
\begin{code}
611
612
613
614
615
616
617
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

618
619
type LMatch id = Located (Match id)

620
data Match id
621
  = Match
622
623
	[LPat id]		-- The patterns
	(Maybe (LHsType id))	-- A type signature for the result of the match
624
				--	Nothing after typechecking
625
	(GRHSs id)
626

627
matchGroupArity :: MatchGroup id -> Arity
628
629
matchGroupArity (MatchGroup [] _) 
  = panic "matchGroupArity"	-- MatchGroup is never empty
630
631
632
633
634
635
636
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)

637
638
639
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

640
-- GRHSs are used both for pattern bindings and for Matches
641
data GRHSs id	
642
  = GRHSs [LGRHS id]		-- Guarded RHSs
643
	  (HsLocalBinds id)	-- The where clause
644

645
type LGRHS id = Located (GRHS id)
646

647
648
data GRHS id = GRHS [LStmt id]		-- Guards
		    (LHsExpr id)	-- Right hand side
649
\end{code}
650

651
We know the list must have at least one @Match@ in it.
652

653
\begin{code}
654
pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
655
656
657
pprMatches ctxt (MatchGroup matches ty) = vcat (map (pprMatch ctxt) (map unLoc matches))
                                          -- Don't print the type; it's only 
                                          -- a place-holder before typechecking
658
659

-- Exported to HsBinds, which can't see the defn of HsMatchContext
660
pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
661
662
663
pprFunBind fun matches = pprMatches (FunRhs fun) matches

-- Exported to HsBinds, which can't see the defn of HsMatchContext
664
665
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
	   => LPat bndr -> GRHSs id -> SDoc
666
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
667
668


669
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
670
pprMatch ctxt (Match pats maybe_ty grhss)
671
  = pp_name ctxt <+> sep [sep (map ppr pats), 
672
		     ppr_maybe_ty, 
673
		     nest 2 (pprGRHSs ctxt grhss)]
674
  where
675
676
    pp_name (FunRhs fun) = ppr fun	-- Not pprBndr; the AbsBinds will
					-- have printed the signature
677
    pp_name LambdaExpr   = char '\\'
678
    pp_name other	 = empty
679

680
681
682
683
684
    ppr_maybe_ty = case maybe_ty of
			Just ty -> dcolon <+> ppr ty
			Nothing -> empty


685
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
686
pprGRHSs ctxt (GRHSs grhss binds)
687
688
689
690
  = pprDeeper
    (vcat (map (pprGRHS ctxt . unLoc) grhss)
      $$
     if isEmptyLocalBinds binds then empty
691
     else text "where" $$ nest 4 (pprBinds binds))
692

693
pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
694

695
pprGRHS ctxt (GRHS [] expr)
696
 =  pp_rhs ctxt expr
697

698
pprGRHS ctxt (GRHS guards expr)
699
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
700

701
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
702
\end{code}
703

704
705
706
707
708
709
710
%************************************************************************
%*									*
\subsection{Do stmts and list comprehensions}
%*									*
%************************************************************************

\begin{code}
711
712
type LStmt id = Located (Stmt id)

713
714
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax.  Otherwise they are unused.
715
data Stmt id
716
717
718
719
720
721
722
723
724
725
726
  = 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)

727
  | LetStmt	(HsLocalBinds id)	
728
729

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

733
	-- Recursive statement (see Note [RecStmt] below)
734
  | RecStmt  [LStmt id] 
735
736
737
738
739
740
741
742
		--- 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

743
744
		--- These fields are only valid after typechecking
	     [PostTcExpr]	-- These expressions correspond
745
746
747
748
				-- 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*.
749
750
	     (DictBinds id)	-- Method bindings of Ids bound by the RecStmt,
				-- and used afterwards
751
752
\end{code}

753
ExprStmts are a bit tricky, because what they mean
754
depends on the context.  Consider the following contexts:
755
756
757

	A do expression of type (m res_ty)
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
758
	* ExprStmt E any_ty:   do { ....; E; ... }
759
760
761
762
763
		E :: m any_ty
	  Translation: E >> ...
	
	A list comprehensions of type [elt_ty]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
764
	* ExprStmt E Bool:   [ .. | .... E ]
765
766
			[ .. | ..., E, ... ]
			[ .. | .... | ..., E | ... ]
767
768
		E :: Bool
	  Translation: if E then fail else ...
769

770
771
	A guard list, guarding a RHS of type rhs_ty
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772
	* ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
773
774
775
		E :: Bool
	  Translation: if E then fail else ...
	
chak's avatar
chak committed
776
Array comprehensions are handled like list comprehensions -=chak
777

778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
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.


802
\begin{code}
803
instance OutputableBndr id => Outputable (Stmt id) where
804
805
    ppr stmt = pprStmt stmt

806
807
808
809
810
811
812
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
813
814
pprDo DoExpr      stmts body = ptext SLIT("do")  <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
pprDo (MDoExpr _) stmts body = ptext SLIT("mdo") <+> pprDeeperList vcat (map ppr stmts ++ [ppr body])
815
816
pprDo ListComp    stmts body = pprComp brackets    stmts body
pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
817
pprDo other	  stmts body = panic "pprDo" 	-- PatGuard, ParStmtCxt
818
819
820

pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
821
  = brack $
822
	hang (ppr body <+> char '|')
823
	     4 (interpp'SP quals)
824
825
\end{code}

826
827
828
829
830
831
832
%************************************************************************
%*									*
		Template Haskell quotation brackets
%*									*
%************************************************************************

\begin{code}
833
data HsSplice id  = HsSplice 	--  $z  or $(f 4)
834
835
836
837
838
839
840
841
842
843
			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


844
845
data HsBracket id = ExpBr (LHsExpr id)		-- [|  expr  |]
		  | PatBr (LPat id)		-- [p| pat   |]
846
		  | DecBr (HsGroup id)		-- [d| decls |]
847
		  | TypBr (LHsType id)		-- [t| type  |]
848
		  | VarBr id			-- 'x, ''T
849
850
851
852
853
854
855

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


pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
856
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
857
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
858
859
860
861
862
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
863
864
865
866
867

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

868
869
870
871
872
873
874
%************************************************************************
%*									*
\subsection{Enumerations and list comprehensions}
%*									*
%************************************************************************

\begin{code}
875
data ArithSeqInfo id
876
877
878
879
880
881
882
883
  = From	    (LHsExpr id)
  | FromThen 	    (LHsExpr id)
		    (LHsExpr id)
  | FromTo	    (LHsExpr id)
		    (LHsExpr id)
  | FromThenTo	    (LHsExpr id)
		    (LHsExpr id)
		    (LHsExpr id)
884
885
886
\end{code}

\begin{code}
887
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
888
889
890
891
892
    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]
893

sof's avatar
sof committed
894
pp_dotdot = ptext SLIT(" .. ")
895
\end{code}
896
897
898
899
900
901
902
903
904


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

\begin{code}
905
906
907
908
data HsMatchContext id	-- Context of a Match
  = FunRhs id			-- Function binding for f
  | CaseAlt			-- Guard on a case alternative
  | LambdaExpr			-- Pattern of a lambda
909
  | ProcExpr			-- Pattern of a proc
910
911
912
913
  | 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
914
915
  deriving ()

916
917
918
data HsStmtContext id
  = ListComp 
  | DoExpr 
919
920
921
  | MDoExpr PostTcTable			-- Recursive do-expression
					-- (tiresomely, it needs table
					--  of its return/bind ops)
922
923
  | PArrComp				-- Parallel array comprehension
  | PatGuard (HsMatchContext id)	-- Pattern guard for specified thing
924
  | ParStmtCtxt (HsStmtContext id)	-- A branch of a parallel stmt 
925
926
927
\end{code}

\begin{code}
928
isDoExpr :: HsStmtContext id -> Bool
929
930
931
isDoExpr DoExpr      = True
isDoExpr (MDoExpr _) = True
isDoExpr other       = False
932
933
934
\end{code}

\begin{code}
935
936
937
matchSeparator (FunRhs _)   = ptext SLIT("=")
matchSeparator CaseAlt      = ptext SLIT("->") 
matchSeparator LambdaExpr   = ptext SLIT("->") 
938
matchSeparator ProcExpr     = ptext SLIT("->") 
939
matchSeparator PatBindRhs   = ptext SLIT("=") 
940
941
matchSeparator (StmtCtxt _) = ptext SLIT("<-")  
matchSeparator RecUpd       = panic "unused"
942
943
944
\end{code}

\begin{code}
945
946
947
948
949
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")
950
pprMatchContext ProcExpr   	  = ptext SLIT("an arrow abstraction")
951
952
pprMatchContext (StmtCtxt ctxt)   = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt

953
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
954
955
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr          = ptext SLIT("a 'do' expression")
956
pprStmtContext (MDoExpr _)     = ptext SLIT("an 'mdo' expression")
957
958
959
pprStmtContext ListComp        = ptext SLIT("a list comprehension")
pprStmtContext PArrComp        = ptext SLIT("an array comprehension")

960
961
962
963
964
965
966
967
{- 
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

968
969
970
971
972
-- 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
973
-}
974
975

-- Used to generate the string for a *runtime* error message
976
977
978
979
980
matchContextErrString (FunRhs fun)    	      	 = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt	      	      	 = "case"
matchContextErrString PatBindRhs      	      	 = "pattern binding"
matchContextErrString RecUpd	      	      	 = "record update"
matchContextErrString LambdaExpr      	      	 = "lambda"
981
matchContextErrString ProcExpr      	      	 = "proc"
982
983
984
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) 	 = "pattern guard"
matchContextErrString (StmtCtxt DoExpr)       	 = "'do' expression"
985
matchContextErrString (StmtCtxt (MDoExpr _))   	 = "'mdo' expression"
986
987
matchContextErrString (StmtCtxt ListComp)     	 = "list comprehension"
matchContextErrString (StmtCtxt PArrComp)     	 = "array comprehension"
988
\end{code}