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

Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@.

\begin{code}
module HsBinds where

11
#include "HsVersions.h"
12

13 14 15
import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr,
			       Match,  pprFunBind,
			       GRHSs,  pprPatBind )
sof's avatar
sof committed
16

17
-- friends:
18
import HsImpExp		( ppr_var )
19
import HsTypes		( HsType )
20
import CoreSyn		( CoreExpr )
21
import PprCore		( {- instance Outputable (Expr a) -} )
22 23

--others:
24 25
import Name		( Name )
import PrelNames	( isUnboundName )
26
import NameSet		( NameSet, elemNameSet, nameSetToList )
27
import BasicTypes	( RecFlag(..), Fixity, Activation(..), pprPhase )
28 29
import Outputable	
import SrcLoc		( SrcLoc )
30
import Var		( TyVar )
31
import Class            ( DefMeth (..) )
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48
\end{code}

%************************************************************************
%*									*
\subsection{Bindings: @HsBinds@}
%*									*
%************************************************************************

The following syntax may produce new syntax which is not part of the input,
and which is instead a translation of the input to the typechecker.
Syntax translations are marked TRANSLATION in comments. New empty
productions are useful in development but may not appear in the final
grammar.

Collections of bindings, created by dependency analysis and translation:

\begin{code}
49
data HsBinds id pat		-- binders and bindees
50 51
  = EmptyBinds

52 53
  | ThenBinds	(HsBinds id pat)
		(HsBinds id pat)
54

55
  | MonoBind 	(MonoBinds id pat)
sof's avatar
sof committed
56 57 58 59 60
		[Sig id]		-- Empty on typechecker output
		RecFlag
\end{code}

\begin{code}
61
nullBinds :: HsBinds id pat -> Bool
sof's avatar
sof committed
62 63 64 65

nullBinds EmptyBinds		= True
nullBinds (ThenBinds b1 b2)	= nullBinds b1 && nullBinds b2
nullBinds (MonoBind b _ _)	= nullMonoBinds b
66 67 68 69

mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat
mkMonoBind EmptyMonoBinds _ _ = EmptyBinds
mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec
sof's avatar
sof committed
70 71 72
\end{code}

\begin{code}
73
instance (Outputable pat, Outputable id) =>
74
		Outputable (HsBinds id pat) where
75 76 77 78
    ppr binds = ppr_binds binds

ppr_binds EmptyBinds = empty
ppr_binds (ThenBinds binds1 binds2)
79
    = ppr_binds binds1 $$ ppr_binds binds2
80
ppr_binds (MonoBind bind sigs is_rec)
81
     = vcat [ppr_isrec,
82 83
     	     vcat (map ppr sigs),
	     ppr bind
sof's avatar
sof committed
84 85
       ]
     where
86 87 88 89 90
       ppr_isrec = getPprStyle $ \ sty -> 
		   if userStyle sty then empty else
		   case is_rec of
		   	Recursive    -> ptext SLIT("{- rec -}")
			NonRecursive -> ptext SLIT("{- nonrec -}")
sof's avatar
sof committed
91 92 93 94 95 96 97 98 99 100 101
\end{code}

%************************************************************************
%*									*
\subsection{Bindings: @MonoBinds@}
%*									*
%************************************************************************

Global bindings (where clauses)

\begin{code}
102
data MonoBinds id pat
sof's avatar
sof committed
103 104
  = EmptyMonoBinds

105 106
  | AndMonoBinds    (MonoBinds id pat)
		    (MonoBinds id pat)
sof's avatar
sof committed
107

108 109 110 111
  | FunMonoBind     id		-- Used for both functions 	f x = e
				-- and variables		f = \x -> e
				-- Reason: the Match stuff lets us have an optional
				--	   result type sig	f :: a->a = ...mentions a...
112 113 114 115
				--
				-- This also means that instance decls can only have
				-- FunMonoBinds, so if you change this, you'll need to
				-- change e.g. rnMethodBinds
116
		    Bool		-- True => infix declaration
117
		    [Match id pat]
sof's avatar
sof committed
118 119
		    SrcLoc

120 121 122 123 124
  | PatMonoBind     pat		-- The pattern is never a simple variable;
				-- That case is done by FunMonoBind
		    (GRHSs id pat)
		    SrcLoc

sof's avatar
sof committed
125
  | VarMonoBind	    id			-- TRANSLATION
126
		    (HsExpr id pat)
sof's avatar
sof committed
127 128 129

  | CoreMonoBind    id			-- TRANSLATION
		    CoreExpr		-- No zonking; this is a final CoreExpr with Ids and Types!
130

131 132 133 134 135
  | AbsBinds				-- Binds abstraction; TRANSLATION
		[TyVar]	  		-- Type variables
		[id]			-- Dicts
		[([TyVar], id, id)]	-- (type variables, polymorphic, momonmorphic) triples
		NameSet			-- Set of *polymorphic* variables that have an INLINE pragma
136
		(MonoBinds id pat)      -- The "business end"
