HsDecls.lhs 13.7 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
%
\section[HsDecls]{Abstract syntax: global declarations}

6
Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
sof's avatar
sof committed
7
@InstDecl@, @DefaultDecl@ and @ForeignDecl@.
8
9

\begin{code}
10
module HsDecls (
11
	HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
12
	DefaultDecl(..), ForeignDecl(..), ForKind(..),
13
	ExtName(..), isDynamicExtName, extNameStatic,
14
	ConDecl(..), ConDetails(..), BangType(..),
15
	IfaceSig(..),  SpecDataSig(..), 
16
17
	hsDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls
    ) where
18

19
#include "HsVersions.h"
20
21

-- friends:
22
import HsBinds		( HsBinds, MonoBinds, Sig, FixitySig(..), nullMonoBinds )
23
import HsExpr		( HsExpr )
24
import HsPragmas	( DataPragmas, ClassPragmas )
25
import HsTypes
26
import HsCore		( UfExpr, UfBinder, IfaceSig(..), UfRuleBody )
sof's avatar
sof committed
27
import BasicTypes	( Fixity, NewOrData(..) )
sof's avatar
sof committed
28
import CallConv		( CallConv, pprCallConv )
29
import Var		( TyVar )
30
31

-- others:
32
import PprType
33
import {-# SOURCE #-} FunDeps ( pprFundeps )
34
import CStrings		( CLabelString, pprCLabelString )
35
import Outputable	
36
import SrcLoc		( SrcLoc )
sof's avatar
sof committed
37
import Util
38
39
\end{code}

40
41
42
43
44
45
46
47

%************************************************************************
%*									*
\subsection[HsDecl]{Declarations}
%*									*
%************************************************************************

\begin{code}
48
49
50
data HsDecl name pat
  = TyClD	(TyClDecl name pat)
  | InstD	(InstDecl  name pat)
51
  | DefD	(DefaultDecl name)
52
  | ValD	(HsBinds name pat)
sof's avatar
sof committed
53
  | ForD        (ForeignDecl name)
54
55
  | SigD	(IfaceSig name)
  | FixD	(FixitySig name)
56
  | RuleD	(RuleDecl name pat)
57
58
59
60
61
62
63
64
65
66
67
68
69

-- NB: all top-level fixity decls are contained EITHER
-- EITHER FixDs
-- OR     in the ClassDecls in TyClDs
--
-- The former covers
-- 	a) data constructors
-- 	b) class methods (but they can be also done in the
-- 		signatures of class decls)
--	c) imported functions (that have an IfacSig)
--	d) top level decls
--
-- The latter is for class methods only
70
71
72
\end{code}

\begin{code}
sof's avatar
sof committed
73
#ifdef DEBUG
74
hsDeclName :: (Outputable name, Outputable pat)
75
	   => HsDecl name pat -> name
sof's avatar
sof committed
76
#endif
77
78
79
80
81
hsDeclName (TyClD decl)				 = tyClDeclName decl
hsDeclName (SigD  (IfaceSig name _ _ _))	 = name
hsDeclName (InstD (InstDecl _ _ _ name _))       = name
hsDeclName (ForD  (ForeignDecl name _ _ _ _ _))  = name
hsDeclName (FixD  (FixitySig name _ _))		 = name
82
-- Others don't make sense
sof's avatar
sof committed
83
#ifdef DEBUG
84
hsDeclName x				      = pprPanic "HsDecls.hsDeclName" (ppr x)
sof's avatar
sof committed
85
#endif
86
87

tyClDeclName :: TyClDecl name pat -> name
88
89
90
tyClDeclName (TyData _ _ name _ _ _ _ _)            = name
tyClDeclName (TySynonym name _ _ _)                 = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ _ _ _) = name
91
92
93
\end{code}

\begin{code}
94
instance (Outputable name, Outputable pat)
95
	=> Outputable (HsDecl name pat) where
96

97
    ppr (TyClD dcl)  = ppr dcl
98
99
100
101
    ppr (SigD sig)   = ppr sig
    ppr (ValD binds) = ppr binds
    ppr (DefD def)   = ppr def
    ppr (InstD inst) = ppr inst
sof's avatar
sof committed
102
    ppr (ForD fd)    = ppr fd
103
    ppr (FixD fd)    = ppr fd
