InterfaceEquivalence.hs 5.48 KB
Newer Older
Björn Peemöller 's avatar
Björn Peemöller committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23
{- |
    Module      :  $Header$
    Description :  Comparison of Interfaces
    Copyright   :  (c) 2000 - 2007, Wolfgang Lux
                       2014       , Björn Peemöller
    License     :  OtherLicense

    Maintainer  :  bjp@informatik.uni-kiel.de
    Stability   :  experimental
    Portability :  portable

    If a module is recompiled, the compiler has to check whether the
    interface file must be updated. This must be done if any exported
    entity has been changed, or an export was removed or added. The
    function 'intfEquiv' checks whether two interfaces are
    equivalent, i.e., whether they define the same entities.

    /Note: There is deliberately no list instance for
    'IntfEquiv' because the order of interface declarations is
    irrelevant, whereas it is decisive for the constructor declarations
    of a data type. By not providing a list instance, we cannot
    inadvertently mix up these cases.
-}
24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87
module InterfaceEquivalence (fixInterface, intfEquiv) where

import Data.List (deleteFirstsBy)
import qualified Data.Set as Set

import Curry.Base.Ident
import Curry.Syntax

infix 4 =~=, `eqvList`, `eqvSet`

intfEquiv :: Interface -> Interface -> Bool
intfEquiv = (=~=)

class IntfEquiv a where
  (=~=) :: a -> a -> Bool

eqvList :: IntfEquiv a => [a] -> [a] -> Bool
xs `eqvList` ys = length xs == length ys && and (zipWith (=~=) xs ys)

eqvSet :: IntfEquiv a => [a] -> [a] -> Bool
xs `eqvSet` ys = null (deleteFirstsBy (=~=) xs ys ++ deleteFirstsBy (=~=) ys xs)

instance IntfEquiv a => IntfEquiv (Maybe a) where
  Nothing =~= Nothing = True
  Nothing =~= Just _  = False
  Just _  =~= Nothing = False
  Just x  =~= Just y  = x =~= y

instance IntfEquiv Interface where
  Interface m1 is1 ds1 =~= Interface m2 is2 ds2 =
    m1 == m2 && is1 `eqvSet` is2 && ds1 `eqvSet` ds2

instance IntfEquiv IImportDecl where
  IImportDecl _ m1 =~= IImportDecl _ m2 = m1 == m2

instance IntfEquiv IDecl where
  IInfixDecl _ fix1 p1 op1 =~= IInfixDecl _ fix2 p2 op2 =
    fix1 == fix2 && p1 == p2 && op1 == op2
  HidingDataDecl _ tc1 tvs1 =~= HidingDataDecl _ tc2 tvs2 =
    tc1 == tc2 && tvs1 == tvs2
  IDataDecl _ tc1 tvs1 cs1 =~= IDataDecl _ tc2 tvs2 cs2 =
    tc1 == tc2 && tvs1 == tvs2 && cs1 `eqvList` cs2
  INewtypeDecl _ tc1 tvs1 nc1 =~= INewtypeDecl _ tc2 tvs2 nc2 =
    tc1 == tc2 && tvs1 == tvs2 && nc1 =~= nc2
  ITypeDecl _ tc1 tvs1 ty1 =~= ITypeDecl _ tc2 tvs2 ty2 =
    tc1 == tc2 && tvs1 == tvs2 && ty1 == ty2
  IFunctionDecl _ f1 n1 ty1 =~= IFunctionDecl _ f2 n2 ty2 =
    f1 == f2 && n1 == n2 && ty1 == ty2
  _ =~= _ = False

instance IntfEquiv ConstrDecl where
  ConstrDecl _ evs1 c1 tys1 =~= ConstrDecl _ evs2 c2 tys2 =
    c1 == c2 && evs1 == evs2 && tys1 == tys2
  ConOpDecl _ evs1 ty11 op1 ty12 =~= ConOpDecl _ evs2 ty21 op2 ty22 =
    op1 == op2 && evs1 == evs2 && ty11 == ty21 && ty12 == ty22
  _ =~= _ = False

