HsExpr.lhs 33.1 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

\begin{code}
9
{-# OPTIONS -w #-}
10
11
12
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
13
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
14
15
-- for details

16
17
module HsExpr where

18
#include "HsVersions.h"
19
20

-- friends:
21
22
23
24
25
26
import HsDecls
import HsPat
import HsLit
import HsTypes
import HsImpExp
import HsBinds
27
28

-- others:
29
30
31
import Var
import Name
import BasicTypes
32
import DataCon
33
import SrcLoc
34
import Outputable	
35
import FastString
36
37
\end{code}

38

39
40
41
42
43
44
45
%************************************************************************
%*									*
\subsection{Expressions proper}
%*									*
%************************************************************************

\begin{code}
46
47
type LHsExpr id = Located (HsExpr id)

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
87
88
89
90
91
92
93
-------------------------
-- 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 = []


-------------------------
94
data HsExpr id
95
  = HsVar	id		-- variable
96
  | HsIPVar	(IPName id)	-- implicit parameter
97
  | HsOverLit	(HsOverLit id)	-- Overloaded literals
98
  | HsLit	HsLit		-- Simple (non-overloaded) literals
99

100
101
102
  | HsLam	(MatchGroup  id)	-- Currently always a single match

  | HsApp	(LHsExpr id)		-- Application
103
		(LHsExpr id)
104

105
  -- Operator applications:
106
107
  -- NB Bracketed ops such as (+) come out as Vars.

108
109
110
  -- 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.

111
112
  | OpApp	(LHsExpr id)	-- left operand
		(LHsExpr id)	-- operator
113
		Fixity		-- Renamer adds fixity; bottom until then
114
		(LHsExpr id)	-- right operand
115

116
  | NegApp	(LHsExpr id)	-- negated expr
117
		(SyntaxExpr id)	-- Name of 'negate'
118

119
  | HsPar	(LHsExpr id)	-- parenthesised expr
120

121
122
123
124
  | SectionL	(LHsExpr id)	-- operand
		(LHsExpr id)	-- operator
  | SectionR	(LHsExpr id)	-- operator
		(LHsExpr id)	-- operand
125
				
126
  | HsCase	(LHsExpr id)
127
		(MatchGroup id)
128

129
130
131
  | HsIf	(LHsExpr id)	--  predicate
		(LHsExpr id)	--  then part
		(LHsExpr id)	--  else part
132

133
  | HsLet	(HsLocalBinds id) -- let(rec)
134
		(LHsExpr  id)
135

136
137
  | HsDo	(HsStmtContext Name)	-- The parameterisation is unimportant
					-- because in this context we never use
138
					-- the PatGuard or ParStmt variant
139
		[LStmt id]		-- "do":one or more stmts
140
141
142
		(LHsExpr id)		-- The body; the last expression in the 'do'
					--	     of [ body | ... ] in a list comp
		PostTcType		-- Type of the whole expression
143
144

  | ExplicitList		-- syntactic list
145
		PostTcType	-- Gives type of components of list
146
		[LHsExpr id]
147

chak's avatar
chak committed
148
149
  | ExplicitPArr		-- syntactic parallel array: [:e1, ..., en:]
		PostTcType	-- type of elements of the parallel array
150
		[LHsExpr id]
chak's avatar
chak committed
151

152
  | ExplicitTuple		-- tuple
153
		[LHsExpr id]
154
155
156
				-- NB: Unit is ExplicitTuple []
				-- for tuples, we can get the types
				-- direct from the components
157
		Boxity
158
159


160
	-- Record construction
161
  | RecordCon	(Located id)		-- The constructor.  After type checking
162
					-- it's the dataConWrapId of the constructor
163
		PostTcExpr		-- Data con Id applied to type args
164
		(HsRecordBinds id)
sof's avatar
sof committed
165

166
	-- Record update
167
  | RecordUpd	(LHsExpr id)
168
		(HsRecordBinds id)
169
170
171
172
173
		[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
174

175
  | ExprWithTySig			-- e :: type
176
177
		(LHsExpr id)
		(LHsType id)
178
179
180
181
182

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

183
184
  | ArithSeq				-- arithmetic sequence
		PostTcExpr
185
		(ArithSeqInfo id)
186
187
188

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

191
  | HsSCC	FastString	-- "set cost centre" (_scc_) annotation
192
		(LHsExpr id) 	-- expr whose cost is to be measured
193
194

  | HsCoreAnn   FastString      -- hdaume: core annotation
195
                (LHsExpr id)
196
		
197
  -----------------------------------------------------------
198
  -- MetaHaskell Extensions
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
199

200
  | HsBracket    (HsBracket id)
201
202
203
204
205

  | 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

206
  | HsSpliceE (HsSplice id) 
207

208
209
210
  -----------------------------------------------------------
  -- Arrow notation extension

211
212
  | HsProc	(LPat id)		-- arrow abstraction, proc
		(LHsCmdTop id)		-- body of the abstraction
213
214
215
216
217
218
					-- always has an empty stack

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

  | HsArrApp	-- Arrow tail, or arrow application (f -< arg)
219
220
	(LHsExpr id)	-- arrow expression, f
	(LHsExpr id)	-- input expression, arg
221
222
223
224
225
226
	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
227
  | HsArrForm	-- Command formation,  (| e cmd1 .. cmdn |)
228
	(LHsExpr id)	-- the operator
229
230
231
232
			-- 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
233
	[LHsCmdTop id]	-- argument commands
234

235

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
236
237
238
239
240
  ---------------------------------------
  -- Haskell program coverage (Hpc) Support

  | HsTick 
     Int				-- module-local tick number
241
     [id]                               -- variables in scope
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
242
243
244
245
246
247
248
249
250
251
252
253
254
255
     (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.
256
257
258

  | EWildPat			-- wildcard

259
260
  | EAsPat	(Located id)	-- as pattern
		(LHsExpr id)
261

262
  | ELazyPat	(LHsExpr id) -- ~ pattern
263

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

simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
266
267
  ---------------------------------------
  -- Finally, HsWrap appears only in typechecker output
268

269
  |  HsWrap	HsWrapper 	-- TRANSLATION
270
271
		(HsExpr id)

272
type PendingSplice = (Name, LHsExpr Id)	-- Typechecked splices, waiting to be 
273
					-- pasted back in by the desugarer
274
275
276
277
278
279
280
281
282
\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}
283
instance OutputableBndr id => Outputable (HsExpr id) where
284
    ppr expr = pprExpr expr
285
286
287
\end{code}

\begin{code}
288
289
-----------------------
-- pprExpr, pprLExpr, pprBinds call pprDeeper; 
290
291
-- the underscore versions do not
pprLExpr :: OutputableBndr id => LHsExpr id -> SDoc
292
293
294
pprLExpr (L _ e) = pprExpr e

pprExpr :: OutputableBndr id => HsExpr id -> SDoc
Ian Lynagh's avatar
Ian Lynagh committed
295
296
297
298
299
300
301
302
303
304
305
306
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
307

308
309
pprBinds :: OutputableBndr id => HsLocalBinds id -> SDoc
pprBinds b = pprDeeper (ppr b)
310

311
-----------------------
312
313
ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
314

315
ppr_expr (HsVar v)	 = pprHsVar v
316
ppr_expr (HsIPVar v)     = ppr v
317
318
ppr_expr (HsLit lit)     = ppr lit
ppr_expr (HsOverLit lit) = ppr lit
319
320
321
322
ppr_expr (HsPar e)	 = parens (ppr_lexpr e)

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

324
325
ppr_expr (HsApp e1 e2)
  = let (fun, args) = collect_args e1 [e2] in
326
    hang (ppr_lexpr fun) 2 (sep (map pprParendExpr args))
327
  where
328
329
    collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args)
    collect_args fun args = (fun, args)
330

331
ppr_expr (OpApp e1 op fixity e2)
332
  = case unLoc op of
333
334
335
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
336
337
    pp_e1 = pprDebugParendExpr e1   -- In debug mode, add parens 
    pp_e2 = pprDebugParendExpr e2   -- to make precedence clear
338
339

    pp_prefixly
340
      = hang (ppr op) 2 (sep [pp_e1, pp_e2])
341
342

    pp_infixly v
343
      = sep [nest 2 pp_e1, pprInfix v, nest 2 pp_e2]
344

345
ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
346

347
ppr_expr (SectionL expr op)
348
  = case unLoc op of
349
350
351
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
352
    pp_expr = pprDebugParendExpr expr
353

354
    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])
