IfaceSyn.lhs 37.6 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
4
5
6
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
%

\begin{code}
7
{-# OPTIONS -w #-}
8
9
10
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
11
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12
13
-- for details

14
15
16
module IfaceSyn (
	module IfaceType,		-- Re-export all this

17
	IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..),
18
	IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..),
19
	IfaceBinding(..), IfaceConAlt(..), IfaceIdInfo(..),
20
	IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..),
21

22
	-- Misc
23
        ifaceDeclSubBndrs, visibleIfConDecls,
24

25
	-- Equality
26
	GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy,
27
	eqIfDecl, eqIfInst, eqIfFamInst, eqIfRule, checkBootDecl,
28
29
	
	-- Pretty printing
30
	pprIfaceExpr, pprIfaceDeclHead 
31
32
33
34
35
36
37
    ) where

#include "HsVersions.h"

import CoreSyn
import IfaceType

Simon Marlow's avatar
Simon Marlow committed
38
39
40
import NewDemand
import Class
import UniqFM
41
import NameSet 
Simon Marlow's avatar
Simon Marlow committed
42
43
44
45
import Name
import CostCentre
import Literal
import ForeignCall
46
import BasicTypes
47
48
import Outputable
import FastString
49
import Module
50

Simon Marlow's avatar
Simon Marlow committed
51
52
import Data.List
import Data.Maybe
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

infixl 3 &&&
infix  4 `eqIfExt`, `eqIfIdInfo`, `eqIfType`
\end{code}


%************************************************************************
%*									*
		Data type declarations
%*									*
%************************************************************************

\begin{code}
data IfaceDecl 
  = IfaceId { ifName   :: OccName,
	      ifType   :: IfaceType, 
	      ifIdInfo :: IfaceIdInfo }

71
  | IfaceData { ifName       :: OccName,	-- Type constructor
72
73
74
75
		ifTyVars     :: [IfaceTvBndr],	-- Type variables
		ifCtxt	     :: IfaceContext,	-- The "stupid theta"
		ifCons	     :: IfaceConDecls,	-- Includes new/data info
	        ifRec	     :: RecFlag,	-- Recursive or not?
76
77
78
79
80
81
82
83
84
85
		ifGadtSyntax :: Bool,		-- True <=> declared using
						-- GADT syntax 
		ifGeneric    :: Bool,		-- True <=> generic converter
						--          functions available
    						-- We need this for imported
    						-- data decls, since the
    						-- imported modules may have
    						-- been compiled with
    						-- different flags to the
    						-- current compilation unit 
86
                ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
87
                                                -- Just <=> instance of family
88
89
90
                                                -- Invariant: 
                                                --   ifCons /= IfOpenDataTyCon
                                                --   for family instances
91
    }
92

93
94
95
  | IfaceSyn  {	ifName    :: OccName,		-- Type constructor
		ifTyVars  :: [IfaceTvBndr],	-- Type variables
		ifOpenSyn :: Bool,		-- Is an open family?
96
		ifSynRhs  :: IfaceType,		-- Type for an ordinary
97
98
						-- synonym and kind for an
						-- open family
99
100
101
102
                ifFamInst    :: Maybe (IfaceTyCon, [IfaceType])
                                                -- Just <=> instance of family
                                                -- Invariant: ifOpenSyn == False
                                                --   for family instances
103
104
    }

105
106
107
  | IfaceClass { ifCtxt    :: IfaceContext, 	-- Context...
		 ifName    :: OccName,		-- Name of the class
		 ifTyVars  :: [IfaceTvBndr],	-- Type variables
108
		 ifFDs     :: [FunDep FastString], -- Functional dependencies
109
		 ifATs	   :: [IfaceDecl],	-- Associated type families
110
		 ifSigs    :: [IfaceClassOp],	-- Method signatures
111
	         ifRec	   :: RecFlag		-- Is newtype/datatype associated with the class recursive?
112
113
    }

114
115
  | IfaceForeign { ifName :: OccName,           -- Needs expanding when we move
                                                -- beyond .NET
116
117
118
119
120
121
122
		   ifExtName :: Maybe FastString }

data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType
	-- Nothing    => no default method
	-- Just False => ordinary polymorphic default method
	-- Just True  => generic default method

123
124
data IfaceConDecls
  = IfAbstractTyCon		-- No info
125
  | IfOpenDataTyCon		-- Open data family
126
  | IfDataTyCon [IfaceConDecl]	-- data type decls
127
128
129
  | IfNewTyCon  IfaceConDecl	-- newtype decls

visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl]
130
visibleIfConDecls IfAbstractTyCon  = []
131
visibleIfConDecls IfOpenDataTyCon  = []
132
133
visibleIfConDecls (IfDataTyCon cs) = cs
visibleIfConDecls (IfNewTyCon c)   = [c]
134

135
data IfaceConDecl 
136
  = IfCon {
137
	ifConOcc     :: OccName,   		-- Constructor name
138
	ifConInfix   :: Bool,			-- True <=> declared infix
139
140
141
	ifConUnivTvs :: [IfaceTvBndr],		-- Universal tyvars
	ifConExTvs   :: [IfaceTvBndr],		-- Existential tyvars
	ifConEqSpec  :: [(OccName,IfaceType)],	-- Equality contraints
142
143
	ifConCtxt    :: IfaceContext,		-- Non-stupid context
	ifConArgTys  :: [IfaceType],		-- Arg types
144
	ifConFields  :: [OccName],		-- ...ditto... (field labels)
145
	ifConStricts :: [StrictnessMark]}	-- Empty (meaning all lazy),
146
147
						-- or 1-1 corresp with arg tys

148
data IfaceInst 
149
  = IfaceInst { ifInstCls  :: Name,     		-- See comments with
150
		ifInstTys  :: [Maybe IfaceTyCon],	-- the defn of Instance
151
		ifDFun     :: Name,     		-- The dfun
152
		ifOFlag    :: OverlapFlag,		-- Overlap flag
153
		ifInstOrph :: Maybe OccName }		-- See Note [Orphans]
