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

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

\begin{code}
module HsDecls where

12
#include "HsVersions.h"
13 14

-- friends:
15
import HsBinds		( HsBinds, MonoBinds, Sig, nullMonoBinds )
16
import HsPragmas	( DataPragmas, ClassPragmas )
17
import HsTypes
18
import HsCore		( UfExpr )
sof's avatar
sof committed
19
import BasicTypes	( Fixity, NewOrData(..) )
20
import IdInfo		( ArityInfo, UpdateInfo, InlinePragInfo )
21
import Demand		( Demand )
sof's avatar
sof committed
22
import CallConv		( CallConv, pprCallConv )
23 24

-- others:
25
import Name		( NamedThing )
26
import Outputable	
27
import SrcLoc		( SrcLoc )
sof's avatar
sof committed
28
import Util
29 30
\end{code}

31 32 33 34 35 36 37 38

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

\begin{code}
39
data HsDecl flexi name pat
40
  = TyD		(TyDecl name)
41 42
  | ClD		(ClassDecl flexi name pat)
  | InstD	(InstDecl  flexi name pat)
43
  | DefD	(DefaultDecl name)
44
  | ValD	(HsBinds flexi name pat)
45
  | SigD	(IfaceSig name)
sof's avatar
sof committed
46
  | ForD        (ForeignDecl name)
47 48 49
\end{code}

\begin{code}
sof's avatar
sof committed
50
#ifdef DEBUG
51 52
hsDeclName :: (NamedThing name, Outputable name, Outputable pat)
	   => HsDecl flexi name pat -> name
sof's avatar
sof committed
53 54 55
#endif
hsDeclName (TyD (TyData _ _ name _ _ _ _ _))  	  = name
hsDeclName (TyD (TySynonym name _ _ _))       	  = name
56
hsDeclName (ClD (ClassDecl _ name _ _ _ _ _ _ _)) = name
sof's avatar
sof committed
57 58
hsDeclName (SigD (IfaceSig name _ _ _))	      	  = name
hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
sof's avatar
sof committed
59
hsDeclName (ForD  (ForeignDecl name _ _ _ _ _))   = name
60
-- Others don't make sense
sof's avatar
sof committed
61
#ifdef DEBUG
62
hsDeclName x				      = pprPanic "HsDecls.hsDeclName" (ppr x)
sof's avatar
sof committed
63
#endif
64 65 66
\end{code}

\begin{code}
67 68
instance (NamedThing name, Outputable name, Outputable pat)
	=> Outputable (HsDecl flexi name pat) where
69

70 71 72 73 74 75
    ppr (TyD td)     = ppr td
    ppr (ClD cd)     = ppr cd
    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
76
    ppr (ForD fd)    = ppr fd
77

sof's avatar
sof committed
78
#ifdef DEBUG
79 80 81 82 83 84 85 86
-- hsDeclName needs more context when DEBUG is on
instance (NamedThing name, Outputable name, Outputable pat, Eq name)
      => Eq (HsDecl flex name pat) where
   d1 == d2 = hsDeclName d1 == hsDeclName d2
	
instance (NamedThing name, Outputable name, Outputable pat, Ord name)
      => Ord (HsDecl flex name pat) where
	d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
sof's avatar
sof committed
87
#else
88 89 90 91 92
instance (Eq name) => Eq (HsDecl flex name pat) where
	d1 == d2 = hsDeclName d1 == hsDeclName d2
	
instance (Ord name) => Ord (HsDecl flexi name pat) where
	d1 `compare` d2 = hsDeclName d1 `compare` hsDeclName d2
sof's avatar
sof committed
93
#endif
94 95 96
\end{code}


97 98 99 100 101 102 103
%************************************************************************
%*									*
\subsection[FixityDecl]{A fixity declaration}
%*									*
%************************************************************************

\begin{code}
104 105 106
data FixityDecl name  = FixityDecl name Fixity SrcLoc

instance Outputable name => Outputable (FixityDecl name) where
107
  ppr (FixityDecl name fixity loc) = sep [ppr fixity, ppr name]
108 109
\end{code}

110

111 112 113 114 115 116 117 118
%************************************************************************
%*									*
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%*									*
%************************************************************************