sof's avatar
sof committed
355
		       4 (hsep [pp_expr, ptext SLIT("x_ )")])
356
    pp_infixly v = parens (sep [pp_expr, pprInfix v])
357

358
ppr_expr (SectionR op expr)
359
  = case unLoc op of
360
361
362
      HsVar v -> pp_infixly v
      _	      -> pp_prefixly
  where
363
    pp_expr = pprDebugParendExpr expr
364

365
    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext SLIT("x_")])
sof's avatar
sof committed
366
		       4 ((<>) pp_expr rparen)
367
    pp_infixly v
368
      = parens (sep [pprInfix v, pp_expr])
369

370
371
372
ppr_expr (HsLam matches) 
  = pprMatches LambdaExpr matches

373
374
ppr_expr (HsCase expr matches)
  = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")],
375
	    nest 2 (pprMatches CaseAlt matches) ]
376

377
378
379
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
380
	   ptext SLIT("else"),
381
	   nest 4 (ppr e3)]
382
383

-- special case: let ... in let ...
384
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
385
  = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]),
386
	 ppr_lexpr expr]
387

388
ppr_expr (HsLet binds expr)
389
  = sep [hang (ptext SLIT("let")) 2 (pprBinds binds),
390
	 hang (ptext SLIT("in"))  2 (ppr expr)]
