HsDecls.lhs 21.6 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
	DeprecDecl(..), DeprecTxt,
17
	hsDeclName, instDeclName, tyClDeclName, tyClDeclNames,
18
	isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
19
	mkClassDeclSysNames, isIfaceRuleDecl,
20
	getClassDeclSysNames
21
    ) where
22

23
#include "HsVersions.h"
24 25

-- friends:
26
import HsBinds		( HsBinds, MonoBinds, Sig(..), FixitySig(..) )
27
import HsExpr		( HsExpr )
28
import HsTypes
29
import PprCore		( pprCoreRule )
30 31
import HsCore		( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo,
			  eq_ufBinders, eq_ufExpr, pprUfExpr 
32
			)
33
import CoreSyn		( CoreRule(..) )
34
import BasicTypes	( NewOrData(..) )
sof's avatar
sof committed
35
import CallConv		( CallConv, pprCallConv )
36 37

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

45 46 47 48 49 50 51 52

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

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

-- 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
75 76 77
\end{code}

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

91 92 93

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

95 96 97
\end{code}

\begin{code}
98
instance (Outputable name, Outputable pat)
99
	=> Outputable (HsDecl name pat) where
100

101
    ppr (TyClD dcl)  = ppr dcl
102 103 104
    ppr (ValD binds) = ppr binds
    ppr (DefD def)   = ppr def
    ppr (InstD inst) = ppr inst
sof's avatar
sof committed
105
    ppr (ForD fd)    = ppr fd
106
    ppr (FixD fd)    = ppr fd
107
    ppr (RuleD rd)   = ppr rd
108 109 110 111 112 113 114 115
    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
   (TyClD d1) == (TyClD d2) = d1 == d2
116
   _          == _          = False
117 118
\end{code}

119

120 121 122 123 124 125
%************************************************************************
%*									*
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
%*									*
%************************************************************************

126 127 128 129 130 131 132 133 134 135 136 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
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

168
\begin{code}
169
data TyClDecl name pat
170 171 172 173 174 175
  = IfaceSig	name			-- It may seem odd to classify an interface-file signature
		(HsType name)		-- as a 'TyClDecl', but it's very convenient.  These three
		[HsIdInfo name]		-- are the kind that appear in interface files.
		SrcLoc

  | TyData	NewOrData
176 177
		(HsContext name) -- context
		name		 -- type constructor
178
		[HsTyVarBndr name]	 -- type variables
179
		[ConDecl name]	 -- data constructors (empty if abstract)
180
		Int		 -- Number of data constructors (valid even if type is abstract)
181 182 183 184
		(Maybe [name])	 -- derivings; Nothing => not specified
				 -- (i.e., derive default); Just [] => derive
				 -- *nothing*; Just <list> => as you would
				 -- expect...
185
		SrcLoc
186 187
		name             -- generic converter functions
		name             -- generic converter functions
188

189 190 191
  | TySynonym	name		        -- type constructor
                [HsTyVarBndr name]	-- type variables
		(HsType name)	        -- synonym expansion
192 193
		SrcLoc

194
  | ClassDecl	(HsContext name)    	-- context...
195
		name		    	-- name of the class
196 197
		[HsTyVarBndr name]	-- the class type variables
		[FunDep name]		-- functional dependencies
198
		[Sig name]		-- methods' signatures
199
		(MonoBinds name pat)	-- default methods
200
		(ClassDeclSysNames name)
201
		SrcLoc
202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222
\end{code}

Simple classifiers

\begin{code}
isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool

isIfaceSigDecl (IfaceSig _ _ _ _) = True
isIfaceSigDecl other		  = False

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

isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True
isDataDecl other		        = False

isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True
isClassDecl other		 	 = False
\end{code}

Dealing with names
223

224
\begin{code}
225
tyClDeclName :: TyClDecl name pat -> name
226
tyClDeclName (IfaceSig name _ _ _)	     = name
227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246
tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name
tyClDeclName (TySynonym name _ _ _)          = name
tyClDeclName (ClassDecl _ name _ _ _ _ _ _)  = name


tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
-- Returns all the binding names of the decl, along with their SrcLocs
-- The first one is guaranteed to be the name of the decl
-- For record fields, the first one counts as the SrcLoc
-- We use the equality to filter out duplicate field names

tyClDeclNames (TySynonym name _ _ loc)
  = [(name,loc)]

tyClDeclNames (ClassDecl _ name _ _ sigs _ _ loc)
  = (name,loc) : [(name,loc) | ClassOpSig n _ _ loc <- sigs]

tyClDeclNames (TyData _ _ name _ cons _ _ loc _ _)
  = (name,loc) : conDeclsNames cons

247
tyClDeclNames (IfaceSig _ _ _ _) = []
248 249 250 251 252 253 254 255 256 257 258 259 260 261

type ClassDeclSysNames name = [name]
	-- 	[tycon, datacon wrapper, datacon worker, 
	--	 superclass selector 1, ..., superclass selector n]
	-- They are kept in a list rather than a tuple to make the
	-- renamer easier.

mkClassDeclSysNames  :: (name, name, name, [name]) -> [name]
getClassDeclSysNames :: [name] -> (name, name, name, [name])
mkClassDeclSysNames  (a,b,c,ds) = a:b:c:ds
getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds)
\end{code}

\begin{code}
262 263
instance Ord name => Eq (TyClDecl name pat) where
	-- Used only when building interface files
264 265 266
  (==) (IfaceSig n1 t1 i1 _)
       (IfaceSig n2 t2 i2 _) = n1==n2 && t1==t2 && i1==i2

267 268
  (==) (TyData nd1 cxt1 n1 tvs1 cons1 _ _ _ _ _)
       (TyData nd2 cxt2 n2 tvs2 cons2 _ _ _ _ _)
269 270 271
    = n1 == n2 &&
      nd1 == nd2 &&
      eqWithHsTyVars tvs1 tvs2 (\ env -> 
272
   	  eq_hsContext env cxt1 cxt2  &&
273 274 275 276 277 278 279 280
	  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)

281 282
  (==) (ClassDecl cxt1 n1 tvs1 fds1 sigs1 _ _ _ )
       (ClassDecl cxt2 n2 tvs2 fds2 sigs2 _ _ _ )
283 284 285 286 287 288 289
    =  n1 == n2 &&
       eqWithHsTyVars tvs1 tvs2 (\ env -> 
	  eq_hsContext env cxt1 cxt2 &&
	  eqListBy (eq_hsFD env) fds1 fds2 &&
	  eqListBy (eq_cls_sig env) sigs1 sigs2
       )

290 291 292
  (==) _ _ = False	-- default case


293 294 295
eq_hsFD env (ns1,ms1) (ns2,ms2)
  = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2

296 297 298 299 300 301 302
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
303
    (Just (explicit_dm1)) `eq_dm` (Just (explicit_dm2)) = explicit_dm1 == explicit_dm2
304 305
    Nothing		    `eq_dm` Nothing		    = True
    dm1			    `eq_dm` dm2			    = False
306 307 308
\end{code}

\begin{code}
309
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
310 311
	-- class, data, newtype, synonym decls
countTyClDecls decls 
312 313 314
 = (length [() | ClassDecl _ _ _ _ _ _ _ _	   <- decls],
    length [() | TyData DataType _ _ _ _ _ _ _ _ _ <- decls],
    length [() | TyData NewType  _ _ _ _ _ _ _ _ _ <- decls],
315 316
    length [() | TySynonym _ _ _ _	           <- decls],
    length [() | IfaceSig _ _ _ _	           <- decls])
317 318 319
\end{code}

\begin{code}
320
instance (Outputable name, Outputable pat)
321
	      => Outputable (TyClDecl name pat) where
322

323 324
    ppr (IfaceSig var ty info _) = hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]

325
    ppr (TySynonym tycon tyvars mono_ty src_loc)
326
      = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
327
	     4 (ppr mono_ty)
328

329 330
    ppr (TyData new_or_data context tycon tyvars condecls ncons 
		derivings src_loc gen_conv1 gen_conv2) -- The generic names are not printed out ATM
