HsDecls.lhs 21.1 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 4 5
%
\section[HsDecls]{Abstract syntax: global declarations}

6
Definitions for: @TyDecl@ and @ConDecl@, @ClassDecl@,
sof's avatar
sof committed
7
@InstDecl@, @DefaultDecl@ and @ForeignDecl@.
8 9

\begin{code}
10
module HsDecls (
11
	HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..),
12
	DefaultDecl(..), ForeignDecl(..), ForKind(..),
13
	ExtName(..), isDynamicExtName, extNameStatic,
14 15
	ConDecl(..), ConDetails(..), 
	BangType(..), getBangType,
16
	IfaceSig(..),  SpecDataSig(..), 
17
	DeprecDecl(..), DeprecTxt,
18 19 20 21
	hsDeclName, instDeclName, tyClDeclName, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule,
	toClassDeclNameList, 
	fromClassDeclNameList

22
    ) where
23

24
#include "HsVersions.h"
25 26

-- friends:
27
import HsBinds		( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
28
import HsExpr		( HsExpr )
29
import HsPragmas	( DataPragmas, ClassPragmas )
30
import HsImpExp		( IE(..) )
31
import HsTypes
32 33 34
import PprCore		( pprCoreRule )
import HsCore		( UfExpr(UfVar), UfBinder, IfaceSig(..), eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr )
import CoreSyn		( CoreRule(..) )
35
import BasicTypes	( NewOrData(..) )
sof's avatar
sof committed
36
import CallConv		( CallConv, pprCallConv )
37
import Name		( toRdrName )
38 39

-- others:
40 41
import FunDeps		( pprFundeps )
import Class		( FunDep )
42
import CStrings		( CLabelString, pprCLabelString )
43
import Outputable	
44
import SrcLoc		( SrcLoc, noSrcLoc )
45 46
\end{code}

47 48 49 50 51 52 53 54

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

\begin{code}
55 56 57
data HsDecl name pat
  = TyClD	(TyClDecl name pat)
  | InstD	(InstDecl  name pat)
58
  | DefD	(DefaultDecl name)
59
  | ValD	(HsBinds name pat)
sof's avatar
sof committed
60
  | ForD        (ForeignDecl name)
61 62
  | SigD	(IfaceSig name)
  | FixD	(FixitySig name)
63
  | DeprecD	(DeprecDecl name)
64
  | RuleD	(RuleDecl name pat)
65 66 67 68 69 70 71 72 73 74 75 76 77

-- NB: all top-level fixity decls are contained EITHER
-- EITHER FixDs
-- OR     in the ClassDecls in TyClDs
--
-- The former covers
-- 	a) data constructors
-- 	b) class methods (but they can be also done in the
-- 		signatures of class decls)
--	c) imported functions (that have an IfacSig)
--	d) top level decls
--
-- The latter is for class methods only
78 79 80
\end{code}

\begin{code}
sof's avatar
sof committed
81
#ifdef DEBUG
82
hsDeclName :: (Outputable name, Outputable pat)
83
	   => HsDecl name pat -> name
sof's avatar
sof committed
84
#endif
85 86 87 88 89
hsDeclName (TyClD decl)				    = tyClDeclName decl
hsDeclName (InstD   decl)			    = instDeclName decl
hsDeclName (SigD    (IfaceSig name _ _ _))	    = name
hsDeclName (ForD    (ForeignDecl name _ _ _ _ _))   = name
hsDeclName (FixD    (FixitySig name _ _))	    = name
90
-- Others don't make sense
sof's avatar
sof committed
91
#ifdef DEBUG
92
hsDeclName x				      = pprPanic "HsDecls.hsDeclName" (ppr x)
sof's avatar
sof committed
93
#endif
94

95

96
tyClDeclName :: TyClDecl name pat -> name
97
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _ _)      = name
98
tyClDeclName (TySynonym name _ _ _)                 = name
99
tyClDeclName (ClassDecl _ name _ _ _ _ _ _ _ )      = name
100 101 102

