HsDecls.lhs 23.3 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 @oCnDecl@, @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, tyClDeclSysNames,
18
	isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
19
	mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
20
	getClassDeclSysNames, conDetailsTys
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
import Name		( NamedThing )
39
import FunDeps		( pprFundeps )
40
import Class		( FunDep, DefMeth(..) )
41
import CStrings		( CLabelString, pprCLabelString )
42
import Outputable	
43
import SrcLoc		( SrcLoc )
44 45
\end{code}

46 47 48 49 50 51 52 53

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

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

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

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

92 93 94

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

96 97 98
\end{code}

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

102
    ppr (TyClD dcl)  = ppr dcl
103 104 105
    ppr (ValD binds) = ppr binds
    ppr (DefD def)   = ppr def
    ppr (InstD inst) = ppr inst
sof's avatar
sof committed
106
    ppr (ForD fd)    = ppr fd
107
    ppr (FixD fd)    = ppr fd
108
    ppr (RuleD rd)   = ppr rd
109 110 111
    ppr (DeprecD dd) = ppr dd
\end{code}

112

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

119 120 121 122 123 124 125 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
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

161
\begin{code}
162
data TyClDecl name pat
163 164 165 166 167 168 169 170 171 172 173 174 175
  = IfaceSig {	tcdName :: name,		-- It may seem odd to classify an interface-file signature
		tcdType :: HsType name,		-- as a 'TyClDecl', but it's very convenient.  These three
		tcdIdInfo :: [HsIdInfo name],	-- are the kind that appear in interface files.
		tcdLoc :: SrcLoc
    }

  | TyData {	tcdND     :: NewOrData,
		tcdCtxt   :: HsContext name,	 -- context
		tcdName   :: name,		 -- type constructor
		tcdTyVars :: [HsTyVarBndr name], -- type variables
		tcdCons	  :: [ConDecl name],	 -- data constructors (empty if abstract)
		tcdNCons  :: Int,		 -- Number of data constructors (valid even if type is abstract)
		tcdDerivs :: Maybe [name],	 -- derivings; Nothing => not specified
176 177 178
				 -- (i.e., derive default); Just [] => derive
				 -- *nothing*; Just <list> => as you would
				 -- expect...
179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199
		tcdSysNames :: DataSysNames name,	-- Generic converter functions
		tcdLoc	    :: SrcLoc
    }

  | TySynonym {	tcdName :: name,		        -- type constructor
		tcdTyVars :: [HsTyVarBndr name],	-- type variables
		tcdSynRhs :: HsType name,	        -- synonym expansion
		tcdLoc    :: SrcLoc
    }

  | ClassDecl {	tcdCtxt    :: HsContext name, 	 	-- Context...
		tcdName    :: name,		    	-- Name of the class
		tcdTyVars  :: [HsTyVarBndr name],	-- The class type variables
		tcdFDs     :: [FunDep name],		-- Functional dependencies
		tcdSigs    :: [Sig name],		-- Methods' signatures
		tcdMeths   :: Maybe (MonoBinds name pat),	-- Default methods
								-- Nothing for imported class decls
								-- Just bs for source   class decls
		tcdSysNames :: ClassSysNames name,
		tcdLoc      :: SrcLoc
    }
200 201 202 203 204 205 206
\end{code}

Simple classifiers

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

207 208
isIfaceSigDecl (IfaceSig {}) = True
isIfaceSigDecl other	     = False
209

210 211
isSynDecl (TySynonym {}) = True
isSynDecl other		 = False
212

213 214
isDataDecl (TyData {}) = True
isDataDecl other       = False
215

216 217
isClassDecl (ClassDecl {}) = True
isClassDecl other	   = False
218 219 220
\end{code}

Dealing with names
221

222
\begin{code}
223
--------------------------------
224
tyClDeclName :: TyClDecl name pat -> name
225
tyClDeclName tycl_decl = tcdName tycl_decl
226

227
--------------------------------
228
tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
229
-- Returns all the *binding* names of the decl, along with their SrcLocs
230 231 232 233
-- 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

234 235
tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc})  = [(name,loc)]
tyClDeclNames (IfaceSig  {tcdName = name, tcdLoc = loc})  = [(name,loc)]
236

237
tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
238
  = (cls_name,loc) : [(n,loc) | ClassOpSig n _ _ loc <- sigs]
239

240
tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc})
241
  = (tc_name,loc) : conDeclsNames cons
242 243


244
--------------------------------
245
-- The "system names" are extra implicit names *bound* by the decl.
246 247 248 249 250 251 252 253 254 255 256 257 258 259
-- They are kept in a list rather than a tuple 
-- to make the renamer easier.

