HsBinds.lhs 15.4 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
%
\section[HsBinds]{Abstract syntax: top-level bindings and signatures}

6
Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
7
8
9
10

\begin{code}
module HsBinds where

11
#include "HsVersions.h"
12

13
import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr,
14
			       MatchGroup, pprFunBind,
15
			       GRHSs, pprPatBind )
16
import {-# SOURCE #-} HsPat  ( LPat )
sof's avatar
sof committed
17

18
import HsTypes		( LHsType, PostTcType )
19
import Type		( Type )
20
import Name		( Name )
21
import NameSet		( NameSet, elemNameSet )
22
import BasicTypes	( IPName, RecFlag(..), InlineSpec(..), Fixity )
23
import Outputable	
24
25
import SrcLoc		( Located(..), SrcSpan, unLoc )
import Util		( sortLe )
26
import Var		( TyVar, DictId, Id )
27
import Bag		( Bag, emptyBag, isEmptyBag, bagToList, unionBags, unionManyBags )
28
29
30
31
\end{code}

%************************************************************************
%*									*
32
\subsection{Bindings: @BindGroup@}
33
34
35
%*									*
%************************************************************************

36
Global bindings (where clauses)
37
38

\begin{code}
39
40
41
42
data HsLocalBinds id	-- Bindings in a 'let' expression
			-- or a 'where' clause
  = HsValBinds (HsValBinds id)
  | HsIPBinds  (HsIPBinds id)
43

44
  | EmptyLocalBinds
sof's avatar
sof committed
45

46
47
48
49
data HsValBinds id	-- Value bindings (not implicit parameters)
  = ValBindsIn  			-- Before typechecking
	(LHsBinds id) [LSig id]		-- Not dependency analysed
					-- Recursive by default
50

51
  | ValBindsOut				-- After renaming
52
	[(RecFlag, LHsBinds id)]	-- Dependency analysed
53
	[LSig Name]
54

55
56
57
58
type LHsBinds id  = Bag (LHsBind id)
type DictBinds id = LHsBinds id		-- Used for dictionary or method bindings
type LHsBind  id  = Located (HsBind id)

59
data HsBind id
60
61
  = FunBind {	-- FunBind is used for both functions 	f x = e
		-- and variables			f = \x -> e
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
62
63
64
65
66
67
68
-- Reason 1: the Match stuff lets us have an optional
--	   result type sig	f :: a->a = ...mentions a...
--
-- Reason 2: Special case for type inference: see TcBinds.tcMonoBinds
--
-- Reason 3: instance decls can only have FunBinds, which is convenient
--	     If you change this, you'll need tochange e.g. rnMethodBinds
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88

	fun_id :: Located id,

	fun_infix :: Bool,	-- True => infix declaration

	fun_matches :: MatchGroup id,	-- The payload

	fun_co_fn :: ExprCoFn,	-- Coercion from the type of the MatchGroup to the type of
				-- the Id.  Example:
				--	f :: Int -> forall a. a -> a
				--	f x y = y
				-- Then the MatchGroup will have type (Int -> a' -> a')
				-- (with a free type variable a').  The coercion will take
				-- a CoreExpr of this type and convert it to a CoreExpr of
				-- type 	Int -> forall a'. a' -> a'
				-- Notice that the coercion captures the free a'.  That's
				-- why coercions are (CoreExpr -> CoreExpr), rather than
				-- just CoreExpr (with a functional type)

	bind_fvs :: NameSet	-- After the renamer, this contains a superset of the 
89
90
91
92
				-- Names of the other binders in this binding group that 
				-- are free in the RHS of the defn
				-- Before renaming, and after typechecking, 
				-- the field is unused; it's just an error thunk
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
    }

  | PatBind {	-- The pattern is never a simple variable;
		-- That case is done by FunBind
	pat_lhs    :: LPat id,
	pat_rhs    :: GRHSs id,
	pat_rhs_ty :: PostTcType,	-- Type of the GRHSs
	bind_fvs   :: NameSet		-- Same as for FunBind
    }

  | VarBind {	-- Dictionary binding and suchlike 
	var_id :: id,		-- All VarBinds are introduced by the type checker
	var_rhs :: LHsExpr id	-- Located only for consistency
    }

  | AbsBinds {					-- Binds abstraction; TRANSLATION
	abs_tvs     :: [TyVar],  
	abs_dicts   :: [DictId],
	abs_exports :: [([TyVar], id, id, [Prag])],	-- (tvs, poly_id, mono_id, prags)
	abs_binds   :: LHsBinds id		-- The dictionary bindings and typechecked user bindings
113
114
						-- mixed up together; you can tell the dict bindings because
						-- they are all VarBinds
115
    }
116
117
118
119
120
121
122
123
124
	-- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds]
	-- 
	-- Creates bindings for (polymorphic, overloaded) poly_f
	-- in terms of monomorphic, non-overloaded mono_f
	--
	-- Invariants: 
	--	1. 'binds' binds mono_f
	--	2. ftvs is a subset of tvs
	--	3. ftvs includes all tyvars free in ds
125
126
127
128
	--
	-- See section 9 of static semantics paper for more details.
	-- (You can get a PhD for explaining the True Meaning
	--  of this last construct.)
129
130
131
132
133
134
135
136
137
138
139
140
141

placeHolderNames :: NameSet
-- Used for the NameSet in FunBind and PatBind prior to the renamer
placeHolderNames = panic "placeHolderNames"

------------
instance OutputableBndr id => Outputable (HsLocalBinds id) where
  ppr (HsValBinds bs) = ppr bs
  ppr (HsIPBinds bs)  = ppr bs
  ppr EmptyLocalBinds = empty

instance OutputableBndr id => Outputable (HsValBinds id) where
  ppr (ValBindsIn binds sigs)
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
   = pprValBindsForUser binds sigs

  ppr (ValBindsOut sccs sigs) 
    = getPprStyle $ \ sty ->
      if debugStyle sty then	-- Print with sccs showing
	vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)
     else
	pprValBindsForUser (unionManyBags (map snd sccs)) sigs
   where
     ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds
     pp_rec Recursive    = ptext SLIT("rec")
     pp_rec NonRecursive = ptext SLIT("nonrec")

