HsExpr.lhs 32 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
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
288
289
290
291
292
293
294
295
296
297
298
299
pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e
          | otherwise                           = pprDeeper (ppr_expr e)

isQuietHsExpr :: HsExpr id -> Bool
-- Parentheses do display something, but it gives little info and
-- if we go deeper when we go inside them then we get ugly things
-- like (...)
isQuietHsExpr (HsPar _) = True
-- applications don't display anything themselves
isQuietHsExpr (HsApp _ _) = True
isQuietHsExpr (OpApp _ _ _ _) = True
isQuietHsExpr _ = False
300

301
302
pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
pprBinds b = pprDeeper (ppr b)
303

304
-----------------------
305
306
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
307

308
ppr_expr (HsVar v)	 = pprHsVar v
309
ppr_expr (HsIPVar v)     = ppr v
310
311
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
312
313
314
315
ppr_expr (HsPar e)	 = parens (ppr_lexpr e)

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

317
318
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
319
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
320
  where
321
322
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
323

324
ppr_expr (OpApp e1 op fixity e2)
325
  = case unLoc op of
326
327
328
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
329
330
    pp_e1 = pprParendExpr e1		-- Add parens to make precedence clear
    pp_e2 = pprParendExpr e2
331
332

    pp_prefixly
333
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
334
335

    pp_infixly v
336
      = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
337

338
ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e
339

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

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

351
ppr_expr (SectionR op expr)
352
  = case unLoc op of
353
354
355
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
356
    pp_expr = pprParendExpr expr
357

358
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
sof's avatar
sof committed
359
		       4 ((<>) pp_expr rparen)
360
    pp_infixly v
361
      = parens (sep [pprInfix v, pp_expr])
362

363
364
365
ppr_expr (HsLam matches) 
  = pprMatches LambdaExpr matches

366
367
ppr_expr (HsCase expr matches)
  = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
368
	    nest 2 (pprMatches CaseAlt matches) ]
369

370
371
372
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
373
	   ptext SLIT("else"),
374
	   nest 4 (ppr e3)]
375
376

-- special case: let ... in let ...
377
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
378
  = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
379
	 ppr_lexpr expr]
380

381
ppr_expr (HsLet binds expr)
382
  = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
383
	 hang (ptext SLIT("in"))  2 (ppr expr)]
384

385
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
386

387
ppr_expr (ExplicitList _ exprs)
388
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
389

chak's avatar
chak committed
390
ppr_expr (ExplicitPArr _ exprs)
391
  = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
392

393
ppr_expr (ExplicitTuple exprs boxity)
394
  = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
395

396
ppr_expr (RecordCon con_id con_expr rbinds)
397
  = pp_rbinds (ppr con_id) rbinds
398

399
ppr_expr (RecordUpd aexp rbinds _ _ _)
400
401
402
  = pp_rbinds (pprParendExpr aexp) rbinds

ppr_expr (ExprWithTySig expr sig)
403
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
404
	 4 (ppr sig)
405
406
407
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
	 4 (ppr sig)
408

409
410
ppr_expr (ArithSeq expr info) = brackets (ppr info)
ppr_expr (PArrSeq expr info)  = pa_brackets (ppr info)
chak's avatar
chak committed
411

412
ppr_expr EWildPat     = char '_'
413
414
415
416
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e

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

419
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
420
ppr_expr (HsType id)	    = ppr id
chak's avatar
chak committed
421

422
423
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
424
425
ppr_expr (HsBracketOut e []) = ppr e	
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps
426

427
428
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
  = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
429

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

442
443
444
445
446
447
448
449
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]
450

451
452
453
454
455
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("|)"))
456
457

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
458
459
460
461
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
462
463
464
465
466
467
468
469

-- 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
470
471
-- add parallel array brackets around a document
--
472
473
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")    
474
475
476
477
\end{code}

Parenthesize unless very simple:
\begin{code}
478
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
479
pprParendExpr expr
480
  = let
481
482
483
	pp_as_was = pprLExpr expr
	-- Using pprLExpr makes sure that we go 'deeper'
	-- I think that is usually (always?) right