type ClassSysNames name = [name]
-- For class decls they are:
-- 	[tycon, datacon wrapper, datacon worker, 
--	 superclass selector 1, ..., superclass selector n]

type DataSysNames name =  [name]
-- For data decls they are
--	[from, to]
-- where from :: T -> Tring
--	 to   :: Tring -> T

260 261 262 263
tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)]
-- Similar to tyClDeclNames, but returns the "implicit" 
-- or "system" names of the declaration

264
tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc, tcdSigs = sigs})
265
  = [(n,loc) | n <- names]
266 267 268 269
tyClDeclSysNames (TyData {tcdCons = cons, tcdSysNames = names, tcdLoc = loc})
  = [(n,loc) | n <- names] ++ 
    [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons]
tyClDeclSysNames decl = []
270

271 272 273 274 275 276 277 278

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}
279
instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
280
	-- Used only when building interface files
281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305
  (==) d1@(IfaceSig {}) d2@(IfaceSig {})
      = tcdName d1 == tcdName d2 && 
	tcdType d1 == tcdType d2 && 
	tcdIdInfo d1 == tcdIdInfo d2

  (==) d1@(TyData {}) d2@(TyData {})
      = tcdName d1 == tcdName d2 && 
	tcdND d1   == tcdND   d2 && 
	eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> 
   	  eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&
	  eqListBy (eq_ConDecl env) (tcdCons d1) (tcdCons d2)
	)

  (==) d1@(TySynonym {}) d2@(TySynonym {})
      = tcdName d1 == tcdName d2 && 
	eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> 
          eq_hsType env (tcdSynRhs d1) (tcdSynRhs d2)
        )

  (==) d1@(ClassDecl {}) d2@(ClassDecl {})
    = tcdName d1 == tcdName d2 && 
      eqWithHsTyVars (tcdTyVars d1) (tcdTyVars d2) (\ env -> 
   	  eq_hsContext env (tcdCtxt d1) (tcdCtxt d2)  &&
	  eqListBy (eq_hsFD env) (tcdFDs d1) (tcdFDs d2) &&
	  eqListBy (eq_cls_sig env) (tcdSigs d1) (tcdSigs d2)
306 307
       )

308 309
  (==) _ _ = False	-- default case

310 311 312
eq_hsFD env (ns1,ms1) (ns2,ms2)
  = eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2

313 314 315
eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _)
  = n1==n2 && dm1 `eq_dm` dm2 && eq_hsType env ty1 ty2
  where
316
	-- Ignore the name of the default method for (DefMeth id)
317 318 319
	-- This is used for comparing declarations before putting
	-- them into interface files, and the name of the default 
	-- method isn't relevant
320 321 322 323
    NoDefMeth  `eq_dm` NoDefMeth  = True
    GenDefMeth `eq_dm` GenDefMeth = True
    DefMeth _  `eq_dm` DefMeth _  = True
    dm1	       `eq_dm` dm2	  = False
324 325

    
326 327 328
\end{code}

\begin{code}
329
countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
330 331
	-- class, data, newtype, synonym decls
countTyClDecls decls 
332 333 334 335 336
 = (length [() | ClassDecl {} <- decls],
    length [() | TySynonym {} <- decls],
    length [() | IfaceSig  {} <- decls],
    length [() | TyData {tcdND = DataType} <- decls],
    length [() | TyData {tcdND = NewType} <- decls])
337 338 339
\end{code}

\begin{code}
340
instance (NamedThing name, Outputable name, Outputable pat)
341
	      => Outputable (TyClDecl name pat) where
342

343 344
    ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info})
	= hsep [ppr var, dcolon, ppr ty, pprHsIdInfo info]
345

346
    ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty})
347
      = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals)
348
	     4 (ppr mono_ty)
349

350 351 352 353
    ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon,
		 tcdTyVars = tyvars, tcdCons = condecls, tcdNCons = ncons,
		 tcdDerivs = derivings})
      = pp_tydecl (ptext keyword <+> pp_decl_head context tycon tyvars <+> equals)
354
		  (pp_condecls condecls ncons)
355
		  derivings
sof's avatar
sof committed
356 357 358 359
      where
	keyword = case new_or_data of
			NewType  -> SLIT("newtype")
			DataType -> SLIT("data")
360

361 362
    ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds,
		    tcdSigs = sigs, tcdMeths = methods})
