HsDecls.lhs 13 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 11 12 13 14 15 16 17
module HsDecls (
	HsDecl(..), TyClDecl(..), InstDecl(..),
	DefaultDecl(..), ForeignDecl(..), ForKind(..),
	ExtName(..), isDynamic,
	ConDecl(..), ConDetails(..), BangType(..),
	IfaceSig(..),  SpecDataSig(..), HsIdInfo(..), HsStrictnessInfo(..),
	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 HsPragmas	( DataPragmas, ClassPragmas )
24
import HsTypes
25
import HsCore		( UfExpr )
sof's avatar
sof committed
26
import BasicTypes	( Fixity, NewOrData(..) )
27
import IdInfo		( ArityInfo, UpdateInfo, InlinePragInfo )
28
import Demand		( Demand )
sof's avatar
sof committed
29
import CallConv		( CallConv, pprCallConv )
30 31

-- others:
32
import Outputable	
33
import SrcLoc		( SrcLoc )
sof's avatar
sof committed
34
import Util
35 36
\end{code}

37 38 39 40 41 42 43 44

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

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

-- 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

-- It's a bit wierd that the fixity decls in the ValD
-- cover all the classops and imported decls too, but it's convenient
-- For a start, it means we don't need a FixD
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 _ _ _ (Just 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 88 89 90

tyClDeclName :: TyClDecl name pat -> name
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 104 105
    ppr (FixD fd)    = ppr fd

{-	Why do we need ordering on decls?
106

sof's avatar
sof committed
107
#ifdef DEBUG
108
-- hsDeclName needs more context when DEBUG is on
109
instance (Outputable name, Outputable pat, Eq name)
110
      => Eq (HsDecl name pat) where
111 112
   d1 == d2 = hsDeclName d1 == hsDeclName d2
	
113
instance (Outputable name, Outputable pat, Ord name)
114
      => Ord (HsDecl name pat) where
115
	d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
sof's avatar
sof committed
116
#else
117
instance (Eq name) => Eq (HsDecl name pat) where
118 119
	d1 == d2 = hsDeclName d1 == hsDeclName d2
	
120
instance (Ord name) => Ord (HsDecl name pat) where
121
	d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
sof's avatar
sof committed
122
#endif
123
-}
124 125
\end{code}

126

127 128 129 130 131 132 133
%************************************************************************
%*									*
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%*									*
%************************************************************************

\begin{code}
134
data TyClDecl name pat
sof's avatar
sof committed
135 136
  = TyData	NewOrData
		(Context name)	-- context
137
		name		-- type constructor
138
		[HsTyVar name]	-- type variables
139 140 141 142 143 144 145 146 147
		[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...
		(DataPragmas name)
		SrcLoc

  | TySynonym	name		-- type constructor
148 149
		[HsTyVar name]	-- type variables
		(HsType name)	-- synonym expansion
150 151
		SrcLoc

152 153 154 155 156 157 158 159 160
  | ClassDecl	(Context name)	    		-- context...
		name		    		-- name of the class
		[HsTyVar name]	    		-- the class type variables
		[Sig name]			-- methods' signatures
		(MonoBinds name pat)	-- default methods
		(ClassPragmas name)
		name name			-- The names of the tycon and datacon for this class
						-- These are filled in by the renamer
		SrcLoc
161 162 163
\end{code}

\begin{code}
164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
	-- class, data, newtype, synonym decls
countTyClDecls decls 
 = (length [() | ClassDecl _ _ _ _ _ _ _ _   _ <- decls],
    length [() | TyData DataType _ _ _ _ _ _ _ <- decls],
    length [() | TyData NewType  _ _ _ _ _ _ _ <- decls],
    length [() | TySynonym _ _ _ _	       <- decls])

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

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

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

isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _) = True
isClassDecl other			  = False
\end{code}

\begin{code}
185
instance (Outputable name, Outputable pat)
186
	      => Outputable (TyClDecl name pat) where
187

188 189 190
    ppr (TySynonym tycon tyvars mono_ty src_loc)
      = hang (pp_decl_head SLIT("type") empty tycon tyvars)
	     4 (ppr mono_ty)
191

192 193
    ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
      = pp_tydecl
194
		  (pp_decl_head keyword (pprContext context) tycon tyvars)
195
		  (pp_condecls condecls)
196
		  derivings
sof's avatar
sof committed
197 198 199 200
      where
	keyword = case new_or_data of
			NewType  -> SLIT("newtype")
			DataType -> SLIT("data")
201

202 203 204 205 206 207 208 209 210 211 212 213 214 215 216
    ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
      | 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
        top_matter = hsep [ptext SLIT("class"), pprContext context,
                            ppr clas, hsep (map (ppr) tyvars)]
	ppr_sig sig = ppr sig <> semi


217 218 219
pp_decl_head str pp_context tycon tyvars
  = hsep [ptext str, pp_context, ppr tycon,
	   interppSP tyvars, ptext SLIT("=")]
220

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

224
pp_tydecl pp_head pp_decl_rhs derivings
sof's avatar
sof committed
225
  = hang pp_head 4 (sep [
226
	pp_decl_rhs,
227 228 229
	case derivings of
	  Nothing 	   -> empty
	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
230
    ])
231 232 233 234 235 236 237 238 239
\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
240
		(HsType name)
241 242
		SrcLoc

243
instance (Outputable name)
244 245
	      => Outputable (SpecDataSig name) where

246 247
    ppr (SpecDataSig tycon ty _)
      = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
248 249 250 251 252 253 254 255 256 257
\end{code}

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

\begin{code}
data ConDecl name
sof's avatar
sof committed
258
  = ConDecl 	name			-- Constructor name
259 260 261 262 263

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

sof's avatar
sof committed
264
		(ConDetails name)
265 266
		SrcLoc

sof's avatar
sof committed
267 268 269 270 271 272
data ConDetails name
  = VanillaCon			-- prefix-style con decl
		[BangType name]

  | InfixCon			-- infix-style con decl
		(BangType name)
273 274
		(BangType name)

sof's avatar
sof committed
275
  | RecCon			-- record-style con decl
276
		[([name], BangType name)]	-- list of "fields"
277

sof's avatar
sof committed
278
  | NewCon	 		-- newtype con decl, possibly with a labelled field.
279
		(HsType name)
sof's avatar
sof committed
280
		(Maybe name)	-- Just x => labelled field 'x'
281 282

data BangType name
283 284
  = Banged   (HsType name)	-- HsType: to allow Haskell extensions
  | Unbanged (HsType name)	-- (MonoType only needed for straight Haskell)
285 286 287
\end{code}

\begin{code}
288
instance (Outputable name) => Outputable (ConDecl name) where
289 290
    ppr (ConDecl con tvs cxt con_details  loc)
      = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details]
291

292 293
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
294

295 296
ppr_con_details con (VanillaCon tys)
  = ppr con <+> hsep (map (ppr_bang) tys)
sof's avatar
sof committed
297

sof's avatar
sof committed
298
ppr_con_details con (NewCon ty Nothing)
299
  = ppr con <+> pprParendHsType ty
300

sof's avatar
sof committed
301 302 303 304 305
ppr_con_details con (NewCon ty (Just x))
  = ppr con <+> braces pp_field 
   where
    pp_field = ppr x <+> dcolon <+> pprParendHsType ty
 
306 307
ppr_con_details con (RecCon fields)
  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
sof's avatar
sof committed
308
  where
309
    ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
310
			 dcolon <+>
311
			 ppr_bang ty
sof's avatar
sof committed
312

313 314
ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
315 316 317 318 319
\end{code}


%************************************************************************
%*									*
sof's avatar
sof committed
320
\subsection[InstDecl]{An instance declaration
321 322 323 324
%*									*
%************************************************************************

\begin{code}
325
data InstDecl name pat
326
  = InstDecl	(HsType name)	-- Context => Class Instance-type
327 328 329
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.

330
		(MonoBinds name pat)
331

332
		[Sig name]		-- User-supplied pragmatic info
333

334
		(Maybe name)		-- Name for the dictionary function
335 336 337 338 339

		SrcLoc
\end{code}

\begin{code}
340
instance (Outputable name, Outputable pat)
341
	      => Outputable (InstDecl name pat) where
342 343 344 345 346 347 348 349 350

    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) ]