137 138 139 140 141 142 143 144 145

	-- Creates bindings for *new* (polymorphic, overloaded) locals
	-- in terms of *old* (monomorphic, non-overloaded) ones.
	--
	-- See section 9 of static semantics paper for more details.
	-- (You can get a PhD for explaining the True Meaning
	--  of this last construct.)
\end{code}

146 147
What AbsBinds means
~~~~~~~~~~~~~~~~~~~
sof's avatar
sof committed
148
	 AbsBinds tvs
149
		  [d1,d2]
sof's avatar
sof committed
150 151
		  [(tvs1, f1p, f1m), 
		   (tvs2, f2p, f2m)]
152 153 154
		  BIND
means

sof's avatar
sof committed
155
	f1p = /\ tvs -> \ [d1,d2] -> letrec DBINDS and BIND 
156 157 158 159 160 161 162 163 164 165 166 167 168 169
				      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..

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

170
\begin{code}
171 172
-- We keep the invariant that a MonoBinds is only empty 
-- if it is exactly EmptyMonoBinds
173

174
nullMonoBinds :: MonoBinds id pat -> Bool
sof's avatar
sof committed
175 176 177
nullMonoBinds EmptyMonoBinds	     = True
nullMonoBinds other_monobind	     = False

178
andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat
179 180 181 182
andMonoBinds EmptyMonoBinds mb = mb
andMonoBinds mb EmptyMonoBinds = mb
andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2

183
andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat
184 185 186 187 188 189 190 191 192 193 194
andMonoBindList binds
  = loop1 binds
  where
    loop1 [] = EmptyMonoBinds
    loop1 (EmptyMonoBinds : binds) = loop1 binds
    loop1 (b:bs) = loop2 b bs

	-- acc is non-empty
    loop2 acc [] = acc
    loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs
    loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs
195 196
\end{code}

197

198
\begin{code}
199
instance (Outputable id, Outputable pat) =>
200
		Outputable (MonoBinds id pat) where
201
    ppr mbind = ppr_monobind mbind
sof's avatar
sof committed
202

203

204
ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc
205 206
ppr_monobind EmptyMonoBinds = empty
ppr_monobind (AndMonoBinds binds1 binds2)
207
      = ppr_monobind binds1 $$ ppr_monobind binds2
sof's avatar
sof committed
208

209 210
ppr_monobind (PatMonoBind pat grhss locn)	= pprPatBind pat grhss
ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches
sof's avatar
sof committed
211 212
      -- ToDo: print infix if appropriate

213 214
ppr_monobind (VarMonoBind name expr)
      = sep [ppr name <+> equals, nest 4 (pprExpr expr)]
sof's avatar
sof committed
215

216 217
ppr_monobind (CoreMonoBind name expr)
      = sep [ppr name <+> equals, nest 4 (ppr expr)]
sof's avatar
sof committed
218