instDeclName :: InstDecl name pat -> name
instDeclName (InstDecl _ _ _ (Just name) _) = name
103

104 105 106
\end{code}

\begin{code}
107
instance (Outputable name, Outputable pat)
108
	=> Outputable (HsDecl name pat) where
109

110
    ppr (TyClD dcl)  = ppr dcl
111 112 113 114
    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
115
    ppr (ForD fd)    = ppr fd
116
    ppr (FixD fd)    = ppr fd
117
    ppr (RuleD rd)   = ppr rd
118 119 120 121 122 123 124
    ppr (DeprecD dd) = ppr dd
\end{code}

\begin{code}
instance Ord name => Eq (HsDecl name pat) where
	-- Used only when comparing interfaces, 
	-- at which time only signature and type/class decls
125
   (SigD s1)  == (SigD s2)  = s1 == s2
126
   (TyClD d1) == (TyClD d2) = d1 == d2
127
   _          == _          = False
128 129
\end{code}

130

131 132 133 134 135 136
%************************************************************************
%*									*
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%*									*
%************************************************************************

137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178
Type and class declarations carry 'implicit names'.  In particular:

Type A.  
~~~~~~~
  Each data type decl defines 
	a worker name for each constructor
	to-T and from-T convertors
  Each class decl defines
	a tycon for the class
	a data constructor for that tycon
	the worker for that constructor
	a selector for each superclass

All have occurrence names that are derived uniquely from their parent declaration.

None of these get separate definitions in an interface file; they are
fully defined by the data or class decl.  But they may *occur* in
interface files, of course.  Any such occurrence must haul in the
relevant type or class decl.

Plan of attack:
 - Make up their occurrence names immediately

 - Ensure they "point to" the parent data/class decl 
   when loading that decl from an interface file

 - When renaming the decl look them up in the name cache,
   ensure correct module and provenance is set

Type B: Default methods and dictionary functions
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Have their own binding in an interface file.

Default methods : occurrence name is derived uniquely from the class decl.
Dict functions  : occurrence name is derived from the instance decl, plus a unique number.

Plan of attack: 
  - Do *not* make them point to the parent class decl
  - Interface-file decls: treat just like Type A
  - Source-file decls:    the names aren't in the decl at all; 
			  instead the typechecker makes them up

179
\begin{code}
180
data TyClDecl name pat
sof's avatar
sof committed
181
  = TyData	NewOrData
182 183
		(HsContext name) -- context
		name		 -- type constructor
184
		[HsTyVarBndr name]	 -- type variables
185
		[ConDecl name]	 -- data constructors (empty if abstract)
186
		Int		 -- Number of data constructors (valid even if type is abstract)
187 188 189 190
		(Maybe [name])	 -- derivings; Nothing => not specified
				 -- (i.e., derive default); Just [] => derive
				 -- *nothing*; Just <list> => as you would
				 -- expect...
191 192
		(DataPragmas name)
		SrcLoc
193 194
		name             -- generic converter functions
		name             -- generic converter functions
195

196 197 198
  | TySynonym	name		        -- type constructor
                [HsTyVarBndr name]	-- type variables
		(HsType name)	        -- synonym expansion
199 200
		SrcLoc

201
  | ClassDecl	(HsContext name)    	-- context...
202
		name		    	-- name of the class
203 204
		[HsTyVarBndr name]	-- the class type variables
		[FunDep name]		-- functional dependencies
205
		[Sig name]		-- methods' signatures
206 207
		(MonoBinds name pat)	-- default methods
		(ClassPragmas name)
208 209 210 211 212 213 214
		[name]	                -- The names of the tycon, datacon 
					-- wrapper, datacon worker,
					-- and superclass selectors for this 
					-- class (the first 3 are at the front 
					-- of the list in this order)
					-- These are filled in as the 
					-- ClassDecl is made.
215
		SrcLoc
216

217 218 219 220 221 222 223 224 225 226
-- Put type signatures in and explain further!!
                -- The names of the tycon, datacon 
					-- wrapper, datacon worker,
					-- and superclass selectors for this 
					-- class (the first 3 are at the front 
					-- of the list in this order)
					-- These are filled in as the 