instance IntfEquiv NewConstrDecl where
  NewConstrDecl _ evs1 c1 ty1 =~= NewConstrDecl _ evs2 c2 ty2 =
    c1 == c2 && evs1 == evs2 && ty1 == ty2

-- If we check for a change in the interface, we do not need to check the
-- interface declarations, but still must disambiguate (nullary) type
-- constructors and type variables in type expressions. This is handled
Björn Peemöller 's avatar
Björn Peemöller committed
88
-- by function 'fixInterface' and the associated type class 'FixInterface'.
89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
fixInterface :: Interface -> Interface
fixInterface (Interface m is ds) = Interface m is $
  fix (Set.fromList (typeConstructors ds)) ds

class FixInterface a where
  fix :: Set.Set Ident -> a -> a

instance FixInterface a => FixInterface (Maybe a) where
  fix tcs = fmap (fix tcs)

instance FixInterface a => FixInterface [a] where
  fix tcs = map (fix tcs)

instance FixInterface IDecl where
  fix tcs (IDataDecl     p tc tvs cs) = IDataDecl     p tc tvs (fix tcs cs)
  fix tcs (INewtypeDecl  p tc tvs nc) = INewtypeDecl  p tc tvs (fix tcs nc)
  fix tcs (ITypeDecl     p tc tvs ty) = ITypeDecl     p tc tvs (fix tcs ty)
  fix tcs (IFunctionDecl p f  n   ty) = IFunctionDecl p f  n   (fix tcs ty)
  fix _   d                           = d

instance FixInterface ConstrDecl where
  fix tcs (ConstrDecl p evs      c tys) = ConstrDecl p evs c (fix tcs tys)
  fix tcs (ConOpDecl  p evs ty1 op ty2) =
    ConOpDecl p evs (fix tcs ty1) op (fix tcs ty2)

instance FixInterface NewConstrDecl where
  fix tcs (NewConstrDecl p evs c ty) = NewConstrDecl p evs c (fix tcs ty)

instance FixInterface TypeExpr where
  fix tcs (ConstructorType tc tys)
    | not (isQualified tc) && not (isPrimTypeId tc) &&
      tc' `Set.notMember` tcs && null tys
    = VariableType tc'
    | otherwise = ConstructorType tc (fix tcs tys)
    where tc' = unqualify tc
  fix tcs (VariableType  tv)
    | tv `Set.member` tcs = ConstructorType (qualify tv) []
    | otherwise = VariableType tv
  fix tcs (TupleType     tys) = TupleType  (fix tcs tys)
  fix tcs (ListType       ty) = ListType   (fix tcs ty)
  fix tcs (ArrowType ty1 ty2) = ArrowType  (fix tcs ty1) (fix tcs ty2)
  fix tcs (RecordType fs mty) = RecordType (map fixField fs) (fix tcs mty)
   where fixField (lbl, ty) = (lbl, fix tcs ty)

typeConstructors :: [IDecl] -> [Ident]
Björn Peemöller 's avatar
Björn Peemöller committed
134
typeConstructors ds = [tc | (QualIdent Nothing tc) <- foldr tyCons [] ds]
135 136 137 138 139 140 141 142 143
  where tyCons (IInfixDecl      _ _ _ _) tcs = tcs
        tyCons (HidingDataDecl   _ tc _) tcs = tc : tcs
        tyCons (IDataDecl      _ tc _ _) tcs = tc : tcs
        tyCons (INewtypeDecl   _ tc _ _) tcs = tc : tcs
        tyCons (ITypeDecl      _ tc _ _) tcs = tc : tcs
        tyCons (IFunctionDecl   _ _ _ _) tcs = tcs

isPrimTypeId :: QualIdent -> Bool
isPrimTypeId tc = tc `elem` [qUnitId, qListId] || isQTupleId tc