363 364 365 366 367
      | null sigs	-- No "where" part
      = top_matter

      | otherwise	-- Laid out
      = sep [hsep [top_matter, ptext SLIT("where {")],
368
	     nest 4 (sep [sep (map ppr_sig sigs), pp_methods, char '}'])]
369
      where
370
        top_matter  = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds
371
	ppr_sig sig = ppr sig <> semi
372 373 374 375 376
	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]
377

378 379
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)
380

381
pp_tydecl pp_head pp_decl_rhs derivings
sof's avatar
sof committed
382
  = hang pp_head 4 (sep [
383
	pp_decl_rhs,
384 385 386
	case derivings of
	  Nothing 	   -> empty
	  Just ds	   -> hsep [ptext SLIT("deriving"), parens (interpp'SP ds)]
387
    ])
388 389 390 391 392 393 394 395 396 397 398
\end{code}


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

\begin{code}
data ConDecl name
399 400 401 402 403
  = 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
404

405
		[HsTyVarBndr name]	-- Existentially quantified type variables
406
		(HsContext name)	-- ...and context
407 408
					-- If both are empty then there are no existentials

sof's avatar
sof committed
409
		(ConDetails name)
410 411
		SrcLoc

sof's avatar
sof committed
412 413 414 415 416 417
data ConDetails name
  = VanillaCon			-- prefix-style con decl
		[BangType name]

  | InfixCon			-- infix-style con decl
		(BangType name)
418 419
		(BangType name)

sof's avatar
sof committed
420
  | RecCon			-- record-style con decl
421
		[([name], BangType name)]	-- list of "fields"
422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438
\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
439

440 441 442 443 444 445
	  do_fld1 (flds_seen, acc) fld
		| fld `elem` flds_seen = (flds_seen,acc)
		| otherwise	       = (fld:flds_seen, (fld,loc):acc)
\end{code}

\begin{code}
446 447 448 449 450 451
conDetailsTys :: ConDetails name -> [HsType name]
conDetailsTys (VanillaCon btys)    = map getBangType btys
conDetailsTys (InfixCon bty1 bty2) = [getBangType bty1, getBangType bty2]
conDetailsTys (RecCon fields)	   = [getBangType bty | (_, bty) <- fields]


452 453 454
eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _)
	       (ConDecl n2 _ tvs2 cxt2 cds2 _)
  = n1 == n2 &&
455
    (eq_hsTyVars env tvs1 tvs2	$ \ env ->
456 457 458 459 460 461 462 463 464 465 466 467
     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
468
\end{code}
469
  
470
\begin{code}
471 472 473 474 475 476 477 478 479
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

480 481 482
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
483
eq_btype env _		   _		 = False
484 485 486
\end{code}

\begin{code}
487
instance (Outputable name) => Outputable (ConDecl name) where
488
    ppr (ConDecl con _ tvs cxt con_details  loc)
489
      = sep [pprHsForAll tvs cxt, ppr_con_details con con_details]
490

491 492
ppr_con_details con (InfixCon ty1 ty2)
  = hsep [ppr_bang ty1, ppr con, ppr_bang ty2]
493

494 495
ppr_con_details con (VanillaCon tys)
  = ppr con <+> hsep (map (ppr_bang) tys)
sof's avatar
sof committed
496

497 498
ppr_con_details con (RecCon fields)
  = ppr con <+> braces (hsep (punctuate comma (map ppr_field fields)))
sof's avatar
sof committed
499
  where
500
    ppr_field (ns, ty) = hsep (map (ppr) ns) <+> 
501
			 dcolon <+>
502
			 ppr_bang ty
sof's avatar
sof committed
503

504 505 506
instance Outputable name => Outputable (BangType name) where
    ppr = ppr_bang

507 508
ppr_bang (Banged   ty) = ptext SLIT("!") <> pprParendHsType ty
ppr_bang (Unbanged ty) = pprParendHsType ty
509
ppr_bang (Unpacked ty) = ptext SLIT("! !") <> pprParendHsType ty
510 511 512 513 514
\end{code}


%************************************************************************
%*									*
sof's avatar
sof committed
515
\subsection[InstDecl]{An instance declaration
516 517 518 519
%*									*
%************************************************************************

\begin{code}
520
data InstDecl name pat
521
  = InstDecl	(HsType name)	-- Context => Class Instance-type
522 523 524
				-- Using a polytype means that the renamer conveniently
				-- figures out the quantified type variables for us.

525
		(MonoBinds name pat)
526

527
		[Sig name]		-- User-supplied pragmatic info
528

529 530
		(Maybe name)		-- Name for the dictionary function
					-- Nothing for source-file instance decls
531 532 533 534 535

		SrcLoc
\end{code}

\begin{code}
536
instance (Outputable name, Outputable pat)
537
	      => Outputable (InstDecl name pat) where
538

539
    ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc)
540
      = getPprStyle $ \ sty ->
541
        if ifaceStyle sty then
542
           hsep [ptext SLIT("instance"), ppr inst_ty, equals, pp_dfun]
543 544 545 546
	else
	   vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")],
	         nest 4 (ppr uprags),
	         nest 4 (ppr binds) ]
547 548 549 550
      where
	pp_dfun = case maybe_dfun_name of
		    Just df -> ppr df
		    Nothing -> empty
551 552
\end{code}

553 554 555 556 557 558 559
\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}