154
155
156
157
158
159
160
	-- There's always a separate IfaceDecl for the DFun, which gives 
	-- its IdInfo with its full type and version number.
	-- The instance declarations taken together have a version number,
	-- and we don't want that to wobble gratuitously
	-- If this instance decl is *used*, we'll record a usage on the dfun;
	-- and if the head does not change it won't be used if it wasn't before

161
data IfaceFamInst
162
  = IfaceFamInst { ifFamInstFam   :: Name                -- Family tycon
163
164
		 , ifFamInstTys   :: [Maybe IfaceTyCon]  -- Rough match types
		 , ifFamInstTyCon :: IfaceTyCon		 -- Instance decl
165
166
		 }

167
168
169
170
data IfaceRule
  = IfaceRule { 
	ifRuleName   :: RuleName,
	ifActivation :: Activation,
171
	ifRuleBndrs  :: [IfaceBndr],	-- Tyvars and term vars
172
	ifRuleHead   :: Name,   	-- Head of lhs
173
174
175
	ifRuleArgs   :: [IfaceExpr],	-- Args of LHS
	ifRuleRhs    :: IfaceExpr,
	ifRuleOrph   :: Maybe OccName	-- Just like IfaceInst
176
177
178
179
180
    }

data IfaceIdInfo
  = NoInfo			-- When writing interface file without -O
  | HasInfo [IfaceInfoItem]	-- Has info, and here it is
181
182

-- Here's a tricky case:
183
184
--   * Compile with -O module A, and B which imports A.f
--   * Change function f in A, and recompile without -O
185
186
187
188
189
190
--   * When we read in old A.hi we read in its IdInfo (as a thunk)
--	(In earlier GHCs we used to drop IdInfo immediately on reading,
--	 but we do not do that now.  Instead it's discarded when the
--	 ModIface is read into the various decl pools.)
--   * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *)
--	and so gives a new version.
191
192
193
194

data IfaceInfoItem
  = HsArity	 Arity
  | HsStrictness StrictSig
195
196
  | HsInline     Activation
  | HsUnfold	 IfaceExpr
197
  | HsNoCafRefs
198
  | HsWorker	 Name Arity	-- Worker, if any see IdInfo.WorkerInfo
199
200
201
					-- for why we want arity here.
	-- NB: we need IfaceExtName (not just OccName) because the worker
	--     can simplify to a function in another module.
202
203
204
205
206
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id.  Partial reason: some are orphans.

--------------------------------
data IfaceExpr
207
  = IfaceLcl 	FastString
208
  | IfaceExt    Name
209
210
211
212
  | IfaceType   IfaceType
  | IfaceTuple 	Boxity [IfaceExpr]		-- Saturated; type arguments omitted
  | IfaceLam 	IfaceBndr IfaceExpr
  | IfaceApp 	IfaceExpr IfaceExpr
213
  | IfaceCase	IfaceExpr FastString IfaceType [IfaceAlt]
214
215
  | IfaceLet	IfaceBinding  IfaceExpr
  | IfaceNote	IfaceNote IfaceExpr
216
  | IfaceCast   IfaceExpr IfaceCoercion
217
218
  | IfaceLit	Literal
  | IfaceFCall	ForeignCall IfaceType
219
  | IfaceTick   Module Int
220
221
222
223
224

data IfaceNote = IfaceSCC CostCentre
	       | IfaceInlineMe
               | IfaceCoreNote String

225
type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr)
226
	-- Note: FastString, not IfaceBndr (and same with the case binder)
227
228
229
230
	-- We reconstruct the kind/type of the thing from the context
	-- thus saving bulk in interface files

data IfaceConAlt = IfaceDefault
231
 		 | IfaceDataAlt Name
232
233
234
235
		 | IfaceTupleAlt Boxity
		 | IfaceLitAlt Literal

data IfaceBinding
236
237
238
239
240
241
242
  = IfaceNonRec	IfaceLetBndr IfaceExpr
  | IfaceRec 	[(IfaceLetBndr, IfaceExpr)]

-- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too
-- It's used for *non-top-level* let/rec binders
-- See Note [IdInfo on nested let-bindings]
data IfaceLetBndr = IfLetBndr FastString IfaceType IfaceIdInfo
243
244
\end{code}