toClassDeclNameList (a,b,c,ds) = a:b:c:ds
fromClassDeclNameList (a:b:c:ds) = (a,b,c,ds)

227 228
instance Ord name => Eq (TyClDecl name pat) where
	-- Used only when building interface files
229 230
  (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _ _)
       (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _ _)
231 232 233
    = n1 == n2 &&
      nd1 == nd2 &&
      eqWithHsTyVars tvs1 tvs2 (\ env -> 
234
   	  eq_hsContext env cxt1 cxt2  &&
235 236 237 238 239 240 241 242
	  eqListBy (eq_ConDecl env) cons1 cons2
      )

  (==) (TySynonym n1 tvs1 ty1 _)
       (TySynonym n2 tvs2 ty2 _)
    =  n1 == n2 &&
       eqWithHsTyVars tvs1 tvs2 (\ env -> eq_hsType env ty1 ty2)

243 244
  (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ _ )
       (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ _ )
245 246 247 248 249 250 251
    =  n1 == n2 &&
       eqWithHsTyVars tvs1 tvs2 (\ env -> 
	  eq_hsContext env cxt1 cxt2 &&
	  eqListBy (eq_hsFD env) fds1 fds2 &&
	  eqListBy (eq_cls_sig env) sigs1 sigs2
       )

252 253 254
  (==) _ _ = False	-- default case


255 256 257
eq_hsFD env (ns1,ms1) (ns2,ms2)
  = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2

258 259 260 261 262 263 264
eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
  = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2
  where
	-- Ignore the name of the default method.
	-- This is used for comparing declarations before putting
	-- them into interface files, and the name of the default 
	-- method isn't relevant
265
    (Just (explicit_dm1)) `eq_dm` (Just (explicit_dm2)) = explicit_dm1 == explicit_dm2
266 267
    Nothing		    `eq_dm` Nothing		    = True
    dm1			    `eq_dm` dm2			    = False
268 269 270
\end{code}

\begin{code}
271 272 273
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int)
	-- class, data, newtype, synonym decls
countTyClDecls decls 
274 275 276
 = (length [() | ClassDecl _ _ _ _ _ _ _ _ _  <- decls],
    length [() | TyData DataType _ _ _ _ _ _ _ _ _ _  <- decls],
    length [() | TyData NewType  _ _ _ _ _ _ _ _ _ _  <- decls],
277
    length [() | TySynonym _ _ _ _	           <- decls])
278 279 280 281 282 283

isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool

isSynDecl (TySynonym _ _ _ _) = True
isSynDecl other		      = False

