X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FIfaceSyn.lhs;h=8e92adce3b8b11b322ce9a84d6886bc9322aa216;hp=4563714196152f11bb2daa666a99d418e589dee6;hb=dfcf88523ec5988fbcaa2cbf812cc5862ad621cf;hpb=4bcaad0c0fc30984282ae40b802f48b2d9dc20bb

diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 4563714..8e92adc 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -27,7 +27,7 @@ module IfaceSyn (
 
 	-- Equality
 	IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
-	eqIfDecl, eqIfInst, eqIfRule, 
+	eqIfDecl, eqIfInst, eqIfRule, checkBootDecl,
 	
 	-- Pretty printing
 	pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead 
@@ -732,6 +732,11 @@ bool :: Bool -> IfaceEq
 bool True  = Equal
 bool False = NotEqual
 
+toBool :: IfaceEq -> Bool
+toBool Equal     = True
+toBool (EqBut _) = True
+toBool NotEqual  = False
+
 zapEq :: IfaceEq -> IfaceEq	-- Used to forget EqBut information
 zapEq (EqBut _) = Equal
 zapEq other	= other
@@ -757,6 +762,43 @@ eqIfExt n1 n2 = NotEqual
 
 \begin{code}
 ---------------------
+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
+
+---------------------
 eqIfDecl :: IfaceDecl -> IfaceDecl -> IfaceEq
 eqIfDecl (IfaceId s1 t1 i1) (IfaceId s2 t2 i2)
   = bool (s1 == s2) &&& (t1 `eqIfType` t2) &&& (i1 `eqIfIdInfo` i2)