391

392
ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body
393

394
ppr_expr (ExplicitList _ exprs)
395
  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
396

chak's avatar
chak committed
397
ppr_expr (ExplicitPArr _ exprs)
398
  = pa_brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
chak's avatar
chak committed
399

400
ppr_expr (ExplicitTuple exprs boxity)
401
  = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs)))
402

403
ppr_expr (RecordCon con_id con_expr rbinds)
404
  = hang (ppr con_id) 2 (ppr rbinds)
405

406
ppr_expr (RecordUpd aexp rbinds _ _ _)
407
  = hang (pprParendExpr aexp) 2 (ppr rbinds)
408
409

ppr_expr (ExprWithTySig expr sig)
410
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
411
	 4 (ppr sig)
412
413
414
ppr_expr (ExprWithTySigOut expr sig)
  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)
	 4 (ppr sig)
415

416
417
ppr_expr (ArithSeq expr info) = brackets (ppr info)
ppr_expr (PArrSeq expr info)  = pa_brackets (ppr info)
chak's avatar
chak committed
418

419
ppr_expr EWildPat     = char '_'
420
421
422
423
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e

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

426
ppr_expr (HsWrap co_fn e) = pprHsWrapper (pprExpr e) co_fn
427
ppr_expr (HsType id)	    = ppr id
chak's avatar
chak committed
428

429
430
ppr_expr (HsSpliceE s)       = pprSplice s
ppr_expr (HsBracket b)       = pprHsBracket b
431
432
ppr_expr (HsBracketOut e []) = ppr e	
ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("pending") <+> ppr ps
433

434
435
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
  = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd]
436

437
438
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
439
440
441
442
443
444
445
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
446
447
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
448

449
450
451
452
453
454
455
456
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]
457

458
459
460
461
462
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("|)"))
463
464

pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc
465
466
467
468
pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _)
  = ppr_lexpr cmd