331
      = pp_tydecl
332 333
		  (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
		  (pp_condecls condecls ncons)
334
		  derivings
sof's avatar
sof committed
335 336 337 338
      where
	keyword = case new_or_data of
			NewType  -> SLIT("newtype")
			DataType -> SLIT("data")
339

340
    ppr (ClassDecl context clas tyvars fds sigs methods _ src_loc)
341 342 343 344 345
      | null sigs	-- No "where" part
      = top_matter

      | otherwise	-- Laid out
      = sep [hsep [top_matter, ptext SLIT("where {")],
346
	     nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])]
347
      where
348
        top_matter  = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
349
	ppr_sig sig = ppr sig <> semi
350 351 352 353 354
	pp_methods = getPprStyle $ \ sty ->
        	     if ifaceStyle sty then empty else ppr methods
        
pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
355

356 357
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)
358

359
pp_tydecl pp_head pp_decl_rhs derivings
sof's avatar
sof committed
360
  = hang pp_head 4 (sep [
361
	pp_decl_rhs,
362 363 364
	case derivings of
	  Nothing 	   -> empty
	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
365
    ])
366 367 368 369 370 371 372 373 374 375 376
\end{code}


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

\begin{code}
data ConDecl name
377 378 379 380 381
  = 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
382

383
		[HsTyVarBndr name]	-- Existentially quantified type variables
384
		(HsContext name)	-- ...and context
385 386
					-- If both are empty then there are no existentials

sof's avatar
sof committed
387
		(ConDetails name)
388 389
		SrcLoc

sof's avatar
sof committed
390 391 392 393 394 395
data ConDetails name
  = VanillaCon			-- prefix-style con decl
		[BangType name]

  | InfixCon			-- infix-style con decl
		(BangType name)
396 397
		(BangType name)

sof's avatar
sof committed
398
  | RecCon			-- record-style con decl
399
		[([name], BangType name)]	-- list of "fields"
400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416
\end{code}

\begin{code}
conDeclsNames :: Eq name => [ConDecl name] -> [(name,SrcLoc)]
  -- See tyClDeclNames for what this does
  -- The function is boringly complicated because of the records
  -- And since we only have equality, we have to be a little careful
conDeclsNames cons
  = snd (foldl do_one ([], []) cons)
  where
    do_one (flds_seen, acc) (ConDecl name _ _ _ details loc)
	= do_details ((name,loc):acc) details
	where
	  do_details acc (RecCon flds) = foldl do_fld (flds_seen, acc) flds
	  do_details acc other	       = (flds_seen, acc)

	  do_fld acc (flds, _) = foldl do_fld1 acc flds
417

418 419 420 421 422 423
	  do_fld1 (flds_seen, acc) fld
		| fld `elem` flds_seen = (flds_seen,acc)
		| otherwise	       = (fld:flds_seen, (fld,loc):acc)
\end{code}

\begin{code}
424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439
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
440
\end{code}
441
  
442
\begin{code}
443 444 445 446 447 448 449 450 451
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

452 453 454
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
455
eq_btype env _		   _		 = False
456 457 458
\end{code}

\begin{code}
459
instance (Outputable name) => Outputable (ConDecl name) where
460
    ppr (ConDecl con _ tvs cxt con_details  loc)
461
      = sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
462

463 464
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
465

466 467
ppr_con_details con (VanillaCon tys)
  = ppr con <+> hsep (map (ppr_bang) tys)
sof's avatar
sof committed
468

469 470
ppr_con_details con (RecCon fields)
  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
sof's avatar
sof committed
471
  where
472
    ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
473
			 dcolon <+>
474
			 ppr_bang ty
sof's avatar
sof committed
475

476 477 478
instance Outputable name => Outputable (BangType name) where
    ppr = ppr_bang

479 480
ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
481
ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
482 483 484 485 486
\end{code}