284 285
isDataDecl (TyData _ _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other		          = False
286

287
isClassDecl (ClassDecl _ _ _ _ _ _ _ _ _ ) = True
288
isClassDecl other		 	        = False
289 290 291
\end{code}

\begin{code}
292
instance (Outputable name, Outputable pat)
293
	      => Outputable (TyClDecl name pat) where
294

295
    ppr (TySynonym tycon tyvars mono_ty src_loc)
296
      = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
297
	     4 (ppr mono_ty)
298

299
    ppr (TyData new_or_data context tycon tyvars condecls ncons derivings pragmas src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
300
      = pp_tydecl
301 302
		  (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
		  (pp_condecls condecls ncons)
303
		  derivings
sof's avatar
sof committed
304 305 306 307
      where
	keyword = case new_or_data of
			NewType  -> SLIT("newtype")
			DataType -> SLIT("data")
308

309
    ppr (ClassDecl context clas tyvars fds sigs methods pragmas _ src_loc)
310 311 312 313 314
      | null sigs	-- No "where" part
      = top_matter

      | otherwise	-- Laid out
      = sep [hsep [top_matter, ptext SLIT("where {")],
315
	     nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])]
316
      where
317
        top_matter  = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
318
	ppr_sig sig = ppr sig <> semi
319 320 321
	pp_methods = getPprStyle $ \ sty ->
        	     if ifaceStyle sty then empty else ppr methods
        
322

323 324
pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
325

326 327
pp_condecls []     ncons = ptext SLIT("{- abstract with") <+> int ncons <+> ptext SLIT("constructors -}")
pp_condecls (c:cs) ncons = sep (ppr c : map (\ c -> ptext SLIT("|") <+> ppr c) cs)
328

329
pp_tydecl pp_head pp_decl_rhs derivings
sof's avatar
sof committed
330
  = hang pp_head 4 (sep [
331
	pp_decl_rhs,
332 333 334
	case derivings of
	  Nothing 	   -> empty
	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
335
    ])
336 337 338 339 340 341 342 343 344
\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
345
		(HsType name)
346 347
		SrcLoc

348
instance (Outputable name)
349 350
	      => Outputable (SpecDataSig name) where

351 352
    ppr (SpecDataSig tycon ty _)
      = hsep [text "{-# SPECIALIZE data", ppr ty, text "#-}"]
353 354 355 356 357 358 359 360 361 362
\end{code}

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

\begin{code}
data ConDecl name
363 364 365 366 367
  = ConDecl 	name			-- Constructor name; this is used for the
					-- DataCon itself, and for the user-callable wrapper Id

		name			-- Name of the constructor's 'worker Id'
					-- Filled in as the ConDecl is built
368

369
		[HsTyVarBndr name]		-- Existentially quantified type variables
370
		(HsContext name)	-- ...and context
371 372
					-- If both are empty then there are no existentials

sof's avatar
sof committed
373
		(ConDetails name)
374 375
		SrcLoc

sof's avatar
sof committed
376 377 378 379 380 381
data ConDetails name
  = VanillaCon			-- prefix-style con decl
		[BangType name]

  | InfixCon			-- infix-style con decl
		(BangType name)
382 383
		(BangType name)

sof's avatar
sof committed
384
  | RecCon			-- record-style con decl
385
		[([name], BangType name)]	-- list of "fields"
386

387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403
eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
	       (ConDecl n2 _ tvs2 cxt2 cds2 _)
  = n1 == n2 &&
    (eqWithHsTyVars tvs1 tvs2	$ \ env ->
     eq_hsContext env cxt1 cxt2	&&
     eq_ConDetails env cds1 cds2)

eq_ConDetails env (VanillaCon bts1) (VanillaCon bts2)
  = eqListBy (eq_btype env) bts1 bts2
eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2)
  = eq_btype env bta1 bta2 && eq_btype env btb1 btb2
eq_ConDetails env (RecCon fs1) (RecCon fs2)
  = eqListBy (eq_fld env) fs1 fs2
eq_ConDetails env _ _ = False

eq_fld env (ns1,bt1) (ns2, bt2) = ns1==ns2 && eq_btype env bt1 bt2

404 405 406 407 408 409 410 411 412 413
  
data BangType name
  = Banged   (HsType name)	-- HsType: to allow Haskell extensions
  | Unbanged (HsType name)	-- (MonoType only needed for straight Haskell)
  | Unpacked (HsType name)	-- Field is strict and to be unpacked if poss.

getBangType (Banged ty)   = ty
getBangType (Unbanged ty) = ty
getBangType (Unpacked ty) = ty

414 415 416
eq_btype env (Banged t1)   (Banged t2)   = eq_hsType env t1 t2
eq_btype env (Unbanged t1) (Unbanged t2) = eq_hsType env t1 t2
eq_btype env (Unpacked t1) (Unpacked t2) = eq_hsType env t1 t2
417
eq_btype env _		   _		 = False
418 419 420
\end{code}

\begin{code}
421
instance (Outputable name) => Outputable (ConDecl name) where
422
    ppr (ConDecl con _ tvs cxt con_details  loc)
423
      = sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
424

425 426
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
427

428 429
ppr_con_details con (VanillaCon tys)
  = ppr con <+> hsep (map (ppr_bang) tys)
sof's avatar
sof committed
430