219
ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds)
220 221 222
     = sep [ptext SLIT("AbsBinds"),
	    brackets (interpp'SP tyvars),
	    brackets (interpp'SP dictvars),
223
	    brackets (sep (punctuate comma (map ppr exports))),
224
	    brackets (interpp'SP (nameSetToList inlines))]
225 226
       $$
       nest 4 (ppr val_binds)
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242
\end{code}

%************************************************************************
%*									*
\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}
data Sig name
  = Sig		name		-- a bog-std type signature
243
		(HsType name)
244 245
		SrcLoc

246
  | ClassOpSig	name		-- Selector name
247 248
                (DefMeth name)	-- Default-method info
				-- See "THE NAMING STORY" in HsDecls
249
		(HsType name)
250 251 252
		SrcLoc

  | SpecSig 	name		-- specialise a function or datatype ...
253
		(HsType name)	-- ... to these types
254 255
		SrcLoc

256 257 258
  | InlineSig	Bool		-- True <=> INLINE f, False <=> NOINLINE f
	 	name		-- Function name
		Activation	-- When inlining is *active*
259 260
		SrcLoc

261 262
  | SpecInstSig (HsType name)	-- (Class tys); should be a specialisation of the 
				-- current instance decl
sof's avatar
sof committed
263
		SrcLoc
264

265
  | FixSig	(FixitySig name)	-- Fixity declaration
266

267

268
data FixitySig name = FixitySig name Fixity SrcLoc 
269

270 271
instance Eq name => Eq (FixitySig name) where
   (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2
sof's avatar
sof committed
272 273 274
\end{code}

\begin{code}
275
okBindSig :: NameSet -> Sig Name -> Bool
276
okBindSig ns (ClassOpSig _ _ _ _)				= False
277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295
okBindSig ns sig = sigForThisGroup ns sig

okClsDclSig :: NameSet -> Sig Name -> Bool
okClsDclSig ns (Sig _ _ _)					  = False
okClsDclSig ns sig = sigForThisGroup ns sig

okInstDclSig :: NameSet -> Sig Name -> Bool
okInstDclSig ns (Sig _ _ _)					   = False
okInstDclSig ns (FixSig _)					   = False
okInstDclSig ns (SpecInstSig _ _)				   = True
okInstDclSig ns sig = sigForThisGroup ns sig

sigForThisGroup ns sig 
  = case sigName sig of
	Nothing 		 -> False
	Just n | isUnboundName n -> True	-- Don't complain about an unbound name again
	       | otherwise 	 -> n `elemNameSet` ns

sigName :: Sig name -> Maybe name
296 297 298 299 300 301
sigName (Sig         n _ _)        = Just n
sigName (ClassOpSig  n _ _ _)      = Just n
sigName (SpecSig     n _ _)        = Just n
sigName (InlineSig _ n _ _)        = Just n
sigName (FixSig (FixitySig n _ _)) = Just n
sigName other			   = Nothing
302

sof's avatar
sof committed
303 304 305 306 307
isFixitySig :: Sig name -> Bool
isFixitySig (FixSig _) = True
isFixitySig _	       = False

isClassOpSig :: Sig name -> Bool
308 309
isClassOpSig (ClassOpSig _ _ _ _) = True
isClassOpSig _			  = False
310 311 312

isPragSig :: Sig name -> Bool
	-- Identifies pragmas 
313
isPragSig (SpecSig _ _ _)     = True
314
isPragSig (InlineSig _ _ _ _) = True
315 316
isPragSig (SpecInstSig _ _)   = True
isPragSig other		      = False
317 318
\end{code}

319 320
\begin{code}
hsSigDoc (Sig        _ _ loc) 	      = (SLIT("type signature"),loc)
321
hsSigDoc (ClassOpSig _ _ _ loc)       = (SLIT("class-method type signature"), loc)
322
hsSigDoc (SpecSig    _ _ loc) 	      = (SLIT("SPECIALISE pragma"),loc)
323 324
hsSigDoc (InlineSig True  _ _ loc)    = (SLIT("INLINE pragma"),loc)
hsSigDoc (InlineSig False _ _ loc)    = (SLIT("NOINLINE pragma"),loc)
325 326 327 328
hsSigDoc (SpecInstSig _ loc)	      = (SLIT("SPECIALISE instance pragma"),loc)
hsSigDoc (FixSig (FixitySig _ _ loc)) = (SLIT("fixity declaration"), loc)
\end{code}

329
\begin{code}
330
instance (Outputable name) => Outputable (Sig name) where
331
    ppr sig = ppr_sig sig
sof's avatar
sof committed
332

333
ppr_sig :: Outputable name => Sig name -> SDoc
334
ppr_sig (Sig var ty _)
335
      = sep [ppr var <+> dcolon, nest 4 (ppr ty)]
336

337
ppr_sig (ClassOpSig var dm ty _)
338 339 340 341 342 343
      = getPprStyle $ \ sty ->
        if ifaceStyle sty 
	   then sep [ ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty) ]
	   else sep [ ppr_var var <+> dcolon, 
		      nest 4 (ppr ty),
		      nest 4 (pp_dm_comment) ]
344
      where
345
	pp_dm = case dm of 
346 347 348
		  DefMeth _  -> equals 	-- Default method indicator
		  GenDefMeth -> semi    -- Generic method indicator
		  NoDefMeth  -> empty   -- No Method at all
349 350 351 352
	pp_dm_comment = case dm of 
		  DefMeth _  -> text "{- has default method -}"
		  GenDefMeth -> text "{- has generic method -}"
		  NoDefMeth  -> empty   -- No Method at all
353

354
ppr_sig (SpecSig var ty _)
355
      = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon],
356
	      nest 4 (ppr ty <+> text "#-}")
357
	]
358

359 360
ppr_sig (InlineSig True var phase _)
      = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"]
361

362 363 364 365 366 367
ppr_sig (InlineSig False var phase _)
      = hsep [text "{-# NOINLINE", pp_phase phase, ppr var, text "#-}"]
      where
	pp_phase NeverActive     = empty		-- NOINLINE f
	pp_phase (ActiveAfter n) = pprPhase n		-- NOINLINE [2] f
	pp_phase AlwaysActive    = text "ALWAYS?" 	-- Unexpected
368

sof's avatar
sof committed
369 370
ppr_sig (SpecInstSig ty _)
      = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"]
371 372

ppr_sig (FixSig fix_sig) = ppr fix_sig
373

374

375 376
instance Outputable name => Outputable (FixitySig name) where
  ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name]
377 378
\end{code}

379 380 381 382
Checking for distinct signatures; oh, so boring


\begin{code}
383
eqHsSig :: Sig Name -> Sig Name -> Bool
384 385
eqHsSig (Sig n1 _ _)         (Sig n2 _ _)          = n1 == n2
eqHsSig (InlineSig b1 n1 _ _)(InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2
386 387

eqHsSig (SpecInstSig ty1 _)  (SpecInstSig ty2 _)  = ty1 == ty2
388 389
eqHsSig (SpecSig n1 ty1 _)   (SpecSig n2 ty2 _)   =
    -- may have many specialisations for one value;
390
    -- but not ones that are exactly the same...
391 392
    (n1 == n2) && (ty1 == ty2)

393
eqHsSig _other1 _other2 = False
394
\end{code}