pprCmdArg (HsCmdTop cmd _ _ _)
  = parens (ppr_lexpr cmd)
469
470
471
472
473
474
475
476

-- 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
477
478
-- add parallel array brackets around a document
--
479
480
pa_brackets :: SDoc -> SDoc
pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]")    
481
482
\end{code}

483
484
485
486
487
488
489
490
491
492
HsSyn records exactly where the user put parens, with HsPar.
So generally speaking we print without adding any parens.
However, some code is internally generated, and in some places
parens are absolutely required; so for these places we use
pprParendExpr (but don't print double parens of course).

For operator applications we don't add parens, because the oprerator
fixities should do the job, except in debug mode (-dppr-debug) so we
can see the structure of the parse tree.

493
\begin{code}
494
495
496
497
498
499
pprDebugParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprDebugParendExpr expr
  = getPprStyle (\sty ->
    if debugStyle sty then pprParendExpr expr
		      else pprLExpr      expr)
  
500
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
501
pprParendExpr expr
502
  = let
503
504
505
	pp_as_was = pprLExpr expr
	-- Using pprLExpr makes sure that we go 'deeper'
	-- I think that is usually (always?) right
506
    in
507
    case unLoc expr of
508
509
510
511
512
513
514
515
516
517
518
519
520
      HsLit l		   -> pp_as_was
      HsOverLit l 	   -> pp_as_was
      HsVar _		   -> pp_as_was
      HsIPVar _		   -> pp_as_was
      ExplicitList _ _     -> pp_as_was
      ExplicitPArr _ _     -> pp_as_was
      ExplicitTuple _ _	   -> pp_as_was
      HsPar _		   -> pp_as_was
      HsBracket _	   -> pp_as_was
      HsBracketOut _ []	   -> pp_as_was
      HsDo sc _ _ _
       | isListCompExpr sc -> pp_as_was
      _			   -> parens pp_as_was
521
522
523
524
525
526
527
528
529

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
530
531
\end{code}

532
533
534
535
536
537
538
539
540
541
542
%************************************************************************
%*									*
\subsection{Commands (in arrow abstractions)}
%*									*
%************************************************************************

We re-use HsExpr to represent these.

\begin{code}
type HsCmd id = HsExpr id

543
544
type LHsCmd id = LHsExpr id

545
546
547
548
549
550
551
552
553
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}

The legal constructors for commands are:

  = HsArrApp ...		-- as above

  | HsArrForm ...		-- as above

ross's avatar
ross committed
554
555
556
  | HsApp	(HsCmd id)
		(HsExpr id)

557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
  | 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

576
  | HsLet	(HsLocalBinds id)	-- let(rec)
577
578
579
580
581
582
583
584
585
586
587
588
589
590
		(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}
591
592
type LHsCmdTop id = Located (HsCmdTop id)

593
data HsCmdTop id
594
  = HsCmdTop	(LHsCmd id)
595
596
		[PostTcType]	-- types of inputs on the command's stack
		PostTcType	-- return type of the command
597
		(SyntaxTable id)
598
599
600
601
				-- after type checking:
				-- names used in the command's desugaring
\end{code}

602
603
604
605
606
607
608
%************************************************************************
%*									*
\subsection{Record binds}
%*									*
%************************************************************************

\begin{code}
609
type HsRecordBinds id = HsRecFields id (LHsExpr id)
610
611
\end{code}

612
613


614
615
%************************************************************************
%*									*
616
\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}
617
618
619
%*									*
%************************************************************************

620
621
622
623
624
625
626
627
628
629
630
631
632
633
@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.

634
\begin{code}
635
636
637
638
639
640
641
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

642
643
type LMatch id = Located (Match id)

644
data Match id
645
  = Match
646
647
	[LPat id]		-- The patterns
	(Maybe (LHsType id))	-- A type signature for the result of the match
648
				--	Nothing after typechecking
649
	(GRHSs id)
650