245
246
247
248
249
250
251
252
253
254
255
256
Note [IdInfo on nested let-bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Occasionally we want to preserve IdInfo on nested let bindings The one
that came up was a NOINLINE pragma on a let-binding inside an INLINE
function.  The user (Duncan Coutts) really wanted the NOINLINE control
to cross the separate compilation boundary.

So a IfaceLetBndr keeps a trimmed-down list of IfaceIdInfo stuff.
Currently we only actually retain InlinePragInfo, but in principle we could
add strictness etc.


257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
Note [Orphans]: the ifInstOrph and ifRuleOrph fields
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
If a module contains any "orphans", then its interface file is read
regardless, so that its instances are not missed.

Roughly speaking, an instance is an orphan if its head (after the =>)
mentions nothing defined in this module.  Functional dependencies
complicate the situation though. Consider

  module M where { class C a b | a -> b }

and suppose we are compiling module X:

  module X where
	import M
	data T = ...
	instance C Int T where ...

This instance is an orphan, because when compiling a third module Y we
might get a constraint (C Int v), and we'd want to improve v to T.  So
we must make sure X's instances are loaded, even if we do not directly
use anything from X.

More precisely, an instance is an orphan iff

  If there are no fundeps, then at least of the names in
  the instance head is locally defined.

  If there are fundeps, then for every fundep, at least one of the
  names free in a *non-determined* part of the instance head is
  defined in this module.  

(Note that these conditions hold trivially if the class is locally
defined.)
291

292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
Note [Versioning of instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Now consider versioning.  If we *use* an instance decl in one compilation,
we'll depend on the dfun id for that instance, so we'll recompile if it changes.
But suppose we *don't* (currently) use an instance!  We must recompile if
the instance is changed in such a way that it becomes important.  (This would
only matter with overlapping instances, else the importing module wouldn't have
compiled before and the recompilation check is irrelevant.)

The is_orph field is set to (Just n) if the instance is not an orphan.
The 'n' is *any* of the locally-defined names mentioned anywhere in the
instance head.  This name is used for versioning; the instance decl is
considered part of the defn of this 'n'.

I'm worried about whether this works right if we pick a name from
a functionally-dependent part of the instance decl.  E.g.

  module M where { class C a b | a -> b }

and suppose we are compiling module X:

  module X where
	import M
	data S  = ...
	data T = ...
	instance C S T where ...

If we base the instance verion on T, I'm worried that changing S to S'
would change T's version, but not S or S'.  But an importing module might
not depend on T, and so might not be recompiled even though the new instance
(C S' T) might be relevant.  I have not been able to make a concrete example,
and it seems deeply obscure, so I'm going to leave it for now.


Note [Versioning of rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~
A rule that is not an orphan has an ifRuleOrph field of (Just n), where
n appears on the LHS of the rule; any change in the rule changes the version of n.


\begin{code}
333
334
335
336
337
338
339
340
-- -----------------------------------------------------------------------------
-- Utils on IfaceSyn

ifaceDeclSubBndrs :: IfaceDecl -> [OccName]
--  *Excludes* the 'main' name, but *includes* the implicitly-bound names
-- Deeply revolting, because it has to predict what gets bound,
-- especially the question of whether there's a wrapper for a datacon

341
342
343
344
345
346
-- N.B. the set of names returned here *must* match the set of
-- TyThings returned by HscTypes.implicitTyThings, in the sense that
-- TyThing.getOccName should define a bijection between the two lists.
-- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop])
-- The order of the list does not matter.
ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon}  = []
347
348
349

-- Newtype
ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
350
351
352
353
354
355
356
357
358
359
360
361
                              ifCons = IfNewTyCon (
                                        IfCon { ifConOcc = con_occ, 
                                                ifConFields = fields
					          }),
                              ifFamInst = famInst}) 
  = -- fields (names of selectors)
    fields ++ 
    -- implicit coerion and (possibly) family instance coercion
    (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++
    -- data constructor and worker (newtypes don't have a wrapper)
    [con_occ, mkDataConWorkerOcc con_occ]

362
363
364
365

ifaceDeclSubBndrs (IfaceData {ifName = tc_occ,
			      ifCons = IfDataTyCon cons, 
			      ifFamInst = famInst})
366
367
368
369
  = -- fields (names of selectors) 
    nub (concatMap ifConFields cons) 	-- Eliminate duplicate fields
    -- (possibly) family instance coercion;
    -- there is no implicit coercion for non-newtypes
370
    ++ famInstCo famInst tc_occ
371
372
373
    -- for each data constructor in order,
    --    data constructor, worker, and (possibly) wrapper
    ++ concatMap dc_occs cons
374
375
376
377
378
  where
    dc_occs con_decl
	| has_wrapper = [con_occ, work_occ, wrap_occ]
	| otherwise   = [con_occ, work_occ]
	where
379
380
381
382
	  con_occ  = ifConOcc con_decl			-- DataCon namespace
	  wrap_occ = mkDataConWrapperOcc con_occ	-- Id namespace
	  work_occ = mkDataConWorkerOcc con_occ		-- Id namespace
	  strs     = ifConStricts con_decl
383
384
385
386
387
	  has_wrapper = any isMarkedStrict strs	-- See MkId.mkDataConIds (sigh)
			|| not (null . ifConEqSpec $ con_decl)
			|| isJust famInst
		-- ToDo: may miss strictness in existential dicts

388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, 
			       ifSigs = sigs, ifATs = ats })
  = -- dictionary datatype:
    --   type constructor
    tc_occ : 
    --   (possibly) newtype coercion
    co_occs ++
    --    data constructor (DataCon namespace)
    --    data worker (Id namespace)
    --    no wrapper (class dictionaries never have a wrapper)
    [dc_occ, dcww_occ] ++
    -- associated types
    [ifName at | at <- ats ] ++
    -- superclass selectors
    [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] ++
    -- operation selectors
    [op | IfaceClassOp op  _ _ <- sigs]
  where
    n_ctxt = length sc_ctxt
    n_sigs = length sigs
    tc_occ  = mkClassTyConOcc cls_occ
    dc_occ  = mkClassDataConOcc cls_occ	
    co_occs | is_newtype = [mkNewTyCoOcc tc_occ]
	    | otherwise  = []
    dcww_occ = mkDataConWorkerOcc dc_occ
    is_newtype = n_sigs + n_ctxt == 1			-- Sigh 

415
416
417
418
419
ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ,
			     ifFamInst = famInst})
  = famInstCo famInst tc_occ

ifaceDeclSubBndrs _ = []
420
421
422
423
424
425

-- coercion for data/newtype family instances
famInstCo Nothing  baseOcc = []
famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc]

----------------------------- Printing IfaceDecl ------------------------------
426
427
428
429
430
431
432
433
434
435
436

instance Outputable IfaceDecl where
  ppr = pprIfaceDecl

pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdInfo = info})
  = sep [ ppr var <+> dcolon <+> ppr ty, 
	  nest 2 (ppr info) ]

pprIfaceDecl (IfaceForeign {ifName = tycon})
  = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon]

437
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
438
439
		        ifOpenSyn = False, ifSynRhs = mono_ty, 
                        ifFamInst = mbFamInst})
440
  = hang (ptext SLIT("type") <+> pprIfaceDeclHead [] tycon tyvars)
441
       4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst])
442