--  *not* pprLHsBinds because we don't want braces; 'let' and
-- 'where' include a list of HsBindGroups and we don't want
-- several groups of bindings each with braces around.
-- Sort by location before printing
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
159
160
pprValBindsForUser :: (OutputableBndr id1, OutputableBndr id2)
		   => LHsBinds id1 -> [LSig id2] -> SDoc
161
162
163
164
165
166
167
168
169
pprValBindsForUser binds sigs
  = vcat (map snd (sort_by_loc decls))
  where

    decls :: [(SrcSpan, SDoc)]
    decls = [(loc, ppr sig)  | L loc sig <- sigs] ++
    	    [(loc, ppr bind) | L loc bind <- bagToList binds]

    sort_by_loc decls = sortLe (\(l1,_) (l2,_) -> l1 <= l2) decls
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185

pprLHsBinds :: OutputableBndr id => LHsBinds id -> SDoc
pprLHsBinds binds 
  | isEmptyLHsBinds binds = empty
  | otherwise = lbrace <+> vcat (map ppr (bagToList binds)) <+> rbrace

------------
emptyLocalBinds :: HsLocalBinds a
emptyLocalBinds = EmptyLocalBinds

isEmptyLocalBinds :: HsLocalBinds a -> Bool
isEmptyLocalBinds (HsValBinds ds) = isEmptyValBinds ds
isEmptyLocalBinds (HsIPBinds ds)  = isEmptyIPBinds ds
isEmptyLocalBinds EmptyLocalBinds = True

isEmptyValBinds :: HsValBinds a -> Bool
186
187
isEmptyValBinds (ValBindsIn ds sigs)  = isEmptyLHsBinds ds && null sigs
isEmptyValBinds (ValBindsOut ds sigs) = null ds && null sigs
188
189
190

emptyValBindsIn, emptyValBindsOut :: HsValBinds a
emptyValBindsIn  = ValBindsIn emptyBag []
191
emptyValBindsOut = ValBindsOut []      []
192
193
194
195
196
197
198
199
200
201
202

emptyLHsBinds :: LHsBinds id
emptyLHsBinds = emptyBag