\begin{code}
data TyDecl name
sof's avatar
sof committed
119 120
  = TyData	NewOrData
		(Context name)	-- context
121
		name		-- type constructor
122
		[HsTyVar name]	-- type variables
123 124 125 126 127 128 129 130 131
		[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
132 133
		[HsTyVar name]	-- type variables
		(HsType name)	-- synonym expansion
134 135 136 137 138 139 140 141
		SrcLoc

\end{code}

\begin{code}
instance (NamedThing name, Outputable name)
	      => Outputable (TyDecl name) where

142 143 144
    ppr (TySynonym tycon tyvars mono_ty src_loc)
      = hang (pp_decl_head SLIT("type") empty tycon tyvars)
	     4 (ppr mono_ty)
145

146 147
    ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
      = pp_tydecl
148
		  (pp_decl_head keyword (pprContext context) tycon tyvars)
149
		  (pp_condecls condecls)
150
		  derivings
sof's avatar
sof committed
151 152 153 154
      where
	keyword = case new_or_data of
			NewType  -> SLIT("newtype")
			DataType -> SLIT("data")
155

156 157 158
pp_decl_head str pp_context tycon tyvars
  = hsep [ptext str, pp_context, ppr tycon,
	   interppSP tyvars, ptext SLIT("=")]
159

160 161 162
pp_condecls [] = empty		-- Curious!
pp_condecls (c:cs)
  = sep (ppr c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr c)) cs)
163

164
pp_tydecl pp_head pp_decl_rhs derivings
sof's avatar
sof committed
165
  = hang pp_head 4 (sep [
166
	pp_decl_rhs,
167 168 169
	case derivings of
	  Nothing 	   -> empty
	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
170
    ])
171 172 173 174 175 176 177 178 179
\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
180
		(HsType name)
181 182 183 184 185
		SrcLoc

instance (NamedThing name, Outputable name)
	      => Outputable (SpecDataSig name) where

186 187
    ppr (SpecDataSig tycon ty _)
      = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
188 189 190 191 192 193 194 195 196 197
\end{code}

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

\begin{code}
data ConDecl name
sof's avatar
sof committed
198
  = ConDecl 	name			-- Constructor name
199 200 201 202 203

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

sof's avatar
sof committed
204
		(ConDetails name)
205 206
		SrcLoc

sof's avatar
sof committed
207 208 209 210 211 212
data ConDetails name
  = VanillaCon			-- prefix-style con decl
		[BangType name]

  | InfixCon			-- infix-style con decl
		(BangType name)
213 214
		(BangType name)

sof's avatar
sof committed
215
  | RecCon			-- record-style con decl
216
		[([name], BangType name)]	-- list of "fields"
217

sof's avatar
sof committed
218
  | NewCon	 		-- newtype con decl
219
		(HsType name)
220 221

data BangType name
222 223
  = Banged   (HsType name)	-- HsType: to allow Haskell extensions
  | Unbanged (HsType name)	-- (MonoType only needed for straight Haskell)
224 225 226 227
\end{code}

\begin{code}
instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
228 229
    ppr (ConDecl con tvs cxt con_details  loc)
      = sep [pprForAll tvs, pprContext cxt, ppr_con_details con con_details]
230

231 232
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
233

234 235
ppr_con_details con (VanillaCon tys)
  = ppr con <+> hsep (map (ppr_bang) tys)
sof's avatar
sof committed
236

237 238
ppr_con_details con (NewCon ty)
  = ppr con <+> pprParendHsType ty
239

240 241
ppr_con_details con (RecCon fields)
  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
sof's avatar
sof committed
242
  where
243
    ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
sof's avatar
sof committed
244
			 ptext SLIT("::") <+>
245
			 ppr_bang ty
sof's avatar
sof committed
246

247 248
ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
249 250 251 252 253 254 255 256 257
\end{code}

%************************************************************************
%*									*
\subsection[ClassDecl]{A class declaration}
%*									*
%************************************************************************

\begin{code}
258
data ClassDecl flexi name pat
259 260
  = ClassDecl	(Context name)	    		-- context...
		name		    		-- name of the class
261
		[HsTyVar name]	    		-- the class type variables