443
444
445
446
447
pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, 
		        ifOpenSyn = True, ifSynRhs = mono_ty})
  = hang (ptext SLIT("type family") <+> pprIfaceDeclHead [] tycon tyvars)
       4 (dcolon <+> ppr mono_ty)

448
pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context,
449
			 ifTyVars = tyvars, ifCons = condecls, 
450
			 ifRec = isrec, ifFamInst = mbFamInst})
451
  = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars)
452
453
       4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls,
	        pprFamily mbFamInst])
454
  where
455
456
    pp_nd = case condecls of
		IfAbstractTyCon -> ptext SLIT("data")
457
		IfOpenDataTyCon -> ptext SLIT("data family")
458
459
		IfDataTyCon _   -> ptext SLIT("data")
		IfNewTyCon _  	-> ptext SLIT("newtype")
460
461

pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, 
462
463
			  ifFDs = fds, ifATs = ats, ifSigs = sigs, 
			  ifRec = isrec})
464
  = hang (ptext SLIT("class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds)
465
       4 (vcat [pprRec isrec,
466
467
	        sep (map ppr ats),
		sep (map ppr sigs)])
468
469

pprRec isrec = ptext SLIT("RecFlag") <+> ppr isrec
470
471
pprGen True  = ptext SLIT("Generics: yes")
pprGen False = ptext SLIT("Generics: no")
472

473
474
pprFamily Nothing        = ptext SLIT("FamilyInstance: none")
pprFamily (Just famInst) = ptext SLIT("FamilyInstance:") <+> ppr famInst
475

476
477
478
instance Outputable IfaceClassOp where
   ppr (IfaceClassOp n dm ty) = ppr n <+> ppr dm <+> dcolon <+> ppr ty

479
pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc
480
481
482
pprIfaceDeclHead context thing tyvars
  = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), 
	  pprIfaceTvBndrs tyvars]
483

484
485
pp_condecls tc IfAbstractTyCon  = ptext SLIT("{- abstract -}")
pp_condecls tc (IfNewTyCon c)   = equals <+> pprIfaceConDecl tc c
486
pp_condecls tc IfOpenDataTyCon  = empty
487
pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |"))
488
489
							     (map (pprIfaceConDecl tc) cs))

490
pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc
491
492
493
494
495
496
497
498
pprIfaceConDecl tc
	(IfCon { ifConOcc = name, ifConInfix = is_infix, 
		 ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, 
		 ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, 
		 ifConStricts = strs, ifConFields = fields })
  = sep [main_payload,
	 if is_infix then ptext SLIT("Infix") else empty,
	 if null strs then empty 
499
	      else nest 4 (ptext SLIT("Stricts:") <+> hsep (map ppr strs)),
500
	 if null fields then empty
501
	      else nest 4 (ptext SLIT("Fields:") <+> hsep (map ppr fields))]
502
503
  where
    main_payload = ppr name <+> dcolon <+> 
504
		   pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau
505

506
507
    eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) 
	      | (tv,ty) <- eq_spec] 
508
509
510
511
512
513
514
515

	-- A bit gruesome this, but we can't form the full con_tau, and ppr it,
	-- because we don't have a Name for the tycon, only an OccName
    pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of
		(t:ts) -> fsep (t : map (arrow <+>) ts)
		[]     -> panic "pp_con_taus"

    pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs]
516

517
instance Outputable IfaceRule where
518
519
  ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
		   ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) 
520
521
522
523
524
525
526
    = sep [hsep [doubleQuotes (ftext name), ppr act,
		 ptext SLIT("forall") <+> pprIfaceBndrs bndrs],
	   nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args),
		        ptext SLIT("=") <+> ppr rhs])
      ]

instance Outputable IfaceInst where
527
528
529
  ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, 
		  ifInstCls = cls, ifInstTys = mb_tcs})
    = hang (ptext SLIT("instance") <+> ppr flag 
530
		<+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs))
531
         2 (equals <+> ppr dfun_id)
532
533

instance Outputable IfaceFamInst where
534
535
536
537
538
539
540
541
542
  ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs,
		     ifFamInstTyCon = tycon_id})
    = hang (ptext SLIT("family instance") <+> 
	    ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs))
         2 (equals <+> ppr tycon_id)

ppr_rough :: Maybe IfaceTyCon -> SDoc
ppr_rough Nothing   = dot
ppr_rough (Just tc) = ppr tc
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
\end{code}


----------------------------- Printing IfaceExpr ------------------------------------

\begin{code}
instance Outputable IfaceExpr where
    ppr e = pprIfaceExpr noParens e

pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
	-- The function adds parens in context that need
	-- an atomic value (e.g. function args)

pprIfaceExpr add_par (IfaceLcl v)       = ppr v
pprIfaceExpr add_par (IfaceExt v)       = ppr v
pprIfaceExpr add_par (IfaceLit l)       = ppr l
pprIfaceExpr add_par (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
560
pprIfaceExpr add_par (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
561
562
563
564
565
566
567
568
569
570
571
572
573
pprIfaceExpr add_par (IfaceType ty)     = char '@' <+> pprParendIfaceType ty

pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
pprIfaceExpr add_par (IfaceTuple c as)  = tupleParens c (interpp'SP as)

pprIfaceExpr add_par e@(IfaceLam _ _)   
  = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow,
		  pprIfaceExpr noParens body])
  where 
    (bndrs,body) = collect [] e
    collect bs (IfaceLam b e) = collect (b:bs) e
    collect bs e              = (reverse bs, e)

574
pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
575
576
  = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
			<+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") 
577
578
579
			<+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
  		  pprIfaceExpr noParens rhs <+> char '}'])

580
pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
581
582
  = add_par (sep [ptext SLIT("case") <+> char '@' <+> pprParendIfaceType ty
		 	<+> pprIfaceExpr noParens scrut <+> ptext SLIT("of") 
583
584
585
			<+> ppr bndr <+> char '{',
  		  nest 2 (sep (map ppr_alt alts)) <+> char '}'])

