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
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 )
22 23

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

30 31 32 33 34 35 36 37

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

\begin{code}
38
data HsDecl flexi name pat
39
  = TyD		(TyDecl name)
40 41
  | ClD		(ClassDecl flexi name pat)
  | InstD	(InstDecl  flexi name pat)
42
  | DefD	(DefaultDecl name)
43
  | ValD	(HsBinds flexi name pat)
44 45 46 47
  | SigD	(IfaceSig name)
\end{code}

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

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

67 68 69 70 71 72
    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
73

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


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

\begin{code}
100 101 102
data FixityDecl name  = FixityDecl name Fixity SrcLoc

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

106

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

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

\end{code}

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

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

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

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

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

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

168 169 170
pp_context_and_arrow :: Outputable name => Context name -> SDoc
pp_context_and_arrow [] = empty
pp_context_and_arrow theta = hsep [pprContext theta, ptext SLIT("=>")]
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 199 200
  = ConDecl 	name			-- Constructor name
		(Context name)		-- Existential context for this constructor
		(ConDetails name)
201 202
		SrcLoc

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

  | InfixCon			-- infix-style con decl
		(BangType name)
209 210
		(BangType name)

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

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

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

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

227 228
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
229

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

233 234
ppr_con_details con (NewCon ty)
  = ppr con <+> pprParendHsType ty
235

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

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

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

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

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

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

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

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

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

297
		(MonoBinds flexi name pat)
298

299
		[Sig name]		-- User-supplied pragmatic info
300

301
		(Maybe name)		-- Name for the dictionary function
302 303 304 305 306

		SrcLoc
\end{code}

\begin{code}
307 308 309 310 311 312 313 314 315 316 317
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) ]
318 319 320 321 322 323 324 325
\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
326
		 (HsType name)    -- type to specialise to
327 328 329 330 331
		 SrcLoc

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

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

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

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

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

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

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