431 432
ppr_con_details con (RecCon fields)
  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
sof's avatar
sof committed
433
  where
434
    ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
435
			 dcolon <+>
436
			 ppr_bang ty
sof's avatar
sof committed
437

438 439 440
instance Outputable name => Outputable (BangType name) where
    ppr = ppr_bang

441 442
ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
443
ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
444 445 446 447 448
\end{code}


%************************************************************************
%*									*
sof's avatar
sof committed
449
\subsection[InstDecl]{An instance declaration
450 451 452 453
%*									*
%************************************************************************

\begin{code}
454
data InstDecl name pat
455
  = InstDecl	(HsType name)	-- Context => Class Instance-type
456 457 458
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.

459
		(MonoBinds name pat)
460

461
		[Sig name]		-- User-supplied pragmatic info
462

463 464
		(Maybe name)		-- Name for the dictionary function
					-- Nothing for source-file instance decls
465 466 467 468 469

		SrcLoc
\end{code}

\begin{code}
470
instance (Outputable name, Outputable pat)
471
	      => Outputable (InstDecl name pat) where
472

473
    ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
474
      = getPprStyle $ \ sty ->
475
        if ifaceStyle sty then
476
           hsep [ptext SLIT("instance"), ppr inst_ty, equals, pp_dfun]
477 478 479 480
	else
	   vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
	         nest 4 (ppr uprags),
	         nest 4 (ppr binds) ]
481 482 483 484
      where
	pp_dfun = case maybe_dfun_name of
		    Just df -> ppr df
		    Nothing -> empty
485 486
\end{code}

487 488 489 490 491 492 493
\begin{code}
instance Ord name => Eq (InstDecl name pat) where
	-- Used for interface comparison only, so don't compare bindings
  (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _)
       = inst_ty1 == inst_ty2 && dfun1 == dfun2
\end{code}

494 495 496 497 498 499 500 501 502 503 504 505 506

%************************************************************************
%*									*
\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
507
  = DefaultDecl	[HsType name]
508 509
		SrcLoc

510
instance (Outputable name)
511 512
	      => Outputable (DefaultDecl name) where

513 514
    ppr (DefaultDecl tys src_loc)
      = ptext SLIT("default") <+> parens (interpp'SP tys)
515
\end{code}
516

sof's avatar
sof committed
517 518 519 520 521 522 523 524 525 526
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
data ForeignDecl name = 
   ForeignDecl 
        name 
sof's avatar
sof committed
527
	ForKind   
sof's avatar
sof committed
528 529 530 531 532
	(HsType name)
	ExtName
	CallConv
	SrcLoc

533
instance (Outputable name)
sof's avatar
sof committed
534 535 536 537
	      => Outputable (ForeignDecl name) where

    ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
      = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> 
538
        ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
sof's avatar
sof committed
539 540 541
        where
         (ppr_imp_exp, ppr_unsafe) =
	   case imp_exp of
sof's avatar
sof committed
542 543 544 545 546 547 548 549 550 551
	     FoLabel     -> (ptext SLIT("label"), empty)
	     FoExport    -> (ptext SLIT("export"), empty)
	     FoImport us 
		| us        -> (ptext SLIT("import"), ptext SLIT("unsafe"))
		| otherwise -> (ptext SLIT("import"), empty)

data ForKind
 = FoLabel
 | FoExport
 | FoImport Bool -- True  => unsafe call.
sof's avatar
sof committed
552 553 554

data ExtName
 = Dynamic 
555 556 557 558 559 560 561 562 563 564 565 566
 | ExtName CLabelString 	-- The external name of the foreign thing,
	   (Maybe CLabelString)	-- and optionally its DLL or module name
				-- Both of these are completely unencoded; 
				-- we just print them as they are

isDynamicExtName :: ExtName -> Bool
isDynamicExtName Dynamic = True
isDynamicExtName _	 = False

extNameStatic :: ExtName -> CLabelString
extNameStatic (ExtName f _) = f
extNameStatic Dynamic	    = panic "staticExtName: Dynamic - shouldn't ever happen."
sof's avatar
sof committed
567 568 569 570 571

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) } <+> 
572
     doubleQuotes (pprCLabelString nm)