651
matchGroupArity :: MatchGroup id -> Arity
652
653
matchGroupArity (MatchGroup [] _) 
  = panic "matchGroupArity"	-- MatchGroup is never empty
654
655
656
657
658
659
660
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)

661
662
663
hsLMatchPats :: LMatch id -> [LPat id]
hsLMatchPats (L _ (Match pats _ _)) = pats

664
-- GRHSs are used both for pattern bindings and for Matches
665
data GRHSs id	
666
  = GRHSs [LGRHS id]		-- Guarded RHSs
667
	  (HsLocalBinds id)	-- The where clause
668

669
type LGRHS id = Located (GRHS id)
670

671
672
data GRHS id = GRHS [LStmt id]		-- Guards
		    (LHsExpr id)	-- Right hand side
673
\end{code}
674

675
We know the list must have at least one @Match@ in it.
676

677
\begin{code}
678
pprMatches :: (OutputableBndr id) => HsMatchContext id -> MatchGroup id -> SDoc
679
680
681
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
682
683

-- Exported to HsBinds, which can't see the defn of HsMatchContext
684
685
pprFunBind :: (OutputableBndr id) => id -> Bool -> MatchGroup id -> SDoc
pprFunBind fun inf matches = pprMatches (FunRhs fun inf) matches
686
687

-- Exported to HsBinds, which can't see the defn of HsMatchContext
688
689
pprPatBind :: (OutputableBndr bndr, OutputableBndr id)
	   => LPat bndr -> GRHSs id -> SDoc
690
pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
691
692


693
pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc
694
pprMatch ctxt (Match pats maybe_ty grhss)
695
696
697
  = herald <+> sep [sep (map ppr other_pats), 
		    ppr_maybe_ty, 
		    nest 2 (pprGRHSs ctxt grhss)]
698
  where
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
    (herald, other_pats) 
	= case ctxt of
	    FunRhs fun is_infix
		| not is_infix -> (ppr fun, pats)
			-- f x y z = e
			-- Not pprBndr; the AbsBinds will
			-- have printed the signature

		| null pats3 -> (pp_infix, [])
			-- x &&& y = e

		| otherwise -> (parens pp_infix, pats3)
			-- (x &&& y) z = e
		where
		  (pat1:pat2:pats3) = pats
		  pp_infix = ppr pat1 <+> ppr fun <+> ppr pat2

	    LambdaExpr -> (char '\\', pats)
	    other      -> (empty,     pats)
718

719
720
721
722
723
    ppr_maybe_ty = case maybe_ty of
			Just ty -> dcolon <+> ppr ty
			Nothing -> empty


724
pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc
725
pprGRHSs ctxt (GRHSs grhss binds)
Ian Lynagh's avatar
Ian Lynagh committed
726
727
728
  = vcat (map (pprGRHS ctxt . unLoc) grhss)
 $$ if isEmptyLocalBinds binds then empty
                               else text "where" $$ nest 4 (pprBinds binds)
729

730
pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc
731

732
pprGRHS ctxt (GRHS [] expr)
733
 =  pp_rhs ctxt expr
734

735
pprGRHS ctxt (GRHS guards expr)
736
 = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr]
737

738
pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)
739
\end{code}
740

741
742
743
744
745
746
747
%************************************************************************
%*									*
\subsection{Do stmts and list comprehensions}
%*									*
%************************************************************************

\begin{code}
748
749
type LStmt id = Located (Stmt id)

750
751
-- The SyntaxExprs in here are used *only* for do-notation, which
-- has rebindable syntax.  Otherwise they are unused.
752
data Stmt id
753
754
755
756
757
758
759
760
761
762
763
  = 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)

764
  | LetStmt	(HsLocalBinds id)	
765
766

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

770
	-- Recursive statement (see Note [RecStmt] below)
771
  | RecStmt  [LStmt id] 
772
773
774
775
776
777
778
779
		--- 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

