HsDecls.lhs 11.5 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13
%
% (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}
#include "HsVersions.h"

module HsDecls where

14
IMP_Ubiq()
15 16

-- friends:
17
import HsBinds		( HsBinds, MonoBinds, Sig, nullMonoBinds )
18
import HsPragmas	( DataPragmas, ClassPragmas,
19 20
			  InstancePragmas, ClassOpPragmas
			)
21
import HsTypes
22 23 24
import IdInfo
import SpecEnv		( SpecEnv )
import HsCore		( UfExpr )
sof's avatar
sof committed
25
import BasicTypes	( Fixity, NewOrData(..) )
26 27

-- others:
sof's avatar
sof committed
28
import Name		--( getOccName, OccName )
29
import Outputable	( interppSP, interpp'SP,
sof's avatar
sof committed
30
			  PprStyle(..), Outputable(..){-instance * []-}
31
			)
32 33
import Pretty
import SrcLoc		( SrcLoc )
sof's avatar
sof committed
34
import Util
35 36
\end{code}

37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54

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

\begin{code}
data HsDecl tyvar uvar name pat
  = TyD		(TyDecl name)
  | ClD		(ClassDecl tyvar uvar name pat)
  | InstD	(InstDecl  tyvar uvar name pat)
  | DefD	(DefaultDecl name)
  | ValD	(HsBinds tyvar uvar name pat)
  | SigD	(IfaceSig name)
\end{code}

\begin{code}
sof's avatar
sof committed
55 56 57 58 59 60 61 62 63 64
#ifdef DEBUG
hsDeclName :: (NamedThing name, Outputable name, Outputable pat,
	       Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
	   => HsDecl tyvar uvar name pat -> name
#endif
hsDeclName (TyD (TyData _ _ name _ _ _ _ _))  	  = name
hsDeclName (TyD (TySynonym name _ _ _))       	  = name
hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) 	  = name
hsDeclName (SigD (IfaceSig name _ _ _))	      	  = name
hsDeclName (InstD (InstDecl _ _ _ (Just name) _)) = name
65
-- Others don't make sense
sof's avatar
sof committed
66 67 68
#ifdef DEBUG
hsDeclName x				      = pprPanic "HsDecls.hsDeclName" (ppr PprDebug x)
#endif
69 70 71 72 73 74 75 76 77 78 79 80 81
\end{code}

\begin{code}
instance (NamedThing name, Outputable name, Outputable pat,
	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
	=> Outputable (HsDecl tyvar uvar name pat) where

    ppr sty (TyD td)     = ppr sty td
    ppr sty (ClD cd)     = ppr sty cd
    ppr sty (SigD sig)   = ppr sty sig
    ppr sty (ValD binds) = ppr sty binds
    ppr sty (DefD def)   = ppr sty def
    ppr sty (InstD inst) = ppr sty inst
82

sof's avatar
sof committed
83 84 85 86 87 88 89 90
#ifdef DEBUG
instance (Ord3 name, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
	  NamedThing name, Outputable name, Outputable pat) => 
	  Ord3 (HsDecl tyvar uvar name pat) where
#else
instance (Ord3 name) => Ord3 (HsDecl tyvar uvar name pat) where
#endif
  d1 `cmp` d2 = hsDeclName d1 `cmp` hsDeclName d2
91 92 93
\end{code}


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

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

instance Outputable name => Outputable (FixityDecl name) where
sof's avatar
sof committed
104
  ppr sty (FixityDecl name fixity loc) = sep [ppr sty fixity, ppr sty name]
105 106
\end{code}

107

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

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

\end{code}

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

    ppr sty (TySynonym tycon tyvars mono_ty src_loc)
sof's avatar
sof committed
140
      = hang (pp_decl_head sty SLIT("type") empty tycon tyvars)
141
	     4 (ppr sty mono_ty)
142

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

pp_decl_head sty str pp_context tycon tyvars
sof's avatar
sof committed
154 155
  = hsep [ptext str, pp_context, ppr sty tycon,
	   interppSP sty tyvars, ptext SLIT("=")]
156

sof's avatar
sof committed
157
pp_condecls sty [] = empty		-- Curious!
158
pp_condecls sty (c:cs)
sof's avatar
sof committed
159
  = sep (ppr sty c : map (\ c -> (<>) (ptext SLIT("| ")) (ppr sty c)) cs)
160 161

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

sof's avatar
sof committed
170 171 172
pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Doc
pp_context_and_arrow sty [] = empty
pp_context_and_arrow sty theta = hsep [pprContext sty 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 188
		SrcLoc

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

    ppr sty (SpecDataSig tycon ty _)
sof's avatar
sof committed
189
      = hsep [text "{-# SPECIALIZE data", ppr sty 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
sof's avatar
sof committed
226 227
    ppr sty (ConDecl con cxt con_details  loc)
      = pp_context_and_arrow sty cxt <+> ppr_con_details sty con con_details
228

sof's avatar
sof committed
229 230
ppr_con_details sty con (InfixCon ty1 ty2)
  = hsep [ppr_bang sty ty1, ppr sty con, ppr_bang sty ty2]
231

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

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

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

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

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

\begin{code}
data ClassDecl tyvar uvar name pat
  = ClassDecl	(Context name)	    		-- context...
		name		    		-- name of the class
259
		(HsTyVar name)	    		-- the class type variable
260 261 262 263 264 265 266 267 268 269 270 271
		[Sig name]			-- methods' signatures
		(MonoBinds tyvar uvar name pat)	-- default methods
		(ClassPragmas name)
		SrcLoc
\end{code}

\begin{code}
instance (NamedThing name, Outputable name, Outputable pat,
	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
		=> Outputable (ClassDecl tyvar uvar name pat) where

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

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

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

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

		(MonoBinds tyvar uvar name pat)

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

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

		SrcLoc
\end{code}

\begin{code}
instance (NamedThing name, Outputable name, Outputable pat,
	  Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
	      => Outputable (InstDecl tyvar uvar name pat) where

312 313 314
    ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
      | case sty of { PprInterface -> True; other -> False} ||
	nullMonoBinds binds && null uprags
sof's avatar
sof committed
315
      = hsep [ptext SLIT("instance"), ppr sty inst_ty]
316 317

      | otherwise
sof's avatar
sof committed
318 319 320
      =	vcat [hsep [ptext SLIT("instance"), ppr sty inst_ty, ptext SLIT("where")],
	          nest 4 (ppr sty uprags),
	          nest 4 (ppr sty binds) ]
321 322 323 324 325 326 327 328
\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
329
		 (HsType name)    -- type to specialise to
330 331 332 333 334 335
		 SrcLoc

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

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

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

    ppr sty (DefaultDecl tys src_loc)
sof's avatar
sof committed
358
      = (<>) (ptext SLIT("default ")) (parens (interpp'SP sty tys))
359
\end{code}
360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375

%************************************************************************
%*									*
\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
    ppr sty (IfaceSig var ty _ _)
sof's avatar
sof committed
376
      = hang (hsep [ppr sty var, ptext SLIT("::")])
377 378 379 380 381
	     4 (ppr sty ty)

data HsIdInfo name
  = HsArity		ArityInfo
  | HsStrictness	(StrictnessInfo name)
sof's avatar
sof committed
382
  | HsUnfold		Bool (UfExpr name)	-- True <=> INLINE pragma
383 384 385 386 387 388
  | HsUpdate		UpdateInfo
  | HsDeforest		DeforestInfo
  | HsArgUsage		ArgUsageInfo
  | HsFBType		FBTypeInfo
	-- ToDo: specialisations
\end{code}