-\begin{code}
-data GenIfaceEq a
- = Equal -- Definitely exactly the same
- | NotEqual -- Definitely different
- | EqBut (UniqSet a) -- The same provided these things have not changed
-
-type IfaceEq = GenIfaceEq Name
-
-instance Outputable a => Outputable (GenIfaceEq a) where
- ppr Equal = ptext (sLit "Equal")
- ppr NotEqual = ptext (sLit "NotEqual")
- ppr (EqBut occset) = ptext (sLit "EqBut") <+> ppr (uniqSetToList occset)
-
-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
-
-(&&&) :: IfaceEq -> IfaceEq -> IfaceEq
-Equal &&& x = x
-NotEqual &&& _ = NotEqual
-EqBut nms &&& Equal = EqBut nms
-EqBut _ &&& NotEqual = NotEqual
-EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2)
-
--- This function is the core of the EqBut stuff
--- 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
-
----------------------
-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)
-
-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 &&
- ifGadtSyntax d1 == ifGadtSyntax d2 &&
- ifGeneric d1 == ifGeneric d2) &&&
- ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
- eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
- eq_hsCD env (ifCons d1) (ifCons d2)
- )
- -- 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
-
-eqIfDecl d1@(IfaceSyn {}) d2@(IfaceSyn {})
- = bool (ifName d1 == ifName d2) &&&
- ifFamInst d1 `eqIfTc_fam` ifFamInst d2 &&&
- eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifType env (ifSynRhs d1) (ifSynRhs d2)
- )
-
-eqIfDecl d1@(IfaceClass {}) d2@(IfaceClass {})
- = bool (ifName d1 == ifName d2 &&
- ifRec d1 == ifRec d2) &&&
- eqWith (ifTyVars d1) (ifTyVars d2) (\ env ->
- eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&&
- eqListBy (eq_hsFD env) (ifFDs d1) (ifFDs d2) &&&
- eqListBy eqIfDecl (ifATs d1) (ifATs d2) &&&
- eqListBy (eq_cls_sig env) (ifSigs d1) (ifSigs d2)
- )
-
-eqIfDecl _ _ = NotEqual -- default case
-
--- Helper
-eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq
-eqWith = eq_ifTvBndrs emptyEqEnv
-
-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
-
-
------------------------
-eqIfInst :: IfaceInst -> IfaceInst -> IfaceEq
-eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2 && ifOFlag d1 == ifOFlag d2)
--- All other changes are handled via the version info on the dfun
-
-eqIfFamInst :: IfaceFamInst -> IfaceFamInst -> IfaceEq
-eqIfFamInst d1 d2 = bool (ifFamInstTyCon d1 == ifFamInstTyCon d2)
projects / ghc-hetmet.git / blobdiff