560 561 562 563 564 565 566 567 568 569 570 571 572

%************************************************************************
%*									*
\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
573
  = DefaultDecl	[HsType name]
574 575
		SrcLoc

576
instance (Outputable name)
577 578
	      => Outputable (DefaultDecl name) where

579 580
    ppr (DefaultDecl tys src_loc)
      = ptext SLIT("default") <+> parens (interpp'SP tys)
581
\end{code}
582

sof's avatar
sof committed
583 584 585 586 587 588 589 590 591 592
%************************************************************************
%*									*
\subsection{Foreign function interface declaration}
%*									*
%************************************************************************

\begin{code}
data ForeignDecl name = 
   ForeignDecl 
        name 
sof's avatar
sof committed
593
	ForKind   
sof's avatar
sof committed
594 595 596 597 598
	(HsType name)
	ExtName
	CallConv
	SrcLoc

599
instance (Outputable name)
sof's avatar
sof committed
600 601 602 603
	      => Outputable (ForeignDecl name) where

    ppr (ForeignDecl nm imp_exp ty ext_name cconv src_loc)
      = ptext SLIT("foreign") <+> ppr_imp_exp <+> pprCallConv cconv <+> 
604
        ppr ext_name <+> ppr_unsafe <+> ppr nm <+> dcolon <+> ppr ty
sof's avatar
sof committed
605 606 607
        where
         (ppr_imp_exp, ppr_unsafe) =
	   case imp_exp of
sof's avatar
sof committed
608 609 610 611 612 613 614 615 616 617
	     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
618 619 620

data ExtName
 = Dynamic 
621 622 623 624 625 626 627 628 629 630 631 632
 | 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
633 634 635 636 637

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

641 642
%************************************************************************
%*									*
643
\subsection{Transformation rules}
644 645 646 647
%*									*
%************************************************************************

\begin{code}
648
data RuleDecl name pat
649
  = HsRule			-- Source rule
650 651 652 653 654 655 656 657
	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		

658 659 660 661 662 663
  | 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
664 665
	SrcLoc		

666 667 668 669
  | IfaceRuleOut		-- Post typecheck
	name			-- Head of LHS
	CoreRule

670 671
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other		     = True
672

673 674 675 676 677
ifaceRuleDeclName :: RuleDecl name pat -> name
ifaceRuleDeclName (IfaceRule _ _ n _ _ _) = n
ifaceRuleDeclName (IfaceRuleOut n r)	  = n
ifaceRuleDeclName (HsRule fs _ _ _ _ _)   = pprPanic "ifaceRuleDeclName" (ppr fs)

678 679 680
data RuleBndr name
  = RuleBndr name
  | RuleBndrSig name (HsType name)
681

682
instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
683 684 685 686 687 688
  -- 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))

689
instance (NamedThing name, Outputable name, Outputable pat)
690
	      => Outputable (RuleDecl name pat) where
691
  ppr (HsRule name tvs ns lhs rhs loc)
692 693 694
	= sep [text "{-# RULES" <+> doubleQuotes (ptext name),
	       pp_forall, ppr lhs, equals <+> ppr rhs,
               text "#-}" ]
695 696 697 698 699
	where
	  pp_forall | null tvs && null ns = empty
		    | otherwise		  = text "forall" <+> 
					    fsep (map ppr tvs ++ map ppr ns)
					    <> dot
700 701 702 703 704 705 706 707 708

  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
709 710 711 712

instance Outputable name => Outputable (RuleBndr name) where
   ppr (RuleBndr name) = ppr name
   ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty
713 714 715 716 717 718 719 720 721
\end{code}


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

722
We use exported entities for things to deprecate.
723 724

\begin{code}
725
data DeprecDecl name = Deprecation name DeprecTxt SrcLoc
726 727 728 729

type DeprecTxt = FAST_STRING	-- reason/explanation for deprecation

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