780
781
		--- These fields are only valid after typechecking
	     [PostTcExpr]	-- These expressions correspond
782
783
784
785
				-- 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*.
786
787
	     (DictBinds id)	-- Method bindings of Ids bound by the RecStmt,
				-- and used afterwards
788
789
\end{code}

790
ExprStmts are a bit tricky, because what they mean
791
depends on the context.  Consider the following contexts:
792
793
794

	A do expression of type (m res_ty)
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
795
	* ExprStmt E any_ty:   do { ....; E; ... }
796
797
798
799
800
		E :: m any_ty
	  Translation: E >> ...
	
	A list comprehensions of type [elt_ty]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
801
	* ExprStmt E Bool:   [ .. | .... E ]
802
803
			[ .. | ..., E, ... ]
			[ .. | .... | ..., E | ... ]
804
805
		E :: Bool
	  Translation: if E then fail else ...
806

807
808
	A guard list, guarding a RHS of type rhs_ty
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
809
	* ExprStmt E Bool:   f x | ..., E, ... = ...rhs...
810
811
812
		E :: Bool
	  Translation: if E then fail else ...
	
chak's avatar
chak committed
813
Array comprehensions are handled like list comprehensions -=chak
814

815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
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.


839
\begin{code}
840
instance OutputableBndr id => Outputable (Stmt id) where
841
842
    ppr stmt = pprStmt stmt

843
844
845
846
847
848
849
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
850
851
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])
852
853
pprDo ListComp    stmts body = pprComp brackets    stmts body
pprDo PArrComp    stmts body = pprComp pa_brackets stmts body
854
pprDo other	  stmts body = panic "pprDo" 	-- PatGuard, ParStmtCxt
855
856
857

pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> LHsExpr id -> SDoc
pprComp brack quals body
858
  = brack $
859
	hang (ppr body <+> char '|')
860
	     4 (interpp'SP quals)
861
862
\end{code}

863
864
865
866
867
868
869
%************************************************************************
%*									*
		Template Haskell quotation brackets
%*									*
%************************************************************************

\begin{code}
870
data HsSplice id  = HsSplice 	--  $z  or $(f 4)
871
872
873
874
875
876
877
			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
878
pprSplice (HsSplice n e) = char '$' <> ifPprDebug (brackets (ppr n)) <> pprParendExpr e
879
880


881
882
data HsBracket id = ExpBr (LHsExpr id)		-- [|  expr  |]
		  | PatBr (LPat id)		-- [p| pat   |]
883
		  | DecBr (HsGroup id)		-- [d| decls |]
884
		  | TypBr (LHsType id)		-- [t| type  |]
885
		  | VarBr id			-- 'x, ''T
886
887
888
889
890
891
892

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


pprHsBracket (ExpBr e) = thBrackets empty (ppr e)
pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p)
893
pprHsBracket (DecBr d) = thBrackets (char 'd') (ppr d)
894
pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t)
895
896
897
898
899
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
900
901
902
903
904

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

905
906
907
908
909
910
911
%************************************************************************
%*									*
\subsection{Enumerations and list comprehensions}
%*									*
%************************************************************************

\begin{code}
912
data ArithSeqInfo id
913
914
915
916
917
918
919
920
  = From	    (LHsExpr id)
  | FromThen 	    (LHsExpr id)
		    (LHsExpr id)
  | FromTo	    (LHsExpr id)
		    (LHsExpr id)
  | FromThenTo	    (LHsExpr id)
		    (LHsExpr id)
		    (LHsExpr id)
921
922
923
\end{code}

\begin{code}
924
instance OutputableBndr id => Outputable (ArithSeqInfo id) where
925
926
927
928
929
    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]
930

sof's avatar
sof committed
931
pp_dotdot = ptext SLIT(" .. ")
932
\end{code}
933
934
935
936
937
938
939
940
941


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

\begin{code}
942
data HsMatchContext id	-- Context of a Match
943
  = FunRhs id Bool		-- Function binding for f; True <=> written infix