484
    in
485
    case unLoc expr of
486
487
      HsLit l		-> pp_as_was
      HsOverLit l 	-> pp_as_was
488
489
490
491
492
493
      HsVar _		-> pp_as_was
      HsIPVar _		-> pp_as_was
      ExplicitList _ _  -> pp_as_was
      ExplicitPArr _ _  -> pp_as_was
      ExplicitTuple _ _	-> pp_as_was
      HsPar _		-> pp_as_was
494
495
      HsBracket _	-> pp_as_was
      HsBracketOut _ []	-> pp_as_was
496
      _			-> parens pp_as_was
497
498
499
500
501
502
503
504
505

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
506
507
\end{code}

508
509
510
511
512
513
514
515
516
517
518
%************************************************************************
%*									*
\subsection{Commands (in arrow abstractions)}
%*									*
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

519
520
type LHsCmd id = LHsExpr id

521
522
523
524
525
526
527
528
529
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}

The legal constructors for commands are:

  = HsArrApp ...		-- as above

  | HsArrForm ...		-- as above

ross's avatar
ross committed
530
531
532
  | HsApp	(HsCmd id)
		(HsExpr id)

533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
  | 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

552
  | HsLet	(HsLocalBinds id)	-- let(rec)
553
554
555
556
557
558
559
560
561
562
563
564
565
566
		(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}
567
568
type LHsCmdTop id = Located (HsCmdTop id)

569
data HsCmdTop id
570
  = HsCmdTop	(LHsCmd id)
571
572
		[PostTcType]	-- types of inputs on the command's stack
		PostTcType	-- return type of the command
573
		(SyntaxTable id)
574
575
576
577
				-- after type checking:
				-- names used in the command's desugaring
\end{code}

578
579
580
581
582
583
584
%************************************************************************
%*									*
\subsection{Record binds}
%*									*
%************************************************************************

\begin{code}
585
data HsRecordBinds id = HsRecordBinds [(Located id, LHsExpr id)]
586
587

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

pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc
591
pp_rbinds thing (HsRecordBinds rbinds)
sof's avatar
sof committed
592
  = hang thing 
593
	 4 (braces (pprDeeperList sep (punctuate comma (map (pp_rbind) rbinds))))
594
  where
595
    pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e]
596
597
\end{code}

598
599


600
601
%************************************************************************
%*									*
602
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
603
604
605
%*									*
%************************************************************************

606
607
608
609
610
611
612
613
614
615
616
617
618
619
@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.

620
\begin{code}
621
622
623
624
625
626
627
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

628
629
type LMatch id = Located (Match id)

630
data Match id
631
  = Match
632
633
	[LPat id]		-- The patterns
	(Maybe (LHsType id))	-- A type signature for the result of the match
634
				--	Nothing after typechecking
635
	(GRHSs id)
636

637
matchGroupArity :: MatchGroup id -> Arity
638
639
matchGroupArity (MatchGroup [] _) 
  = panic "matchGroupArity"	-- MatchGroup is never empty
640
641
642
643
644
645
646
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)

647
648
649
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

650
-- GRHSs are used both for pattern bindings and for Matches
651
data GRHSs id	
652
  = GRHSs [LGRHS id]		-- Guarded RHSs
653
	  (HsLocalBinds id)	-- The where clause
654

655
type LGRHS id = Located (GRHS id)
656

657
658
data GRHS id = GRHS [LStmt id]		-- Guards
		    (LHsExpr id)	-- Right hand side
659
\end{code}
660

661
We know the list must have at least one @Match@ in it.
662

663
\begin{code}
664
pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
665
666
667
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
668
669

-- Exported to HsBinds, which can't see the defn of HsMatchContext
670
pprFunBind :: (OutputableBndr id) => id -> MatchGroup id -> SDoc
671
672
673
pprFunBind fun matches = pprMatches (FunRhs fun) matches

-- Exported to HsBinds, which can't see the defn of HsMatchContext
674
675
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
	   => LPat bndr -> GRHSs id -> SDoc
676
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
677
678