586
587
588
589
pprIfaceExpr add_par (IfaceCast expr co)
  = sep [pprIfaceExpr parens expr,
	 nest 2 (ptext SLIT("`cast`")),
	 pprParendIfaceType co]
590

591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body)
  = add_par (sep [ptext SLIT("let {"), 
		  nest 2 (ppr_bind (b, rhs)),
		  ptext SLIT("} in"), 
		  pprIfaceExpr noParens body])

pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body)
  = add_par (sep [ptext SLIT("letrec {"),
		  nest 2 (sep (map ppr_bind pairs)), 
		  ptext SLIT("} in"),
		  pprIfaceExpr noParens body])

pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprIfaceExpr parens body)

ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, 
			      arrow <+> pprIfaceExpr noParens rhs]

ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
ppr_con_bs con bs		      = ppr con <+> hsep (map ppr bs)
  
611
612
613
ppr_bind (IfLetBndr b ty info, rhs) 
  = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info),
	 equals <+> pprIfaceExpr noParens rhs]
614
615
616
617
618
619
620
621
622
623

------------------
pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprIfaceExpr parens arg) : args)
pprIfaceApp fun	 	       args = sep (pprIfaceExpr parens fun : args)

------------------
instance Outputable IfaceNote where
    ppr (IfaceSCC cc)     = pprCostCentreCore cc
    ppr IfaceInlineMe     = ptext SLIT("__inline_me")
    ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s)
andy@galois.com's avatar
andy@galois.com committed
624

625
626

instance Outputable IfaceConAlt where
627
628
629
630
    ppr IfaceDefault	  = text "DEFAULT"
    ppr (IfaceLitAlt l)   = ppr l
    ppr (IfaceDataAlt d)  = ppr d
    ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt" 
631
632
633
634
	-- IfaceTupleAlt is handled by the case-alternative printer

------------------
instance Outputable IfaceIdInfo where
635
636
  ppr NoInfo       = empty
  ppr (HasInfo is) = ptext SLIT("{-") <+> fsep (map ppr is) <+> ptext SLIT("-}")
637

638
639
instance Outputable IfaceInfoItem where
  ppr (HsUnfold unf)  	 = ptext SLIT("Unfolding:") <+>
640
				  	parens (pprIfaceExpr noParens unf)
641
642
643
644
645
  ppr (HsInline act)     = ptext SLIT("Inline:") <+> ppr act
  ppr (HsArity arity)    = ptext SLIT("Arity:") <+> int arity
  ppr (HsStrictness str) = ptext SLIT("Strictness:") <+> pprIfaceStrictSig str
  ppr HsNoCafRefs	 = ptext SLIT("HasNoCafRefs")
  ppr (HsWorker w a)	 = ptext SLIT("Worker:") <+> ppr w <+> int a
646
647
648
649
650
651
652
653
654
\end{code}


%************************************************************************
%*									*
	Equality, for interface file version generaion only
%*									*
%************************************************************************

655
656
657
658
Equality over IfaceSyn returns an IfaceEq, not a Bool.  The new
constructor is EqBut, which gives the set of things whose version must
be equal for the whole thing to be equal.  So the key function is
eqIfExt, which compares Names.
659
660
661
662

Of course, equality is also done modulo alpha conversion.

\begin{code}
663
data GenIfaceEq a
664
665
  = Equal 		-- Definitely exactly the same
  | NotEqual		-- Definitely different
666
667
668
  | EqBut a       -- The same provided these Names have not changed

type IfaceEq = GenIfaceEq NameSet
669

670
671
672
instance Outputable IfaceEq where
  ppr Equal          = ptext SLIT("Equal")
  ppr NotEqual       = ptext SLIT("NotEqual")
673
  ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset)
674

675
676
677
678
bool :: Bool -> IfaceEq
bool True  = Equal
bool False = NotEqual

679
680
681
682
683
toBool :: IfaceEq -> Bool
toBool Equal     = True
toBool (EqBut _) = True
toBool NotEqual  = False

684
685
686
687
688
689
690
zapEq :: IfaceEq -> IfaceEq	-- Used to forget EqBut information
zapEq (EqBut _) = Equal
zapEq other	= other

(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
Equal       &&& x 	    = x
NotEqual    &&& x	    = NotEqual
691
692
693
EqBut nms   &&& Equal       = EqBut nms
EqBut nms   &&& NotEqual    = NotEqual
EqBut nms1  &&& EqBut nms2  = EqBut (nms1 `unionNameSets` nms2)
694
695

-- This function is the core of the EqBut stuff
696
697
698
699
700
701
-- ASSUMPTION: The left-hand argument is the NEW CODE, and hence
-- any Names in the left-hand arg have the correct parent in them.
eqIfExt :: Name -> Name -> IfaceEq
eqIfExt name1 name2 
  | name1 == name2 = EqBut (unitNameSet name1)
  | otherwise      = NotEqual
702

703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
---------------------
checkBootDecl :: IfaceDecl 	-- The boot decl
	      -> IfaceDecl	-- The real decl
	      -> Bool		-- True <=> compatible
checkBootDecl (IfaceId s1 t1 _) (IfaceId s2 t2 _)
  = ASSERT( s1==s2 ) toBool (t1 `eqIfType` t2)

checkBootDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
  = ASSERT (ifName d1 == ifName d2 ) ifExtName d1 == ifExtName d2

checkBootDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
  = ASSERT( ifName d1 == ifName d2 )
    toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> 
          eq_ifType env (ifSynRhs d1) (ifSynRhs d2)

checkBootDecl d1@(IfaceData {}) d2@(IfaceData {})
-- We don't check the recursion flags because the boot-one is
-- recursive, to be conservative, but the real one may not be.
-- I'm not happy with the way recursive flags are dealt with.
  = ASSERT( ifName d1    == ifName d2 ) 
    toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> 
	eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& 
	case ifCons d1 of
	    IfAbstractTyCon -> Equal
	    cons1	    -> eq_hsCD env cons1 (ifCons d2)

checkBootDecl d1@(IfaceClass {}) d2@(IfaceClass {})
  = ASSERT( ifName d1 == ifName d2 )
    toBool $ eqWith (ifTyVars d1) (ifTyVars d2) $ \ env -> 
	  eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
	  case (ifCtxt d1, ifSigs d1) of
	     ([], [])      -> Equal
	     (cxt1, sigs1) -> eq_ifContext env cxt1 (ifCtxt d2)  &&&
			      eqListBy (eq_cls_sig env) sigs1 (ifSigs d2)

checkBootDecl _ _ = False	-- default case

740
741
742
743
744
745
746
747
748
749
750
---------------------
eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
  = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)