104
    ppr (RuleD rd)   = ppr rd
105
106
\end{code}

107

108
109
110
111
112
113
114
%************************************************************************
%*									*
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%*									*
%************************************************************************

\begin{code}
115
data TyClDecl name pat
sof's avatar
sof committed
116
  = TyData	NewOrData
117
118
119
120
121
122
123
124
		(HsContext name) -- context
		name		 -- type constructor
		[HsTyVar name]	 -- type variables
		[ConDecl name]	 -- data constructors (empty if abstract)
		(Maybe [name])	 -- derivings; Nothing => not specified
				 -- (i.e., derive default); Just [] => derive
				 -- *nothing*; Just <list> => as you would
				 -- expect...
125
126
127
128
		(DataPragmas name)
		SrcLoc

  | TySynonym	name		-- type constructor
129
130
		[HsTyVar name]	-- type variables
		(HsType name)	-- synonym expansion
131
132
		SrcLoc

133
  | ClassDecl	(HsContext name)    	-- context...
134
135
		name		    	-- name of the class
		[HsTyVar name]	    	-- the class type variables
136
		[([name], [name])]	-- functional dependencies
137
		[Sig name]		-- methods' signatures
138
139
		(MonoBinds name pat)	-- default methods
		(ClassPragmas name)
140
141
142
		name name name [name]	-- The names of the tycon, datacon wrapper, datacon worker,
					-- and superclass selectors for this class.
					-- These are filled in as the ClassDecl is made.
143
		SrcLoc
144
145
146
\end{code}

\begin{code}
147
148
149
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
	-- class, data, newtype, synonym decls
countTyClDecls decls 
150
151
152
153
 = (length [() | ClassDecl _ _ _ _ _ _ _ _ _ _ _ _ <- decls],
    length [() | TyData DataType _ _ _ _ _ _ _     <- decls],
    length [() | TyData NewType  _ _ _ _ _ _ _     <- decls],
    length [() | TySynonym _ _ _ _	           <- decls])
154
155
156
157
158
159
160
161
162

isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool

isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other		      = False

isDataDecl (TyData _ _ _ _ _ _ _ _) = True
isDataDecl other		    = False

163
164
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ _ _ _) = True
isClassDecl other		 	        = False
165
166
167
\end{code}

\begin{code}
168
instance (Outputable name, Outputable pat)
169
	      => Outputable (TyClDecl name pat) where
170

171
172
173
    ppr (TySynonym tycon tyvars mono_ty src_loc)
      = hang (pp_decl_head SLIT("type") empty tycon tyvars)
	     4 (ppr mono_ty)
174

175
176
    ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
      = pp_tydecl
177
		  (pp_decl_head keyword (pprHsContext context) tycon tyvars)
178
		  (pp_condecls condecls)
179
		  derivings
sof's avatar
sof committed
180
181
182
183
      where
	keyword = case new_or_data of
			NewType  -> SLIT("newtype")
			DataType -> SLIT("data")
184

185
    ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ _ _ _ src_loc)
186
187
188
189
190
191
192
193
194
      | null sigs	-- No "where" part
      = top_matter

      | otherwise	-- Laid out
      = sep [hsep [top_matter, ptext SLIT("where {")],
	       nest 4 (vcat [sep (map ppr_sig sigs),
				   ppr methods,
				   char '}'])]
      where
195
        top_matter = hsep [ptext SLIT("class"), pprHsContext context,
196
                            ppr clas, hsep (map (ppr) tyvars), pprFundeps fds]
197
198
199
	ppr_sig sig = ppr sig <> semi


200
201
202
pp_decl_head str pp_context tycon tyvars
  = hsep [ptext str, pp_context, ppr tycon,
	   interppSP tyvars, ptext SLIT("=")]
203

204
205
pp_condecls []     = empty		-- Curious!
pp_condecls (c:cs) = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
206

207
pp_tydecl pp_head pp_decl_rhs derivings
sof's avatar
sof committed
208
  = hang pp_head 4 (sep [
209
	pp_decl_rhs,
210
211
212
	case derivings of
	  Nothing 	   -> empty
	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
213
    ])
214
215
216
217
218
219
220
221
222
\end{code}

A type for recording what types a datatype should be specialised to.
It's called a ``Sig'' because it's sort of like a ``type signature''
for an datatype declaration.