679
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
680
pprMatch ctxt (Match pats maybe_ty grhss)
681
  = pp_name ctxt <+> sep [sep (map ppr pats), 
682
		     ppr_maybe_ty, 
683
		     nest 2 (pprGRHSs ctxt grhss)]
684
  where
685
686
    pp_name (FunRhs fun) = ppr fun	-- Not pprBndr; the AbsBinds will
					-- have printed the signature
687
    pp_name LambdaExpr   = char '\\'
688
    pp_name other	 = empty
689

690
691
692
693
694
    ppr_maybe_ty = case maybe_ty of
			Just ty -> dcolon <+> ppr ty
			Nothing -> empty


695
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
696
pprGRHSs ctxt (GRHSs grhss binds)
Ian Lynagh's avatar
Ian Lynagh committed
697
698
699
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
 $$ if isEmptyLocalBinds binds then empty
                               else text "where" $$ nest 4 (pprBinds binds)
700

701
pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
702

703
pprGRHS ctxt (GRHS [] expr)
704
 =  pp_rhs ctxt expr
705

706
pprGRHS ctxt (GRHS guards expr)
707
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
708

709
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
710
\end{code}
711

712
713
714
715
716
717
718
%************************************************************************
%*									*
\subsection{Do stmts and list comprehensions}
%*									*
%************************************************************************

\begin{code}
719
720
type LStmt id = Located (Stmt id)

721
722
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax.  Otherwise they are unused.
723
data Stmt id
724
725
726
727
728
729
730
731
732
733
734
  = 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)

735
  | LetStmt	(HsLocalBinds id)	
736
737

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

741
	-- Recursive statement (see Note [RecStmt] below)
742
  | RecStmt  [LStmt id] 
743
744
745
746
747
748
749
750
		--- 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

751
752
		--- These fields are only valid after typechecking
	     [PostTcExpr]	-- These expressions correspond
753
754
755
756
				-- 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*.
757
758
	     (DictBinds id)	-- Method bindings of Ids bound by the RecStmt,
				-- and used afterwards
759
760
\end{code}

761
ExprStmts are a bit tricky, because what they mean
762
depends on the context.  Consider the following contexts:
763
764
765

	A do expression of type (m res_ty)
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
766
	* ExprStmt E any_ty:   do { ....; E; ... }
767
768
769
770
771
		E :: m any_ty
	  Translation: E >> ...
	
	A list comprehensions of type [elt_ty]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
772
	* ExprStmt E Bool:   [ .. | .... E ]
773
774
			[ .. | ..., E, ... ]
			[ .. | .... | ..., E | ... ]
775
776
		E :: Bool
	  Translation: if E then fail else ...
777

778
779
	A guard list, guarding a RHS of type rhs_ty
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
780
	* ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
781
782
783
		E :: Bool
	  Translation: if E then fail else ...
	
chak's avatar
chak committed
784
Array comprehensions are handled like list comprehensions -=chak
785

786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
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.


810
\begin{code}
811
instance OutputableBndr id => Outputable (Stmt id) where
812
813
    ppr stmt = pprStmt stmt

814
815
816
817
818
819
820
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
821
822
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])
823
824
pprDo ListComp    stmts body = pprComp brackets    stmts body
pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
825
pprDo other	  stmts body = panic "pprDo" 	-- PatGuard, ParStmtCxt
826
827
828

pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
829
  = brack $
830
	hang (ppr body <+> char '|')