isEmptyLHsBinds :: LHsBinds id -> Bool
isEmptyLHsBinds = isEmptyBag

------------
plusHsValBinds :: HsValBinds a -> HsValBinds a -> HsValBinds a
plusHsValBinds (ValBindsIn ds1 sigs1) (ValBindsIn ds2 sigs2)
  = ValBindsIn (ds1 `unionBags` ds2) (sigs1 ++ sigs2)
203
204
plusHsValBinds (ValBindsOut ds1 sigs1) (ValBindsOut ds2 sigs2)
  = ValBindsOut (ds1 ++ ds2) (sigs1 ++ sigs2)
205
206
\end{code}

207
208
What AbsBinds means
~~~~~~~~~~~~~~~~~~~
sof's avatar
sof committed
209
	 AbsBinds tvs
210
		  [d1,d2]
sof's avatar
sof committed
211
212
		  [(tvs1, f1p, f1m), 
		   (tvs2, f2p, f2m)]
213
214
215
		  BIND
means

sof's avatar
sof committed
216
	f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND 
217
218
219
220
221
222
223
224
225
226
227
				      in fm

	gp = ...same again, with gm instead of fm

This is a pretty bad translation, because it duplicates all the bindings.
So the desugarer tries to do a better job:

	fp = /\ [a,b] -> \ [d1,d2] -> case tp [a,b] [d1,d2] of
					(fm,gm) -> fm
	..ditto for gp..

228
229
	tp = /\ [a,b] -> \ [d1,d2] -> letrec DBINDS and BIND 
				       in (fm,gm)
230

231
\begin{code}
232
instance OutputableBndr id => Outputable (HsBind id) where
233
    ppr mbind = ppr_monobind mbind
sof's avatar
sof committed
234

235
ppr_monobind :: OutputableBndr id => HsBind id -> SDoc
236

237
238
239
ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })      = pprPatBind pat grhss
ppr_monobind (VarBind { var_id = var, var_rhs = rhs })         = ppr var <+> equals <+> pprExpr (unLoc rhs)
ppr_monobind (FunBind { fun_id = fun, fun_matches = matches }) = pprFunBind (unLoc fun) matches
sof's avatar
sof committed
240
241
      -- ToDo: print infix if appropriate

242
243
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_dicts = dictvars, 
			 abs_exports = exports, abs_binds = val_binds })
