HsDecls.lhs 12.3 KB
Newer Older
1 2 3 4 5 6
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\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 21
import IdInfo		( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo )
import Demand		( Demand )
sof's avatar
sof committed
22
import CallConv		( CallConv, pprCallConv )
23 24

-- others:
sof's avatar
sof committed
25
import Name		( getOccName, OccName, 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 148 149
    ppr (TyData new_or_data context tycon tyvars condecls derivings pragmas src_loc)
      = pp_tydecl
		  (pp_decl_head keyword (pp_context_and_arrow context) tycon tyvars)
		  (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
pp_context_and_arrow :: Outputable name => Context name -> SDoc
pp_context_and_arrow [] = empty
pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")]
175 176 177 178 179 180 181 182 183
\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
184
		(HsType name)
185 186 187 188 189
		SrcLoc

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

190 191
    ppr (SpecDataSig tycon ty _)
      = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
192 193 194 195 196 197 198 199 200 201
\end{code}

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

\begin{code}
data ConDecl name
sof's avatar
sof committed
202 203 204
  = ConDecl 	name			-- Constructor name
		(Context name)		-- Existential context for this constructor
		(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 cxt con_details  loc)
      = pp_context_and_arrow 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 285 286
        top_matter = hsep [ptext SLIT("class"), pp_context_and_arrow context,
                            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 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
data ForeignDecl name = 
   ForeignDecl 
        name 
	(Maybe Bool)   -- Nothing => foreign export; Just unsafe => foreign import unsafe
	(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
	     Nothing -> (ptext SLIT("export"), empty)
	     Just us -> (ptext SLIT("import"), ptext SLIT("unsafe"))

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}

392 393 394 395 396 397 398 399 400 401 402 403 404 405
%************************************************************************
%*									*
\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
406 407 408
    ppr (IfaceSig var ty _ _)
      = hang (hsep [ppr var, ptext SLIT("::")])
	     4 (ppr ty)
409 410 411

data HsIdInfo name
  = HsArity		ArityInfo
sof's avatar
sof committed
412
  | HsStrictness	(HsStrictnessInfo name)
sof's avatar
sof committed
413
  | HsUnfold		Bool (UfExpr name)	-- True <=> INLINE pragma
414 415 416
  | HsUpdate		UpdateInfo
  | HsArgUsage		ArgUsageInfo
  | HsFBType		FBTypeInfo
417 418
  | HsSpecialise	[HsTyVar name] [HsType name] (UfExpr name)

sof's avatar
sof committed
419 420 421 422 423 424

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