eqIfDecl d1@(IfaceForeign {}) d2@(IfaceForeign {})
  = bool (ifName d1 == ifName d2 && ifExtName d1 == ifExtName d2)

eqIfDecl d1@(IfaceData {}) d2@(IfaceData {})
  = bool (ifName d1    == ifName d2 && 
	  ifRec d1     == ifRec   d2 && 
751
	  ifGadtSyntax d1 == ifGadtSyntax   d2 && 
752
	  ifGeneric d1 == ifGeneric d2) &&&
753
    ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
754
    eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> 
755
756
	    eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& 
    	    eq_hsCD env (ifCons d1) (ifCons d2) 
757
	)
758
759
760
	-- The type variables of the data type do not scope
	-- over the constructors (any more), but they do scope
	-- over the stupid context in the IfaceConDecls
761
762
763

eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
  = bool (ifName d1 == ifName d2) &&&
764
    ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
765
766
767
768
769
770
    eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> 
          eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
        )

eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
  = bool (ifName d1 == ifName d2 && 
771
	  ifRec d1  == ifRec  d2) &&&
772
773
774
    eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> 
   	  eq_ifContext env (ifCtxt d1) (ifCtxt d2)  &&&
	  eqListBy (eq_hsFD env)    (ifFDs d1)  (ifFDs d2) &&&
775
	  eqListBy eqIfDecl         (ifATs d1)  (ifATs d2) &&&
776
777
778
779
780
781
782
783
784
	  eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
       )

eqIfDecl _ _ = NotEqual	-- default case

-- Helper
eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
eqWith = eq_ifTvBndrs emptyEqEnv

785
786
787
788
789
790
791
792
793
eqIfTc_fam :: Maybe (IfaceTyCon, [IfaceType]) 
           -> Maybe (IfaceTyCon, [IfaceType])
           -> IfaceEq
Nothing             `eqIfTc_fam` Nothing             = Equal
(Just (fam1, tys1)) `eqIfTc_fam` (Just (fam2, tys2)) = 
  fam1 `eqIfTc` fam2 &&& eqListBy eqIfType tys1 tys2
_		        `eqIfTc_fam` _               = NotEqual


794
-----------------------
795
eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
796
-- All other changes are handled via the version info on the dfun
797

798
799
800
eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
-- All other changes are handled via the version info on the tycon

801
802
803
eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1)
	 (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2)
       = bool (n1==n2 && a1==a2 && o1 == o2) &&&
804
805
806
807
808
809
	 f1 `eqIfExt` f2 &&&
         eq_ifBndrs emptyEqEnv bs1 bs2 (\env -> 
	 zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&&
		-- zapEq: for the LHSs, ignore the EqBut part
         eq_ifaceExpr env rhs1 rhs2)

810
811
eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) 
  = eqListBy (eq_ConDecl env) c1 c2
812

813
814
eq_hsCD env (IfNewTyCon c1)  (IfNewTyCon c2)  = eq_ConDecl env c1 c2
eq_hsCD env IfAbstractTyCon  IfAbstractTyCon  = Equal
815
eq_hsCD env IfOpenDataTyCon  IfOpenDataTyCon  = Equal
816
eq_hsCD env d1		     d2		      = NotEqual
817

818
eq_ConDecl env c1 c2
819
820
821
822
  = bool (ifConOcc c1     == ifConOcc c2 && 
	  ifConInfix c1   == ifConInfix c2 && 
	  ifConStricts c1 == ifConStricts c2 && 
	  ifConFields c1  == ifConFields c2) &&&
823
824
    eq_ifTvBndrs env (ifConUnivTvs c1) (ifConUnivTvs c2) (\ env ->
    eq_ifTvBndrs env (ifConExTvs c1) (ifConExTvs c2) (\ env ->
825
	eq_ifContext env (ifConCtxt c1) (ifConCtxt c2) &&&
826
	eq_ifTypes env (ifConArgTys c1) (ifConArgTys c2)))
827
828
829
830
831
832
833
834
835
836
837
838
839

eq_hsFD env (ns1,ms1) (ns2,ms2)
  = eqListBy (eqIfOcc env) ns1 ns2 &&& eqListBy (eqIfOcc env) ms1 ms2

eq_cls_sig env (IfaceClassOp n1 dm1 ty1) (IfaceClassOp n2 dm2 ty2)
  = bool (n1==n2 && dm1 == dm2) &&& eq_ifType env ty1 ty2
\end{code}


\begin{code}
-----------------
eqIfIdInfo NoInfo	 NoInfo	       = Equal
eqIfIdInfo (HasInfo is1) (HasInfo is2) = eqListBy eq_item is1 is2
840
eqIfIdInfo i1 		 i2 = NotEqual
841