\begin{code}
data SpecDataSig name
  = SpecDataSig name		-- tycon to specialise
223
		(HsType name)
224
225
		SrcLoc

226
instance (Outputable name)
227
228
	      => Outputable (SpecDataSig name) where

229
230
    ppr (SpecDataSig tycon ty _)
      = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
231
232
233
234
235
236
237
238
239
240
\end{code}

%************************************************************************
%*									*
\subsection[ConDecl]{A data-constructor declaration}
%*									*
%************************************************************************

\begin{code}
data ConDecl name
241
242
243
244
245
  = ConDecl 	name			-- Constructor name; this is used for the
					-- DataCon itself, and for the user-callable wrapper Id

		name			-- Name of the constructor's 'worker Id'
					-- Filled in as the ConDecl is built
246
247

		[HsTyVar name]		-- Existentially quantified type variables
248
		(HsContext name)	-- ...and context
249
250
					-- If both are empty then there are no existentials

sof's avatar
sof committed
251
		(ConDetails name)
252
253
		SrcLoc

sof's avatar
sof committed
254
255
256
257
258
259
data ConDetails name
  = VanillaCon			-- prefix-style con decl
		[BangType name]

  | InfixCon			-- infix-style con decl
		(BangType name)
260
261
		(BangType name)

sof's avatar
sof committed
262
  | RecCon			-- record-style con decl
263
		[([name], BangType name)]	-- list of "fields"
264

sof's avatar
sof committed
265
  | NewCon	 		-- newtype con decl, possibly with a labelled field.
266
		(HsType name)
sof's avatar
sof committed
267
		(Maybe name)	-- Just x => labelled field 'x'
268
269

data BangType name
270
271
  = Banged   (HsType name)	-- HsType: to allow Haskell extensions
  | Unbanged (HsType name)	-- (MonoType only needed for straight Haskell)
272
  | Unpacked (HsType name)	-- Field is strict and to be unpacked if poss.
273
274
275
\end{code}

\begin{code}
276
instance (Outputable name) => Outputable (ConDecl name) where
277
    ppr (ConDecl con _ tvs cxt con_details  loc)
278
      = sep [pprForAll tvs, pprHsContext cxt, ppr_con_details con con_details]
279

280
281
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
282

283
284
ppr_con_details con (VanillaCon tys)
  = ppr con <+> hsep (map (ppr_bang) tys)
sof's avatar
sof committed
285

sof's avatar
sof committed
286
ppr_con_details con (NewCon ty Nothing)
287
  = ppr con <+> pprParendHsType ty
288

sof's avatar
sof committed
289
290
291
292
293
ppr_con_details con (NewCon ty (Just x))
  = ppr con <+> braces pp_field 
   where
    pp_field = ppr x <+> dcolon <+> pprParendHsType ty
 
294
295
ppr_con_details con (RecCon fields)
  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
sof's avatar
sof committed
296
  where
297
    ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
298
			 dcolon <+>
299
			 ppr_bang ty
sof's avatar
sof committed
300

301
302
ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
303
ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
304
305
306
307
308
\end{code}


%************************************************************************
%*									*
sof's avatar
sof committed
309
\subsection[InstDecl]{An instance declaration
310
311
312
313
%*									*
%************************************************************************

\begin{code}
314
data InstDecl name pat
315
  = InstDecl	(HsType name)	-- Context => Class Instance-type
316
317
318
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.

319
		(MonoBinds name pat)
320

321
		[Sig name]		-- User-supplied pragmatic info
322

323
		name			-- Name for the dictionary function
324
325
326
327
328

		SrcLoc
\end{code}

\begin{code}
329
instance (Outputable name, Outputable pat)
330
	      => Outputable (InstDecl name pat) where
331
332
333
334
335
336
337
338
339

    ppr (InstDecl inst_ty binds uprags dfun_name src_loc)
      = getPprStyle $ \ sty ->
        if ifaceStyle sty || (nullMonoBinds binds && null uprags) then
           hsep [ptext SLIT("instance"), ppr inst_ty]
	else
	   vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
	         nest 4 (ppr uprags),
	         nest 4 (ppr binds) ]
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
\end{code}


%************************************************************************
%*									*
\subsection[DefaultDecl]{A @default@ declaration}
%*									*
%************************************************************************