244
245
246
     = sep [ptext SLIT("AbsBinds"),
	    brackets (interpp'SP tyvars),
	    brackets (interpp'SP dictvars),
247
	    brackets (sep (punctuate comma (map ppr_exp exports)))]
248
       $$
249
       nest 2 ( vcat [pprBndr LetBind x | (_,x,_,_) <- exports]
250
			-- Print type signatures
251
252
253
254
255
		$$ pprLHsBinds val_binds )
  where
    ppr_exp (tvs, gbl, lcl, prags)
	= vcat [ppr gbl <+> ptext SLIT("<=") <+> ppr tvs <+> ppr lcl,
	  	nest 2 (vcat (map (pprPrag gbl) prags))]
256
257
\end{code}

258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
%************************************************************************
%*									*
		Implicit parameter bindings
%*									*
%************************************************************************

\begin{code}
data HsIPBinds id
  = IPBinds 
	[LIPBind id] 
	(DictBinds id)	-- Only in typechecker output; binds 
			-- uses of the implicit parameters

isEmptyIPBinds :: HsIPBinds id -> Bool
isEmptyIPBinds (IPBinds is ds) = null is && isEmptyBag ds

type LIPBind id = Located (IPBind id)

-- | Implicit parameter bindings.
data IPBind id
  = IPBind
	(IPName id)
	(LHsExpr id)

instance (OutputableBndr id) => Outputable (HsIPBinds id) where
  ppr (IPBinds bs ds) = vcat (map ppr bs) 
			$$ pprLHsBinds ds

instance (OutputableBndr id) => Outputable (IPBind id) where
  ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
\end{code}


291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
%************************************************************************
%*									*
\subsection{Coercion functions}
%*									*
%************************************************************************

\begin{code}
-- A Coercion is an expression with a hole in it
-- We need coercions to have concrete form so that we can zonk them

data ExprCoFn
  = CoHole			-- The identity coercion
  | CoCompose ExprCoFn ExprCoFn
  | CoApps ExprCoFn [Id]		-- Non-empty list
  | CoTyApps ExprCoFn [Type]		--   in all of these
  | CoLams [Id] ExprCoFn		--   so that the identity coercion
  | CoTyLams [TyVar] ExprCoFn		--   is just Hole
  | CoLet (LHsBinds Id) ExprCoFn	-- Would be nicer to be core bindings

(<.>) :: ExprCoFn -> ExprCoFn -> ExprCoFn
(<.>) = CoCompose

idCoercion :: ExprCoFn
idCoercion = CoHole

isIdCoercion :: ExprCoFn -> Bool
isIdCoercion CoHole = True
isIdCoercion other  = False
\end{code}


322
323
324
325
326
327
328
329
330
331
332
333
%************************************************************************
%*									*
\subsection{@Sig@: type signatures and value-modifying user pragmas}
%*									*
%************************************************************************

It is convenient to lump ``value-modifying'' user-pragmas (e.g.,
``specialise this function to these four types...'') in with type
signatures.  Then all the machinery to move them into place, etc.,
serves for both.

\begin{code}
334
335
type LSig name = Located (Sig name)

336
data Sig name
337
  = TypeSig	(Located name)	-- A bog-std type signature
338
		(LHsType name)
339

340
  | SpecSig 	(Located name)	-- Specialise a function or datatype ...
341
		(LHsType name)	-- ... to these types
342
		InlineSpec
343

344
345
  | InlineSig	(Located name)	-- Function name
		InlineSpec
346

347
  | SpecInstSig (LHsType name)	-- (Class tys); should be a specialisation of the 
348
349
				-- current instance decl

350
  | FixSig	(FixitySig name)	-- Fixity declaration
351

352
353
type LFixitySig name = Located (FixitySig name)
data FixitySig name = FixitySig (Located name) Fixity 
354
355
356

-- A Prag conveys pragmas from the type checker to the desugarer
data Prag 
357
358
  = InlinePrag 
	InlineSpec
359
360
361
362
363

  | SpecPrag   
	(HsExpr Id)	-- An expression, of the given specialised type, which
	PostTcType 	-- specialises the polymorphic function
	[Id]		-- Dicts mentioned free in the expression
364
	InlineSpec 	-- Inlining spec for the specialised function
365

366
367
isInlinePrag (InlinePrag _) = True
isInlinePrag prag	    = False
368

369
370
isSpecPrag (SpecPrag _ _ _ _) = True
isSpecPrag prag		      = False
sof's avatar
sof committed
371
372
373
\end{code}

\begin{code}
374
375
okBindSig :: NameSet -> LSig Name -> Bool
okBindSig ns sig = sigForThisGroup ns sig
376

377
okHsBootSig :: LSig Name -> Bool
378
379
380
okHsBootSig (L _ (TypeSig  _ _)) = True
okHsBootSig (L _ (FixSig _)) 	 = True
okHsBootSig sig	      	     	 = False
381

382
383
384
okClsDclSig :: LSig Name -> Bool
okClsDclSig (L _ (SpecInstSig _)) = False
okClsDclSig sig 	          = True	-- All others OK
385

386
387
388
okInstDclSig :: NameSet -> LSig Name -> Bool
okInstDclSig ns lsig@(L _ sig) = ok ns sig
  where
389
    ok ns (TypeSig _ _)	  = False
390
391
392
    ok ns (FixSig _)	  = False
    ok ns (SpecInstSig _) = True
    ok ns sig		  = sigForThisGroup ns lsig
393

394
395
sigForThisGroup :: NameSet -> LSig Name -> Bool
sigForThisGroup ns sig
396
  = case sigName sig of
397
398
	Nothing -> False
	Just n  -> n `elemNameSet` ns
399

400
401
402
sigName :: LSig name -> Maybe name
sigName (L _ sig) = f sig
 where
403
404
405
    f (TypeSig   n _)          = Just (unLoc n)
    f (SpecSig   n _ _)        = Just (unLoc n)
    f (InlineSig n _)          = Just (unLoc n)
406
407
    f (FixSig (FixitySig n _)) = Just (unLoc n)
    f other			= Nothing
408

409
isFixityLSig :: LSig name -> Bool
410
411
isFixityLSig (L _ (FixSig {})) = True
isFixityLSig _	               = False
sof's avatar
sof committed
412

413
isVanillaLSig :: LSig name -> Bool
414
415
isVanillaLSig (L _(TypeSig {})) = True
isVanillaLSig sig	        = False
416

417
isSpecLSig :: LSig name -> Bool
418
419
isSpecLSig (L _(SpecSig {})) = True
isSpecLSig sig	     	     = False
420

421
422
isSpecInstLSig (L _ (SpecInstSig {})) = True
isSpecInstLSig sig	       	      = False
423

424
isPragLSig :: LSig name -> Bool
425
	-- Identifies pragmas 
426
427
428
429
430
431
432
433
434
435
436
437
438
439
isPragLSig (L _ (SpecSig {}))   = True
isPragLSig (L _ (InlineSig {})) = True
isPragLSig other		= False

isInlineLSig :: LSig name -> Bool
	-- Identifies inline pragmas 
isInlineLSig (L _ (InlineSig {})) = True
isInlineLSig other		  = False

hsSigDoc (TypeSig {}) 		= ptext SLIT("type signature")
hsSigDoc (SpecSig {})	 	= ptext SLIT("SPECIALISE pragma")
hsSigDoc (InlineSig _ spec)   	= ppr spec <+> ptext SLIT("pragma")
hsSigDoc (SpecInstSig {})	= ptext SLIT("SPECIALISE instance pragma")
hsSigDoc (FixSig {}) 		= ptext SLIT("fixity declaration")
440
441
\end{code}

442
443
444
Signature equality is used when checking for duplicate signatures

\begin{code}
445
446
eqHsSig :: LSig Name -> LSig Name -> Bool
eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2
447
448
eqHsSig (L _ (TypeSig n1 _))         	(L _ (TypeSig n2 _))            = unLoc n1 == unLoc n2
eqHsSig (L _ (InlineSig n1 s1))	(L _ (InlineSig n2 s2))    	        = s1 == s2 && unLoc n1 == unLoc n2
449
450
451
452
453
454
 	-- For specialisations, we don't have equality over
	-- HsType, so it's not convenient to spot duplicate 
	-- specialisations here.  Check for this later, when we're in Type land
eqHsSig _other1 _other2 = False
\end{code}

455
\begin{code}
456
instance (OutputableBndr name) => Outputable (Sig name) where
457
    ppr sig = ppr_sig sig
sof's avatar
sof committed
458

459
ppr_sig :: OutputableBndr name => Sig name -> SDoc
460
ppr_sig (TypeSig var ty)	  = pprVarSig (unLoc var) ty
461
ppr_sig (FixSig fix_sig) 	  = ppr fix_sig
462
463
ppr_sig (SpecSig var ty inl) 	  = pragBrackets (pprSpec var ty inl)
ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> ppr var)
464
ppr_sig (SpecInstSig ty) 	  = pragBrackets (ptext SLIT("SPECIALIZE instance") <+> ppr ty)
465

466
467
instance Outputable name => Outputable (FixitySig name) where
  ppr (FixitySig name fixity) = sep [ppr fixity, ppr name]
468

469
470
pragBrackets :: SDoc -> SDoc
pragBrackets doc = ptext SLIT("{-#") <+> doc <+> ptext SLIT("#-}") 
471

472
473
pprVarSig :: (Outputable id, Outputable ty) => id -> ty -> SDoc
pprVarSig var ty = sep [ppr var <+> dcolon, nest 2 (ppr ty)]
474

475
476
pprSpec :: (Outputable id, Outputable ty) => id -> ty -> InlineSpec -> SDoc
pprSpec var ty inl = sep [ptext SLIT("SPECIALIZE") <+> ppr inl <+> pprVarSig var ty]
477

478
pprPrag :: Outputable id => id -> Prag -> SDoc
479
480
pprPrag var (InlinePrag inl)         = ppr inl <+> ppr var
pprPrag var (SpecPrag expr ty _ inl) = pprSpec var ty inl
481
\end{code}