842
eq_item (HsInline a1)	   (HsInline a2)      = bool (a1 == a2)
843
844
eq_item (HsArity a1)	   (HsArity a2)	      = bool (a1 == a2)
eq_item (HsStrictness s1)  (HsStrictness s2)  = bool (s1 == s2)
845
eq_item (HsUnfold u1)   (HsUnfold u2)         = eq_ifaceExpr emptyEqEnv u1 u2
846
eq_item HsNoCafRefs        HsNoCafRefs	      = Equal
847
eq_item (HsWorker wkr1 a1) (HsWorker wkr2 a2) = bool (a1==a2) &&& (wkr1 `eqIfExt` wkr2)
848
849
850
851
852
853
854
855
eq_item _ _ = NotEqual

-----------------
eq_ifaceExpr :: EqEnv -> IfaceExpr -> IfaceExpr -> IfaceEq
eq_ifaceExpr env (IfaceLcl v1)	      (IfaceLcl v2)	   = eqIfOcc env v1 v2
eq_ifaceExpr env (IfaceExt v1)	      (IfaceExt v2)	   = eqIfExt v1 v2
eq_ifaceExpr env (IfaceLit l1)        (IfaceLit l2) 	   = bool (l1 == l2)
eq_ifaceExpr env (IfaceFCall c1 ty1)  (IfaceFCall c2 ty2)  = bool (c1==c2) &&& eq_ifType env ty1 ty2
856
eq_ifaceExpr env (IfaceTick m1 ix1)   (IfaceTick m2 ix2)   = bool (m1==m2) &&& bool (ix1 == ix2)
857
858
859
860
eq_ifaceExpr env (IfaceType ty1)      (IfaceType ty2)	   = eq_ifType env ty1 ty2
eq_ifaceExpr env (IfaceTuple n1 as1)  (IfaceTuple n2 as2)  = bool (n1==n2) &&& eqListBy (eq_ifaceExpr env) as1 as2
eq_ifaceExpr env (IfaceLam b1 body1)  (IfaceLam b2 body2)  = eq_ifBndr env b1 b2 (\env -> eq_ifaceExpr env body1 body2)
eq_ifaceExpr env (IfaceApp f1 a1)     (IfaceApp f2 a2)	   = eq_ifaceExpr env f1 f2 &&& eq_ifaceExpr env a1 a2
861
eq_ifaceExpr env (IfaceCast e1 co1)   (IfaceCast e2 co2)   = eq_ifaceExpr env e1 e2 &&& eq_ifType env co1 co2
862
863
eq_ifaceExpr env (IfaceNote n1 r1)    (IfaceNote n2 r2)    = eq_ifaceNote env n1 n2 &&& eq_ifaceExpr env r1 r2

864
eq_ifaceExpr env (IfaceCase s1 b1 ty1 as1) (IfaceCase s2 b2 ty2 as2)
865
  = eq_ifaceExpr env s1 s2 &&&
866
    eq_ifType env ty1 ty2 &&&
867
868
869
870
871
872
873
    eq_ifNakedBndr env b1 b2 (\env -> eqListBy (eq_ifaceAlt env) as1 as2)
  where
    eq_ifaceAlt env (c1,bs1,r1) (c2,bs2,r2)
	= bool (eq_ifaceConAlt c1 c2) &&& 
	  eq_ifNakedBndrs env bs1 bs2 (\env -> eq_ifaceExpr env r1 r2)

eq_ifaceExpr env (IfaceLet (IfaceNonRec b1 r1) x1) (IfaceLet (IfaceNonRec b2 r2) x2)
874
  = eq_ifaceExpr env r1 r2 &&& eq_ifLetBndr env b1 b2 (\env -> eq_ifaceExpr env x1 x2)
875
876

eq_ifaceExpr env (IfaceLet (IfaceRec as1) x1) (IfaceLet (IfaceRec as2) x2)
877
  = eq_ifLetBndrs env bs1 bs2 (\env -> eqListBy (eq_ifaceExpr env) rs1 rs2 &&& eq_ifaceExpr env x1 x2)
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
  where
    (bs1,rs1) = unzip as1
    (bs2,rs2) = unzip as2


eq_ifaceExpr env _ _ = NotEqual

-----------------
eq_ifaceConAlt :: IfaceConAlt -> IfaceConAlt -> Bool
eq_ifaceConAlt IfaceDefault	  IfaceDefault		= True
eq_ifaceConAlt (IfaceDataAlt n1)  (IfaceDataAlt n2)	= n1==n2
eq_ifaceConAlt (IfaceTupleAlt c1) (IfaceTupleAlt c2)	= c1==c2
eq_ifaceConAlt (IfaceLitAlt l1)	  (IfaceLitAlt l2)	= l1==l2
eq_ifaceConAlt _ _ = False

-----------------
eq_ifaceNote :: EqEnv -> IfaceNote -> IfaceNote -> IfaceEq
eq_ifaceNote env (IfaceSCC c1)    (IfaceSCC c2)        = bool (c1==c2)
eq_ifaceNote env IfaceInlineMe    IfaceInlineMe        = Equal
eq_ifaceNote env (IfaceCoreNote s1) (IfaceCoreNote s2) = bool (s1==s2)
eq_ifaceNote env _ _ = NotEqual
\end{code}

\begin{code}
---------------------
eqIfType t1 t2 = eq_ifType emptyEqEnv t1 t2