There can only be one default declaration per module, but it is hard
for the parser to check that; we pass them all through in the abstract
syntax, and that restriction must be checked in the front end.

\begin{code}
data DefaultDecl name
355
  = DefaultDecl	[HsType name]
356
357
		SrcLoc

358
instance (Outputable name)
359
360
	      => Outputable (DefaultDecl name) where

361
362
    ppr (DefaultDecl tys src_loc)
      = ptext SLIT("default") <+> parens (interpp'SP tys)
363
\end{code}
364

sof's avatar
sof committed
365
366
367
368
369
370
371
372
373
374
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
data ForeignDecl name = 
   ForeignDecl 
        name 
sof's avatar
sof committed
375
	ForKind   
sof's avatar
sof committed
376
377
378
379
380
	(HsType name)
	ExtName
	CallConv
	SrcLoc

381
instance (Outputable name)
sof's avatar
sof committed
382
383
384
385
	      => Outputable (ForeignDecl name) where

    ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
      = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> 
386
        ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
sof's avatar
sof committed
387
388
389
        where
         (ppr_imp_exp, ppr_unsafe) =
	   case imp_exp of
sof's avatar
sof committed
390
391
392
393
394
395
396
397
398
399
	     FoLabel     -> (ptext SLIT("label"), empty)
	     FoExport    -> (ptext SLIT("export"), empty)
	     FoImport us 
		| us        -> (ptext SLIT("import"), ptext SLIT("unsafe"))
		| otherwise -> (ptext SLIT("import"), empty)

data ForKind
 = FoLabel
 | FoExport
 | FoImport Bool -- True  => unsafe call.
sof's avatar
sof committed
400
401
402

data ExtName
 = Dynamic 
403
404
405
406
407
408
409
410
411
412
413
414
 | ExtName CLabelString 	-- The external name of the foreign thing,
	   (Maybe CLabelString)	-- and optionally its DLL or module name
				-- Both of these are completely unencoded; 
				-- we just print them as they are

isDynamicExtName :: ExtName -> Bool
isDynamicExtName Dynamic = True
isDynamicExtName _	 = False

extNameStatic :: ExtName -> CLabelString
extNameStatic (ExtName f _) = f
extNameStatic Dynamic	    = panic "staticExtName: Dynamic - shouldn't ever happen."
sof's avatar
sof committed
415
416
417
418
419

instance Outputable ExtName where
  ppr Dynamic	   = ptext SLIT("dynamic")
  ppr (ExtName nm mb_mod) = 
     case mb_mod of { Nothing -> empty; Just m -> doubleQuotes (ptext m) } <+> 
420
     doubleQuotes (pprCLabelString nm)
sof's avatar
sof committed
421
422
\end{code}

423
424
%************************************************************************
%*									*
425
\subsection{Transformation rules}
426
427
428
429
%*									*
%************************************************************************

\begin{code}
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
data RuleDecl name pat
  = RuleDecl
	FAST_STRING		-- Rule name
	[name]			-- Forall'd tyvars, filled in by the renamer with
				-- tyvars mentioned in sigs; then filled out by typechecker
	[RuleBndr name]		-- Forall'd term vars
	(HsExpr name pat)	-- LHS
	(HsExpr name pat)	-- RHS
	SrcLoc		

  | IfaceRuleDecl 		-- One that's come in from an interface file
	name
	(UfRuleBody name)
	SrcLoc		

data RuleBndr name
  = RuleBndr name
  | RuleBndrSig name (HsType name)
448

449
450
451
instance (Outputable name, Outputable pat)
	      => Outputable (RuleDecl name pat) where
  ppr (RuleDecl name tvs ns lhs rhs loc)
452
453
454
	= sep [text "{-# RULES" <+> doubleQuotes (ptext name),
	       pp_forall, ppr lhs, equals <+> ppr rhs,
               text "#-}" ]
455
456
457
458
459
460
461
462
463
464
	where
	  pp_forall | null tvs && null ns = empty
		    | otherwise		  = text "forall" <+> 
					    fsep (map ppr tvs ++ map ppr ns)
					    <> dot
  ppr (IfaceRuleDecl var body loc) = text "An imported rule..."

instance Outputable name => Outputable (RuleBndr name) where
   ppr (RuleBndr name) = ppr name
   ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
465
\end{code}