944
945
  | CaseAlt			-- Guard on a case alternative
  | LambdaExpr			-- Pattern of a lambda
946
  | ProcExpr			-- Pattern of a proc
947
948
949
950
  | 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
951
952
  deriving ()

953
954
955
data HsStmtContext id
  = ListComp 
  | DoExpr 
956
957
958
  | MDoExpr PostTcTable			-- Recursive do-expression
					-- (tiresomely, it needs table
					--  of its return/bind ops)
959
960
  | PArrComp				-- Parallel array comprehension
  | PatGuard (HsMatchContext id)	-- Pattern guard for specified thing
961
  | ParStmtCtxt (HsStmtContext id)	-- A branch of a parallel stmt 
962
963
964
\end{code}

\begin{code}
965
isDoExpr :: HsStmtContext id -> Bool
966
967
isDoExpr DoExpr      = True
isDoExpr (MDoExpr _) = True
968
969
970
971
972
973
isDoExpr _           = False

isListCompExpr :: HsStmtContext id -> Bool
isListCompExpr ListComp = True
isListCompExpr PArrComp = True
isListCompExpr _        = False
974
975
976
\end{code}

\begin{code}
977
matchSeparator (FunRhs {})  = ptext SLIT("=")
978
979
matchSeparator CaseAlt      = ptext SLIT("->") 
matchSeparator LambdaExpr   = ptext SLIT("->") 
980
matchSeparator ProcExpr     = ptext SLIT("->") 
981
matchSeparator PatBindRhs   = ptext SLIT("=") 
982
983
matchSeparator (StmtCtxt _) = ptext SLIT("<-")  
matchSeparator RecUpd       = panic "unused"
984
985
986
\end{code}

\begin{code}
987
pprMatchContext (FunRhs fun _) 	  = ptext SLIT("the definition of") <+> quotes (ppr fun)
988
989
990
991
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")
992
pprMatchContext ProcExpr   	  = ptext SLIT("an arrow abstraction")
993
994
pprMatchContext (StmtCtxt ctxt)   = ptext SLIT("a pattern binding in") $$ pprStmtContext ctxt

995
pprStmtContext (ParStmtCtxt c) = sep [ptext SLIT("a parallel branch of"), pprStmtContext c]
996
997
pprStmtContext (PatGuard ctxt) = ptext SLIT("a pattern guard for") $$ pprMatchContext ctxt
pprStmtContext DoExpr          = ptext SLIT("a 'do' expression")
998
pprStmtContext (MDoExpr _)     = ptext SLIT("an 'mdo' expression")
999
1000
1001
pprStmtContext ListComp        = ptext SLIT("a list comprehension")
pprStmtContext PArrComp        = ptext SLIT("an array comprehension")

1002
1003
1004
1005
1006
1007
1008
1009
{- 
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

1010
1011
1012
1013
1014
-- 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
1015
-}
1016
1017

-- Used to generate the string for a *runtime* error message
1018
matchContextErrString (FunRhs fun _)   	      	 = "function " ++ showSDoc (ppr fun)
1019
1020
1021
1022
matchContextErrString CaseAlt	      	      	 = "case"
matchContextErrString PatBindRhs      	      	 = "pattern binding"
matchContextErrString RecUpd	      	      	 = "record update"
matchContextErrString LambdaExpr      	      	 = "lambda"
1023
matchContextErrString ProcExpr      	      	 = "proc"
1024
1025
1026
matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c)
matchContextErrString (StmtCtxt (PatGuard _)) 	 = "pattern guard"
matchContextErrString (StmtCtxt DoExpr)       	 = "'do' expression"
1027
matchContextErrString (StmtCtxt (MDoExpr _))   	 = "'mdo' expression"
1028
1029
matchContextErrString (StmtCtxt ListComp)     	 = "list comprehension"
matchContextErrString (StmtCtxt PArrComp)     	 = "array comprehension"
1030
\end{code}