-------------------
eq_ifType env (IfaceTyVar n1)         (IfaceTyVar n2)         = eqIfOcc env n1 n2
eq_ifType env (IfaceAppTy s1 t1)      (IfaceAppTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
eq_ifType env (IfacePredTy st1)       (IfacePredTy st2)       = eq_ifPredType env st1 st2
eq_ifType env (IfaceTyConApp tc1 ts1) (IfaceTyConApp tc2 ts2) = tc1 `eqIfTc` tc2 &&& eq_ifTypes env ts1 ts2
eq_ifType env (IfaceForAllTy tv1 t1)  (IfaceForAllTy tv2 t2)  = eq_ifTvBndr env tv1 tv2 (\env -> eq_ifType env t1 t2)
eq_ifType env (IfaceFunTy s1 t1)      (IfaceFunTy s2 t2)      = eq_ifType env s1 s2 &&& eq_ifType env t1 t2
eq_ifType env _ _ = NotEqual

-------------------
eq_ifTypes env = eqListBy (eq_ifType env)

-------------------
eq_ifContext env a b = eqListBy (eq_ifPredType env) a b

-------------------
eq_ifPredType env (IfaceClassP c1 tys1) (IfaceClassP c2 tys2) = c1 `eqIfExt` c2 &&&  eq_ifTypes env tys1 tys2
eq_ifPredType env (IfaceIParam n1 ty1) (IfaceIParam n2 ty2)   = bool (n1 == n2) &&& eq_ifType env ty1 ty2
eq_ifPredType env _ _ = NotEqual

-------------------
eqIfTc (IfaceTc tc1) (IfaceTc tc2) = tc1 `eqIfExt` tc2
eqIfTc IfaceIntTc    IfaceIntTc	   = Equal
eqIfTc IfaceCharTc   IfaceCharTc   = Equal
eqIfTc IfaceBoolTc   IfaceBoolTc   = Equal
eqIfTc IfaceListTc   IfaceListTc   = Equal
eqIfTc IfacePArrTc   IfacePArrTc   = Equal
eqIfTc (IfaceTupTc bx1 ar1) (IfaceTupTc bx2 ar2) = bool (bx1==bx2 && ar1==ar2)
933
934
935
936
937
938
eqIfTc IfaceLiftedTypeKindTc   IfaceLiftedTypeKindTc   = Equal
eqIfTc IfaceOpenTypeKindTc     IfaceOpenTypeKindTc     = Equal
eqIfTc IfaceUnliftedTypeKindTc IfaceUnliftedTypeKindTc = Equal
eqIfTc IfaceUbxTupleKindTc     IfaceUbxTupleKindTc     = Equal
eqIfTc IfaceArgTypeKindTc      IfaceArgTypeKindTc      = Equal
eqIfTc _		       _		       = NotEqual
939
940
941
942
943
944
945
946
\end{code}

-----------------------------------------------------------
	Support code for equality checking
-----------------------------------------------------------

\begin{code}
------------------------------------
947
type EqEnv = UniqFM FastString	-- Tracks the mapping from L-variables to R-variables
948

949
950
eqIfOcc :: EqEnv -> FastString -> FastString -> IfaceEq
eqIfOcc env n1 n2 = case lookupUFM env n1 of
951
			Just n1 -> bool (n1 == n2)
952
			Nothing -> bool (n1 == n2)
953

954
extendEqEnv :: EqEnv -> FastString -> FastString -> EqEnv
955
extendEqEnv env n1 n2 | n1 == n2  = env
956
		      | otherwise = addToUFM env n1 n2
957
958

emptyEqEnv :: EqEnv
959
emptyEqEnv = emptyUFM
960
961
962
963

------------------------------------
type ExtEnv bndr = EqEnv -> bndr -> bndr -> (EqEnv -> IfaceEq) -> IfaceEq

964
eq_ifNakedBndr :: ExtEnv FastString
965
966
967
968
969
970
971
972
973
974
eq_ifBndr      :: ExtEnv IfaceBndr
eq_ifTvBndr    :: ExtEnv IfaceTvBndr
eq_ifIdBndr    :: ExtEnv IfaceIdBndr

eq_ifNakedBndr env n1 n2 k = k (extendEqEnv env n1 n2)

eq_ifBndr env (IfaceIdBndr b1) (IfaceIdBndr b2) k = eq_ifIdBndr env b1 b2 k
eq_ifBndr env (IfaceTvBndr b1) (IfaceTvBndr b2) k = eq_ifTvBndr env b1 b2 k
eq_ifBndr _ _ _ _ = NotEqual

975
eq_ifTvBndr env (v1, k1) (v2, k2) k = eq_ifType env k1 k2 &&& k (extendEqEnv env v1 v2)
976
977
eq_ifIdBndr env (v1, t1) (v2, t2) k = eq_ifType env t1 t2 &&& k (extendEqEnv env v1 v2)

978
979
980
eq_ifLetBndr env (IfLetBndr v1 t1 i1) (IfLetBndr v2 t2 i2) k 
  = eq_ifType env t1 t2 &&& eqIfIdInfo i1 i2 &&& k (extendEqEnv env v1 v2)

981
eq_ifBndrs   	:: ExtEnv [IfaceBndr]
982
eq_ifLetBndrs 	:: ExtEnv [IfaceLetBndr]
983
eq_ifTvBndrs 	:: ExtEnv [IfaceTvBndr]
984
eq_ifNakedBndrs :: ExtEnv [FastString]
985
986
987
eq_ifBndrs   	= eq_bndrs_with eq_ifBndr
eq_ifTvBndrs 	= eq_bndrs_with eq_ifTvBndr
eq_ifNakedBndrs = eq_bndrs_with eq_ifNakedBndr
988
eq_ifLetBndrs   = eq_bndrs_with eq_ifLetBndr
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005

eq_bndrs_with eq env []       []       k = k env
eq_bndrs_with eq env (b1:bs1) (b2:bs2) k = eq env b1 b2 (\env -> eq_bndrs_with eq env bs1 bs2 k)
eq_bndrs_with eq env _	      _	       _ = NotEqual
\end{code}

\begin{code}
eqListBy :: (a->a->IfaceEq) -> [a] -> [a] -> IfaceEq
eqListBy eq []     []     = Equal
eqListBy eq (x:xs) (y:ys) = eq x y &&& eqListBy eq xs ys
eqListBy eq xs     ys     = NotEqual

eqMaybeBy :: (a->a->IfaceEq) -> Maybe a -> Maybe a -> IfaceEq
eqMaybeBy eq Nothing Nothing   = Equal
eqMaybeBy eq (Just x) (Just y) = eq x y
eqMaybeBy eq x        y        = NotEqual
\end{code}