831
	     4 (interpp'SP quals)
832
833
\end{code}

834
835
836
837
838
839
840
%************************************************************************
%*									*
		Template Haskell quotation brackets
%*									*
%************************************************************************

\begin{code}
841
data HsSplice id  = HsSplice 	--  $z  or $(f 4)
842
843
844
845
846
847
848
849
850
851
			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


852
853
data HsBracket id = ExpBr (LHsExpr id)		-- [|  expr  |]
		  | PatBr (LPat id)		-- [p| pat   |]
854
		  | DecBr (HsGroup id)		-- [d| decls |]
855
		  | TypBr (LHsType id)		-- [t| type  |]
856
		  | VarBr id			-- 'x, ''T
857
858
859
860
861
862
863

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


pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
864
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
865
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
866
867
868
869
870
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
871
872
873
874
875

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

876
877
878
879
880
881
882
%************************************************************************
%*									*
\subsection{Enumerations and list comprehensions}
%*									*
%************************************************************************

\begin{code}
883
data ArithSeqInfo id
884
885
886
887
888
889
890
891
  = From	    (LHsExpr id)
  | FromThen 	    (LHsExpr id)
		    (LHsExpr id)
  | FromTo	    (LHsExpr id)
		    (LHsExpr id)
  | FromThenTo	    (LHsExpr id)
		    (LHsExpr id)
		    (LHsExpr id)
892
893
894
\end{code}

\begin{code}
895
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
896
897
898
899
900
    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]
901

sof's avatar
sof committed
902
pp_dotdot = ptext SLIT(" .. ")
903
\end{code}
904
905
906
907
908
909
910
911
912


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

\begin{code}
913
914
915
916
data HsMatchContext id	-- Context of a Match
  = FunRhs id			-- Function binding for f
  | CaseAlt			-- Guard on a case alternative
  | LambdaExpr			-- Pattern of a lambda
917
  | ProcExpr			-- Pattern of a proc
918
919
920
921
  | 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
922
923
  deriving ()

924
925
926
data HsStmtContext id
  = ListComp 
  | DoExpr 
927
928
929
  | MDoExpr PostTcTable			-- Recursive do-expression
					-- (tiresomely, it needs table
					--  of its return/bind ops)
930
931
  | PArrComp				-- Parallel array comprehension
  | PatGuard (HsMatchContext id)	-- Pattern guard for specified thing
932
  | ParStmtCtxt (HsStmtContext id)	-- A branch of a parallel stmt 
933
934
935
\end{code}

\begin{code}
936
isDoExpr :: HsStmtContext id -> Bool
937
938
939
isDoExpr DoExpr      = True
isDoExpr (MDoExpr _) = True
isDoExpr other       = False
940
941
942
\end{code}

\begin{code}
943
944
945
matchSeparator (FunRhs _)   = ptext SLIT("=")
matchSeparator CaseAlt      = ptext SLIT("->") 
matchSeparator LambdaExpr   = ptext SLIT("->") 
946
matchSeparator ProcExpr     = ptext SLIT("->") 
947
matchSeparator PatBindRhs   = ptext SLIT("=") 
948
949
matchSeparator (StmtCtxt _) = ptext SLIT("<-")  
matchSeparator RecUpd       = panic "unused"
950
951
952
\end{code}

\begin{code}
953
954
955
956
957
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")
958
pprMatchContext ProcExpr   	  = ptext SLIT("an arrow abstraction")
959
960
pprMatchContext (StmtCtxt ctxt)   = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt

961
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
962
963
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr          = ptext SLIT("a 'do' expression")
964
pprStmtContext (MDoExpr _)     = ptext SLIT("an 'mdo' expression")
965
966
967
pprStmtContext ListComp        = ptext SLIT("a list comprehension")
pprStmtContext PArrComp        = ptext SLIT("an array comprehension")

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

976
977
978
979
980
-- 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
981
-}
982
983

-- Used to generate the string for a *runtime* error message
984
985
986
987
988
matchContextErrString (FunRhs fun)    	      	 = "function " ++ showSDoc (ppr fun)
matchContextErrString CaseAlt	      	      	 = "case"
matchContextErrString PatBindRhs      	      	 = "pattern binding"
matchContextErrString RecUpd	      	      	 = "record update"
matchContextErrString LambdaExpr      	      	 = "lambda"
989
matchContextErrString ProcExpr      	      	 = "proc"
990
991
992
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) 	 = "pattern guard"
matchContextErrString (StmtCtxt DoExpr)       	 = "'do' expression"
993
matchContextErrString (StmtCtxt (MDoExpr _))   	 = "'mdo' expression"
994
995
matchContextErrString (StmtCtxt ListComp)     	 = "list comprehension"
matchContextErrString (StmtCtxt PArrComp)     	 = "array comprehension"
996
\end{code}