sof's avatar
sof committed
573 574
\end{code}

575 576
%************************************************************************
%*									*
577
\subsection{Transformation rules}
578 579 580 581
%*									*
%************************************************************************

\begin{code}
582
data RuleDecl name pat
583
  = HsRule			-- Source rule
584 585 586 587 588 589 590 591
	FAST_STRING		-- Rule name
	[name]			-- Forall'd tyvars, filled in by the renamer with
				-- tyvars mentioned in sigs; then filled out by typechecker
	[RuleBndr name]		-- Forall'd term vars
	(HsExpr name pat)	-- LHS
	(HsExpr name pat)	-- RHS
	SrcLoc		

592 593 594 595 596 597
  | IfaceRule	 		-- One that's come in from an interface file; pre-typecheck
	FAST_STRING
	[UfBinder name]		-- Tyvars and term vars
	name			-- Head of lhs
	[UfExpr name]		-- Args of LHS
	(UfExpr name)		-- Pre typecheck
598 599
	SrcLoc		

600 601 602 603 604
  | IfaceRuleOut		-- Post typecheck
	name			-- Head of LHS
	CoreRule


605 606 607
data RuleBndr name
  = RuleBndr name
  | RuleBndrSig name (HsType name)
608

609 610 611 612 613 614 615
instance Ord name => Eq (RuleDecl name pat) where
  -- Works for IfaceRules only; used when comparing interface file versions
  (IfaceRule n1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 bs2 f2 es2 rhs2 _)
     = n1==n2 && f1 == f2 && 
       eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> 
       eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2))

616 617
instance (Outputable name, Outputable pat)
	      => Outputable (RuleDecl name pat) where
618
  ppr (HsRule name tvs ns lhs rhs loc)
619 620 621
	= sep [text "{-# RULES" <+> doubleQuotes (ptext name),
	       pp_forall, ppr lhs, equals <+> ppr rhs,
               text "#-}" ]
622 623 624 625 626
	where
	  pp_forall | null tvs && null ns = empty
		    | otherwise		  = text "forall" <+> 
					    fsep (map ppr tvs ++ map ppr ns)
					    <> dot
627 628 629 630 631 632 633 634 635

  ppr (IfaceRule name tpl_vars fn tpl_args rhs loc) 
    = hsep [ doubleQuotes (ptext name),
	   ptext SLIT("__forall") <+> braces (interppSP tpl_vars),
	   ppr fn <+> sep (map (pprUfExpr parens) tpl_args),
	   ptext SLIT("=") <+> ppr rhs
      ] <+> semi

  ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule
636 637 638 639

instance Outputable name => Outputable (RuleBndr name) where
   ppr (RuleBndr name) = ppr name
   ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671

toHsRule id (BuiltinRule _)
  = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id)

toHsRule id (Rule name bndrs args rhs)
  = IfaceRule name (map toUfBndr bndrs) (toRdrName id)
	      (map toUfExpr args) (toUfExpr rhs) noSrcLoc

bogusIfaceRule id
  = IfaceRule SLIT("bogus") [] (toRdrName id) [] (UfVar (toRdrName id)) noSrcLoc
\end{code}


%************************************************************************
%*									*
\subsection[DeprecDecl]{Deprecations}
%*									*
%************************************************************************

We use exported entities for things to deprecate. Cunning trick (hack?):
`IEModuleContents undefined' is used for module deprecation.

\begin{code}
data DeprecDecl name = Deprecation (IE name) DeprecTxt SrcLoc

type DeprecTxt = FAST_STRING	-- reason/explanation for deprecation

instance Outputable name => Outputable (DeprecDecl name) where
   ppr (Deprecation (IEModuleContents _) txt _)
      = hsep [text "{-# DEPRECATED",            doubleQuotes (ppr txt), text "#-}"]
   ppr (Deprecation thing txt _)
      = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"]
672
\end{code}