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

Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@,
@InstDecl@, @DefaultDecl@.

\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 18
			  InstancePragmas, ClassOpPragmas
			)
19
import HsTypes
20
import HsCore		( UfExpr )
sof's avatar
sof committed
21
import BasicTypes	( Fixity, NewOrData(..) )
22 23
import IdInfo		( ArgUsageInfo, FBTypeInfo, ArityInfo, UpdateInfo )
import Demand		( Demand )
24 25

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

32 33 34 35 36 37 38 39

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

\begin{code}
40
data HsDecl flexi name pat
41
  = TyD		(TyDecl name)
42 43
  | ClD		(ClassDecl flexi name pat)
  | InstD	(InstDecl  flexi name pat)
44
  | DefD	(DefaultDecl name)
45
  | ValD	(HsBinds flexi name pat)
46 47 48 49
  | SigD	(IfaceSig name)
\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
59
-- Others don't make sense
sof's avatar
sof committed
60
#ifdef DEBUG
61
hsDeclName x				      = pprPanic "HsDecls.hsDeclName" (ppr x)
sof's avatar
sof committed
62
#endif
63 64 65
\end{code}

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

69 70 71 72 73 74
    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
75

sof's avatar
sof committed
76
#ifdef DEBUG
77 78 79 80 81 82 83 84
-- 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
85
#else
86 87 88 89 90
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
91
#endif
92 93 94
\end{code}


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

\begin{code}
102 103 104
data FixityDecl name  = FixityDecl name Fixity SrcLoc

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

108

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

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

\end{code}

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

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

144 145 146 147
    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)
148
		  derivings
sof's avatar
sof committed
149 150 151 152
      where
	keyword = case new_or_data of
			NewType  -> SLIT("newtype")
			DataType -> SLIT("data")
153

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

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

162
pp_tydecl pp_head pp_decl_rhs derivings
sof's avatar
sof committed
163
  = hang pp_head 4 (sep [
164
	pp_decl_rhs,
165 166 167
	case derivings of
	  Nothing 	   -> empty
	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
168 169
    ])

170 171 172
pp_context_and_arrow :: Outputable name => Context name -> SDoc
pp_context_and_arrow [] = empty
pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")]
173 174 175 176 177 178 179 180 181
\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
182
		(HsType name)
183 184 185 186 187
		SrcLoc

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

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

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

\begin{code}
data ConDecl name
sof's avatar
sof committed
200 201 202
  = ConDecl 	name			-- Constructor name
		(Context name)		-- Existential context for this constructor
		(ConDetails name)
203 204
		SrcLoc

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

  | InfixCon			-- infix-style con decl
		(BangType name)
211 212
		(BangType name)

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

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

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

\begin{code}
instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
226 227
    ppr (ConDecl con cxt con_details  loc)
      = pp_context_and_arrow cxt <+> ppr_con_details con con_details
228

229 230
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
231

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

235 236
ppr_con_details con (NewCon ty)
  = ppr con <+> pprParendHsType ty
237

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

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

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

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

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

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

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

%************************************************************************
%*									*
\subsection[InstDecl]{An instance declaration (also, @SpecInstSig@)}
%*									*
%************************************************************************

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

299
		(MonoBinds flexi name pat)
300

301
		[Sig name]		-- User-supplied pragmatic info
302

303
		(Maybe name)		-- Name for the dictionary function
304 305 306 307 308

		SrcLoc
\end{code}

\begin{code}
309 310 311 312 313 314 315 316 317 318 319
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) ]
320 321 322 323 324 325 326 327
\end{code}

A type for recording what instances the user wants to specialise;
called a ``Sig'' because it's sort of like a ``type signature'' for an
instance.
\begin{code}
data SpecInstSig name
  = SpecInstSig  name		    -- class
328
		 (HsType name)    -- type to specialise to
329 330 331 332 333
		 SrcLoc

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

334 335
    ppr (SpecInstSig clas ty _)
      = hsep [text "{-# SPECIALIZE instance", ppr clas, ppr ty, text "#-}"]
336 337 338 339 340 341 342 343 344 345 346 347 348 349
\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
350
  = DefaultDecl	[HsType name]
351 352 353 354 355
		SrcLoc

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

356 357
    ppr (DefaultDecl tys src_loc)
      = ptext SLIT("default") <+> parens (interpp'SP tys)
358
\end{code}
359 360 361 362 363 364 365 366 367 368 369 370 371 372 373

%************************************************************************
%*									*
\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
374 375 376
    ppr (IfaceSig var ty _ _)
      = hang (hsep [ppr var, ptext SLIT("::")])
	     4 (ppr ty)
377 378 379

data HsIdInfo name
  = HsArity		ArityInfo
sof's avatar
sof committed
380
  | HsStrictness	(HsStrictnessInfo name)
sof's avatar
sof committed
381
  | HsUnfold		Bool (UfExpr name)	-- True <=> INLINE pragma
382 383 384 385
  | HsUpdate		UpdateInfo
  | HsArgUsage		ArgUsageInfo
  | HsFBType		FBTypeInfo
	-- ToDo: specialisations
sof's avatar
sof committed
386 387 388 389 390 391

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