262
		[Sig name]			-- methods' signatures
263
		(MonoBinds flexi name pat)	-- default methods
264
		(ClassPragmas name)
265 266
		name name			-- The names of the tycon and datacon for this class
						-- These are filled in by the renamer
267 268 269 270
		SrcLoc
\end{code}

\begin{code}
271 272
instance (NamedThing name, Outputable name, Outputable pat)
		=> Outputable (ClassDecl flexi name pat) where
273

274
    ppr (ClassDecl context clas tyvars sigs methods pragmas _ _ src_loc)
275 276 277 278
      | null sigs	-- No "where" part
      = top_matter

      | otherwise	-- Laid out
sof's avatar
sof committed
279 280
      = sep [hsep [top_matter, ptext SLIT("where {")],
	       nest 4 (vcat [sep (map ppr_sig sigs),
281
				   ppr methods,
sof's avatar
sof committed
282
				   char '}'])]
283
      where
284
        top_matter = hsep [ptext SLIT("class"), pprContext context,
285 286
                            ppr clas, hsep (map (ppr) tyvars)]
	ppr_sig sig = ppr sig <> semi
287 288 289 290
\end{code}

%************************************************************************
%*									*
sof's avatar
sof committed
291
\subsection[InstDecl]{An instance declaration
292 293 294 295
%*									*
%************************************************************************

\begin{code}
296
data InstDecl flexi name pat
297
  = InstDecl	(HsType name)	-- Context => Class Instance-type
298 299 300
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.

301
		(MonoBinds flexi name pat)
302

303
		[Sig name]		-- User-supplied pragmatic info
304

305
		(Maybe name)		-- Name for the dictionary function
306 307 308 309 310

		SrcLoc
\end{code}

\begin{code}
311 312 313 314 315 316 317 318 319 320 321
instance (NamedThing name, Outputable name, Outputable pat)
	      => Outputable (InstDecl flexi name pat) where

    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) ]
322 323 324 325 326 327 328 329 330 331 332 333 334 335 336
\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
337
  = DefaultDecl	[HsType name]
338 339 340 341 342
		SrcLoc

instance (NamedThing name, Outputable name)
	      => Outputable (DefaultDecl name) where

343 344
    ppr (DefaultDecl tys src_loc)
      = ptext SLIT("default") <+> parens (interpp'SP tys)
345
\end{code}
346

sof's avatar
sof committed
347 348 349 350 351 352 353 354 355 356
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
data ForeignDecl name = 
   ForeignDecl 
        name 
sof's avatar
sof committed
357
	ForKind   
sof's avatar
sof committed
358 359 360 361 362 363 364 365 366 367 368 369 370 371
	(HsType name)
	ExtName
	CallConv
	SrcLoc

instance (NamedThing name, Outputable name)
	      => Outputable (ForeignDecl name) where

    ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
      = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> 
        ppr ext_name <+> ppr_unsafe <+> ppr nm <+> ptext SLIT("::")  <+> ppr ty
        where
         (ppr_imp_exp, ppr_unsafe) =
	   case imp_exp of
sof's avatar
sof committed
372 373 374 375 376 377 378 379 380 381
	     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
382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399

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}

400 401 402 403 404 405 406 407 408 409 410 411 412 413
%************************************************************************
%*									*
\subsection{Signatures in interface files}
%*									*
%************************************************************************

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

instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
414 415 416
    ppr (IfaceSig var ty _ _)
      = hang (hsep [ppr var, ptext SLIT("::")])
	     4 (ppr ty)
417 418 419

data HsIdInfo name
  = HsArity		ArityInfo
sof's avatar
sof committed
420
  | HsStrictness	(HsStrictnessInfo name)
421
  | HsUnfold		InlinePragInfo (Maybe (UfExpr name))
422
  | HsUpdate		UpdateInfo
423
  | HsSpecialise	[HsTyVar name] [HsType name] (UfExpr name)
424
  | HsNoCafRefs
425

sof's avatar
sof committed
426 427 428 429 430 431

data HsStrictnessInfo name
  = HsStrictnessInfo [Demand] 
		     (Maybe (name, [name]))	-- Worker, if any
						-- and needed constructors
  | HsBottom
432
\end{code}