HsDecls.lhs 11.6 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 )
25
import HsBasic		( Fixity )
sof's avatar
sof committed
26
import TyCon		( NewOrData(..) )	-- Just a boolean flag really
27 28

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

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

%************************************************************************
%*									*
\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
57 58 59 60 61 62 63 64 65 66
#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
67
-- Others don't make sense
sof's avatar
sof committed
68 69 70
#ifdef DEBUG
hsDeclName x				      = pprPanic "HsDecls.hsDeclName" (ppr PprDebug x)
#endif
71 72 73 74 75 76 77 78 79 80 81 82 83
\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
84

sof's avatar
sof committed
85 86 87 88 89 90 91 92
#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
93 94 95
\end{code}


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

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

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

109

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

\begin{code}
data TyDecl name
sof's avatar
sof committed
118 119
  = TyData	NewOrData
		(Context name)	-- context
120
		name		-- type constructor
121
		[HsTyVar name]	-- type variables
122 123 124 125 126 127 128 129 130
		[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
131 132
		[HsTyVar name]	-- type variables
		(HsType name)	-- synonym expansion
133 134 135 136 137 138 139 140 141
		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
142
      = hang (pp_decl_head sty SLIT("type") empty tycon tyvars)
143
	     4 (ppr sty mono_ty)
144

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

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

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

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

sof's avatar
sof committed
172 173 174
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("=>")]
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 190
		SrcLoc

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

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

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

sof's avatar
sof committed
234 235 236 237 238
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
239

sof's avatar
sof committed
240 241 242 243 244 245 246 247
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
248
ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
249 250 251 252 253 254 255 256 257 258 259 260
\end{code}

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

\begin{code}
data ClassDecl tyvar uvar name pat
  = ClassDecl	(Context name)	    		-- context...
		name		    		-- name of the class
261
		(HsTyVar name)	    		-- the class type variable
262 263 264 265 266 267 268 269 270 271 272 273
		[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)
274 275 276 277
      | null sigs	-- No "where" part
      = top_matter

      | otherwise	-- Laid out
sof's avatar
sof committed
278 279 280 281
      = sep [hsep [top_matter, ptext SLIT("where {")],
	       nest 4 (vcat [sep (map ppr_sig sigs),
				   ppr sty methods,
				   char '}'])]
282
      where
sof's avatar
sof committed
283 284 285
        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
286 287 288 289 290 291 292 293 294 295
\end{code}

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

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

		(MonoBinds tyvar uvar name pat)

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

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

		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

314 315 316
    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
317
      = hsep [ptext SLIT("instance"), ppr sty inst_ty]
318 319

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

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

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

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

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

%************************************************************************
%*									*
\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
378
      = hang (hsep [ppr sty var, ptext SLIT("::")])
379 380 381 382 383 384 385 386 387 388 389 390
	     4 (ppr sty ty)

data HsIdInfo name
  = HsArity		ArityInfo
  | HsStrictness	(StrictnessInfo name)
  | HsUnfold		(UfExpr name)
  | HsUpdate		UpdateInfo
  | HsDeforest		DeforestInfo
  | HsArgUsage		ArgUsageInfo
  | HsFBType		FBTypeInfo
	-- ToDo: specialisations
\end{code}