%************************************************************************
%*									*
sof's avatar
sof committed
487
\subsection[InstDecl]{An instance declaration
488 489 490 491
%*									*
%************************************************************************

\begin{code}
492
data InstDecl name pat
493
  = InstDecl	(HsType name)	-- Context => Class Instance-type
494 495 496
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.

497
		(MonoBinds name pat)
498

499
		[Sig name]		-- User-supplied pragmatic info
500

501 502
		(Maybe name)		-- Name for the dictionary function
					-- Nothing for source-file instance decls
503 504 505 506 507

		SrcLoc
\end{code}

\begin{code}
508
instance (Outputable name, Outputable pat)
509
	      => Outputable (InstDecl name pat) where
510

511
    ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
512
      = getPprStyle $ \ sty ->
513
        if ifaceStyle sty then
514
           hsep [ptext SLIT("instance"), ppr inst_ty, equals, pp_dfun]
515 516 517 518
	else
	   vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
	         nest 4 (ppr uprags),
	         nest 4 (ppr binds) ]
519 520 521 522
      where
	pp_dfun = case maybe_dfun_name of
		    Just df -> ppr df
		    Nothing -> empty
523 524
\end{code}

525 526 527 528 529 530 531
\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}

532 533 534 535 536 537 538 539 540 541 542 543 544

%************************************************************************
%*									*
\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
545
  = DefaultDecl	[HsType name]
546 547
		SrcLoc

548
instance (Outputable name)
549 550
	      => Outputable (DefaultDecl name) where

551 552
    ppr (DefaultDecl tys src_loc)
      = ptext SLIT("default") <+> parens (interpp'SP tys)
553
\end{code}
554

sof's avatar
sof committed
555 556 557 558 559 560 561 562 563 564
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
data ForeignDecl name = 
   ForeignDecl 
        name 
sof's avatar
sof committed
565
	ForKind   
sof's avatar
sof committed
566 567 568 569 570
	(HsType name)
	ExtName
	CallConv
	SrcLoc

571
instance (Outputable name)
sof's avatar
sof committed
572 573 574 575
	      => Outputable (ForeignDecl name) where

    ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
      = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> 
576
        ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
sof's avatar
sof committed
577 578 579
        where
         (ppr_imp_exp, ppr_unsafe) =
	   case imp_exp of
sof's avatar
sof committed
580 581 582 583 584 585 586 587 588 589
	     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
590 591 592

data ExtName
 = Dynamic 
593 594 595 596 597 598 599 600 601 602 603 604
 | 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
605 606 607 608 609

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

613 614
%************************************************************************
%*									*
615
\subsection{Transformation rules}
616 617 618 619
%*									*
%************************************************************************

\begin{code}
620
data RuleDecl name pat
621
  = HsRule			-- Source rule
622 623 624 625 626 627 628 629
	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		

630 631 632 633 634 635
  | 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
636 637
	SrcLoc		

638 639 640 641
  | IfaceRuleOut		-- Post typecheck
	name			-- Head of LHS
	CoreRule

642 643
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other		     = True
644

645 646 647
data RuleBndr name
  = RuleBndr name
  | RuleBndrSig name (HsType name)
648

649 650 651 652 653 654 655
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))

656 657
instance (Outputable name, Outputable pat)
	      => Outputable (RuleDecl name pat) where
658
  ppr (HsRule name tvs ns lhs rhs loc)
659 660 661
	= sep [text "{-# RULES" <+> doubleQuotes (ptext name),
	       pp_forall, ppr lhs, equals <+> ppr rhs,
               text "#-}" ]
662 663 664 665 666
	where
	  pp_forall | null tvs && null ns = empty
		    | otherwise		  = text "forall" <+> 
					    fsep (map ppr tvs ++ map ppr ns)
					    <> dot
667 668 669 670 671 672 673 674 675

  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
676 677 678 679

instance Outputable name => Outputable (RuleBndr name) where
   ppr (RuleBndr name) = ppr name
   ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
680 681 682 683 684 685 686 687 688
\end{code}


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

689
We use exported entities for things to deprecate.
690 691

\begin{code}
692
data DeprecDecl name = Deprecation name DeprecTxt SrcLoc
693 694 695 696

type DeprecTxt = FAST_STRING	-- reason/explanation for deprecation

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