351 352 353 354 355 356 357 358 359 360 361 362 363 364 365
\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
366
  = DefaultDecl	[HsType name]
367 368
		SrcLoc

369
instance (Outputable name)
370 371
	      => Outputable (DefaultDecl name) where

372 373
    ppr (DefaultDecl tys src_loc)
      = ptext SLIT("default") <+> parens (interpp'SP tys)
374
\end{code}
375

sof's avatar
sof committed
376 377 378 379 380 381 382 383 384 385
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
data ForeignDecl name = 
   ForeignDecl 
        name 
sof's avatar
sof committed
386
	ForKind   
sof's avatar
sof committed
387 388 389 390 391
	(HsType name)
	ExtName
	CallConv
	SrcLoc

392
instance (Outputable name)
sof's avatar
sof committed
393 394 395 396
	      => Outputable (ForeignDecl name) where

    ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
      = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> 
397
        ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
sof's avatar
sof committed
398 399 400
        where
         (ppr_imp_exp, ppr_unsafe) =
	   case imp_exp of
sof's avatar
sof committed
401 402 403 404 405 406 407 408 409 410
	     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
411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428

data ExtName
 = Dynamic 
 | ExtName FAST_STRING (Maybe FAST_STRING)

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


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) } <+> 
     doubleQuotes (ptext nm)

\end{code}

429 430 431 432 433 434 435 436 437 438 439 440 441
%************************************************************************
%*									*
\subsection{Signatures in interface files}
%*									*
%************************************************************************

\begin{code}
data IfaceSig name
  = IfaceSig	name
		(HsType name)
		[HsIdInfo name]
		SrcLoc

442
instance (Outputable name) => Outputable (IfaceSig name) where
443
    ppr (IfaceSig var ty _ _)
444
      = hang (hsep [ppr var, dcolon])
445
	     4 (ppr ty)
446 447 448

data HsIdInfo name
  = HsArity		ArityInfo
sof's avatar
sof committed
449
  | HsStrictness	(HsStrictnessInfo name)
450
  | HsUnfold		InlinePragInfo (Maybe (UfExpr name))
451
  | HsUpdate		UpdateInfo
452
  | HsSpecialise	[HsTyVar name] [HsType name] (UfExpr name)
453
  | HsNoCafRefs
454

sof's avatar
sof committed
455 456

data HsStrictnessInfo name
457
  = HsStrictnessInfo ([Demand], Bool)
sof's avatar
sof committed
458 459 460
		     (Maybe (name, [name]))	-- Worker, if any
						-- and needed constructors
  | HsBottom
461
\end{code}