diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,31 @@ +0.4 +--- +* remove ErrorT instance for compatibility with transformers-0.6 and mtl-2.3 + +0.3.5 +----- +* compatibility with GHC 8.8 + +0.3.4 +----- +* MonadFail instance for EquivT + +0.3.3 +----- +* compatibility with GHC 8.6 + +0.3.2 +----- +* add Applicative constraints for backwards compatibility with GHC 7.8 + +0.3.1 +----- +* use transformers-compat for backwards compatibility with older versions of transformers + +0.3.0.1 +------- +* add CHANGES.txt to .cabal file + +0.3 +--- +* add suport for Control.Monad.Except (thus the new dependency constraint 'mtl >= 2.2.1') diff --git a/CHANGES.txt b/CHANGES.txt deleted file mode 100644 --- a/CHANGES.txt +++ /dev/null @@ -1,27 +0,0 @@ -0.3.5 ------ -* compatibility with GHC 8.8 - -0.3.4 ------ -* MonadFail instance for EquivT - -0.3.3 ------ -* compatibility with GHC 8.6 - -0.3.2 ------ -* add Applicative constraints for backwards compatibility with GHC 7.8 - -0.3.1 ------ -* use transformers-compat for backwards compatibility with older versions of transformers - -0.3.0.1 -------- -* add CHANGES.txt to .cabal file - -0.3 ---- -* add suport for Control.Monad.Except (thus the new dependency constraint 'mtl >= 2.2.1') diff --git a/equivalence.cabal b/equivalence.cabal --- a/equivalence.cabal +++ b/equivalence.cabal @@ -1,47 +1,99 @@ +Cabal-Version: >= 1.10 Name: equivalence -Version: 0.3.5 +Version: 0.4 License: BSD3 License-File: LICENSE Author: Patrick Bahr Maintainer: paba@itu.dk Homepage: https://github.com/pa-ba/equivalence -bug-reports: https://github.com/pa-ba/equivalence/issues/new +bug-reports: https://github.com/pa-ba/equivalence/issues Synopsis: Maintaining an equivalence relation implemented as union-find using STT. -Description: +Description: This is an implementation of Tarjan's Union-Find algorithm (Robert E. Tarjan. "Efficiency of a Good But Not Linear Set Union Algorithm", JACM 22(2), 1975) in order to maintain an equivalence - relation. - + relation. + This implementation is a port of the /union-find/ package using the ST monad transformer (instead of the IO monad). Category: Algorithms, Data Stability: provisional Build-Type: Simple -Cabal-Version: >=1.9.2 -Extra-Source-Files: CHANGES.txt +tested-with: + GHC == 7.10.3 + GHC == 8.0.2 + GHC == 8.2.2 + GHC == 8.4.4 + GHC == 8.6.5 + GHC == 8.8.4 + GHC == 8.10.7 + GHC == 9.0.2 + GHC == 9.2.1 +Extra-Source-Files: CHANGES.md source-repository head type: git location: https://github.com/pa-ba/equivalence -Test-Suite test - Type: exitcode-stdio-1.0 - Main-is: Data_Test.hs - Other-Modules: Data.Equivalence.Monad_Test,Data.Equivalence.Monad, Data.Equivalence.STT - hs-source-dirs: src testsuite/tests - Build-Depends: base >= 4, template-haskell, containers, mtl >= 2.0.1, QuickCheck >= 2, - STMonadTrans >= 0.4.3, transformers >= 0.2, transformers-compat >= 0.3, fail - Library - Build-Depends: - base >= 4 && < 5, containers, mtl >= 2.0.1, STMonadTrans >= 0.4.3, - transformers >= 0.2, transformers-compat >= 0.3 Exposed-Modules: - Data.Equivalence.STT, + Data.Equivalence.STT Data.Equivalence.Monad - Hs-Source-Dirs: src - build-depends: fail + Hs-Source-Dirs: src + default-language: Haskell2010 + Build-Depends: + base >= 4.8 && < 5 + , containers + , mtl >= 2.2.1 + , STMonadTrans >= 0.4.3 + , transformers >= 0.2 + , transformers-compat >= 0.3 + if impl(ghc < 8.0) + Build-Depends: + fail + + ghc-options: + -Wall + -fno-warn-name-shadowing + -fno-warn-incomplete-record-updates + if impl(ghc >= 8.0) + ghc-options: + -Wcompat + +Test-Suite test + Type: exitcode-stdio-1.0 + Main-is: Data_Test.hs + Other-Modules: + Data.Equivalence.Monad_Test + Data.Equivalence.Monad + Data.Equivalence.STT + hs-source-dirs: src testsuite/tests + default-language: Haskell2010 + Build-Depends: + equivalence + -- inherited dependencies from library + , base + , containers + , mtl + , STMonadTrans + , transformers + , transformers-compat + -- Additional dependencies for testsuite + , QuickCheck >= 2 + , template-haskell + if impl(ghc < 8.0) + Build-Depends: + fail + + ghc-options: + -Wall + -fno-warn-name-shadowing + -fno-warn-incomplete-record-updates + -fno-warn-missing-signatures + -fno-warn-unused-do-bind + if impl(ghc >= 8.0) + ghc-options: + -Wcompat diff --git a/src/Data/Equivalence/Monad.hs b/src/Data/Equivalence/Monad.hs --- a/src/Data/Equivalence/Monad.hs +++ b/src/Data/Equivalence/Monad.hs @@ -1,25 +1,22 @@ -{-# LANGUAGE - RankNTypes, - FlexibleInstances, - FlexibleContexts, - MultiParamTypeClasses, - UndecidableInstances, - FunctionalDependencies #-} - --- Suppress warnings about ''Control.Monad.Error'' being deprecated. - -{-# OPTIONS_GHC -fno-warn-deprecations #-} - +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} -- for type equality ~ +{-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : Data.Equivalence.Monad -- Copyright : Patrick Bahr, 2010 --- License : All Rights Reserved +-- License : BSD-3-Clause -- --- Maintainer : Patrick Bahr --- Stability : unknown --- Portability : unknown +-- Maintainer : Patrick Bahr, Andreas Abel +-- Stability : stable +-- Portability : non-portable (MPTC with FD) -- -- This is an alternative interface to the union-find implementation -- in ''Data.Equivalence.STT''. It is wrapped into the monad @@ -44,17 +41,14 @@ getClass , combine, combineAll, same , desc , remove ) import qualified Data.Equivalence.STT as S - + import Control.Monad.Writer import Control.Monad.Reader import Control.Monad.Error.Class import Control.Monad.State -import Control.Monad.Trans import Control.Monad.Identity import Control.Monad.ST.Trans -import Control.Monad.Trans.Error (ErrorT) import Control.Monad.Trans.Except (ExceptT) -import Control.Applicative import qualified Control.Monad.Fail as Fail @@ -66,7 +60,7 @@ of type @m a@. -} newtype EquivT s c v m a = EquivT {unEquivT :: ReaderT (Equiv s c v) (STT s m) a} - + deriving (Functor, Applicative, Monad, MonadError e, MonadState st, MonadWriter w) {-| This monad transformer is a special case of 'EquivT' that only maintains trivial equivalence class descriptors of type @()@. -} @@ -81,22 +75,12 @@ type EquivM s c v = EquivT s c v Identity - {-| This monad is a special case of 'EquivM' that only maintains trivial equivalence class descriptors of type @()@. -} type EquivM' s v = EquivM s () v -instance Functor m => Functor (EquivT s c v m) where - fmap f (EquivT m) = EquivT $ fmap f m - -instance (Applicative m, Monad m) => Applicative (EquivT s c v m) where - pure = EquivT . pure - (EquivT f) <*> (EquivT a) = EquivT (f <*> a) - -instance (Monad m) => Monad (EquivT s c v m) where - EquivT m >>= f = EquivT (m >>= (unEquivT . f)) - return = EquivT . return +-- Instances for EquivT: instance MonadTrans (EquivT s c v) where lift = EquivT . lift . lift @@ -104,35 +88,25 @@ instance Monad m => Fail.MonadFail (EquivT s c v m) where fail = error +-- NB: This instance is beyond GeneralizedNewtypeDeriving +-- because EquivT already contains a ReaderT in its monad transformer stack. instance (MonadReader r m) => MonadReader r (EquivT s c v m) where ask = EquivT $ lift ask local f (EquivT (ReaderT m)) = EquivT $ ReaderT $ (\ r -> local f (m r)) -instance (Monoid w, MonadWriter w m) => MonadWriter w (EquivT s c v m) where - tell w = EquivT $ tell w - listen (EquivT m) = EquivT $ listen m - pass (EquivT m) = EquivT $ pass m - -instance (MonadState st m) => MonadState st (EquivT s c v m) where - get = EquivT get - put s = EquivT $ put s - -instance (MonadError e m) => MonadError e (EquivT s c v m) where - throwError e = lift $ throwError e - catchError (EquivT m) f = EquivT $ catchError m (unEquivT . f) - {-| This function runs a monadic computation that maintains an -equivalence relation. The first tow arguments specify how to construct +equivalence relation. The first two arguments specify how to construct an equivalence class descriptor for a singleton class and how to combine two equivalence class descriptors. -} -runEquivT :: (Monad m, Applicative m) - => (v -> c) -- ^ used to construct an equivalence class descriptor for a singleton class - -> (c -> c -> c) -- ^ used to combine the equivalence class descriptor of two classes - -- which are meant to be combined. - -> (forall s. EquivT s c v m a) - -> m a -runEquivT mk com m = runST $ do +runEquivT + :: (Monad m, Applicative m) + => (v -> c) -- ^ Used to construct an equivalence class descriptor for a singleton class. + -> (c -> c -> c) -- ^ Used to combine the equivalence class descriptor of two classes + -- which are meant to be combined. + -> (forall s. EquivT s c v m a) + -> m a +runEquivT mk com m = runSTT $ do p <- leastEquiv mk com (`runReaderT` p) $ unEquivT m @@ -147,11 +121,13 @@ equivalence relation. The first tow arguments specify how to construct an equivalence class descriptor for a singleton class and how to combine two equivalence class descriptors. -} -runEquivM :: (v -> c) -- ^ used to construct an equivalence class descriptor for a singleton class - -> (c -> c -> c) -- ^ used to combine the equivalence class descriptor of two classes - -- which are meant to be combined. - -> (forall s. EquivM s c v a) - -> a + +runEquivM + :: (v -> c) -- ^ Used to construct an equivalence class descriptor for a singleton class. + -> (c -> c -> c) -- ^ Used to combine the equivalence class descriptor of two classes + -- which are meant to be combined. + -> (forall s. EquivM s c v a) + -> a runEquivM sing comb m = runIdentity $ runEquivT sing comb m {-| This function is a special case of 'runEquivM' that only maintains @@ -164,21 +140,23 @@ maintains an equivalence relation. -} class (Monad m, Applicative m, Ord v) => MonadEquiv c v d m | m -> v, m -> c, m -> d where + {-| This function decides whether the two given elements are - equivalent in the current equivalence relation -} + equivalent in the current equivalence relation. -} equivalent :: v -> v -> m Bool + {-| This function obtains the descriptor of the given element's equivalence class. -} classDesc :: v -> m d - + {-| This function equates the element in the given list. That is, it unions the equivalence classes of the elements and combines their descriptor. -} equateAll :: [v] -> m () - + {-| This function equates the given two elements. That is it unions the equivalence classes of the two elements. -} @@ -188,22 +166,19 @@ {-| This function removes the equivalence class of the given element. If there is no corresponding equivalence class, @False@ is returned; otherwise @True@. -} + removeClass :: v -> m Bool - - {-| This function provides the equivalence class the given element - is contained in. -} + {-| This function provides the equivalence class of the given element. -} getClass :: v -> m c - - + {-| This function combines all equivalence classes in the given list. Afterwards all elements in the argument list represent the same equivalence class! -} combineAll :: [c] -> m () - {-| This function combines the two given equivalence classes. Afterwards both arguments represent the same equivalence class! One of it is returned in order to represent the new combined @@ -211,27 +186,55 @@ combine :: c -> c -> m c combine x y = combineAll [x,y] >> return x - + {-| This function decides whether the two given equivalence classes are the same. -} (===) :: c -> c -> m Bool - {-| This function returns the descriptor of the given equivalence class. -} desc :: c -> m d {-| This function removes the given equivalence class. If the - equivalence class does not exists anymore @False@ is returned; + equivalence class does not exist anymore, @False@ is returned; otherwise @True@. -} remove :: c -> m Bool + -- Default implementations for lifting via a monad transformer. + -- Unfortunately, GHC does not permit us to give these also to + -- 'equate' and 'combine', which already have a default implementation. - + default equivalent :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> v -> m Bool + equivalent x y = lift $ equivalent x y + default classDesc :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> m d + classDesc = lift . classDesc + + default equateAll :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => [v] -> m () + equateAll = lift . equateAll + + default removeClass :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> m Bool + removeClass = lift . removeClass + + default getClass :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => v -> m c + getClass = lift . getClass + + default combineAll :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => [c] -> m () + combineAll = lift . combineAll + + default (===) :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => c -> c -> m Bool + x === y = lift $ (===) x y + + default desc :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => c -> m d + desc = lift . desc + + default remove :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => c -> m Bool + remove = lift . remove + + instance (Monad m, Applicative m, Ord v) => MonadEquiv (Class s d v) v d (EquivT s d v m) where equivalent x y = EquivT $ do part <- ask @@ -240,11 +243,11 @@ classDesc x = EquivT $ do part <- ask lift $ S.classDesc part x - + equateAll x = EquivT $ do part <- ask lift $ S.equateAll part x - + equate x y = EquivT $ do part <- ask lift $ S.equate part x y @@ -278,67 +281,17 @@ lift $ S.remove part x instance (MonadEquiv c v d m, Monoid w) => MonadEquiv c v d (WriterT w m) where - equivalent x y = lift $ equivalent x y - classDesc = lift . classDesc - equateAll x = lift $ equateAll x - equate x y = lift $ equate x y - removeClass x = lift $ removeClass x - getClass x = lift $ getClass x - combineAll x = lift $ combineAll x + equate x y = lift $ equate x y combine x y = lift $ combine x y - x === y = lift $ (===) x y - desc x = lift $ desc x - remove x = lift $ remove x -instance (MonadEquiv c v d m, Error e) => MonadEquiv c v d (ErrorT e m) where - equivalent x y = lift $ equivalent x y - classDesc = lift . classDesc - equateAll x = lift $ equateAll x - equate x y = lift $ equate x y - removeClass x = lift $ removeClass x - getClass x = lift $ getClass x - combineAll x = lift $ combineAll x - combine x y = lift $ combine x y - x === y = lift $ (===) x y - desc x = lift $ desc x - remove x = lift $ remove x - instance (MonadEquiv c v d m) => MonadEquiv c v d (ExceptT e m) where - equivalent x y = lift $ equivalent x y - classDesc = lift . classDesc - equateAll x = lift $ equateAll x - equate x y = lift $ equate x y - removeClass x = lift $ removeClass x - getClass x = lift $ getClass x - combineAll x = lift $ combineAll x + equate x y = lift $ equate x y combine x y = lift $ combine x y - x === y = lift $ (===) x y - desc x = lift $ desc x - remove x = lift $ remove x - instance (MonadEquiv c v d m) => MonadEquiv c v d (StateT s m) where - equivalent x y = lift $ equivalent x y - classDesc = lift . classDesc - equateAll x = lift $ equateAll x - equate x y = lift $ equate x y - removeClass x = lift $ removeClass x - getClass x = lift $ getClass x - combineAll x = lift $ combineAll x + equate x y = lift $ equate x y combine x y = lift $ combine x y - x === y = lift $ (===) x y - desc x = lift $ desc x - remove x = lift $ remove x instance (MonadEquiv c v d m) => MonadEquiv c v d (ReaderT r m) where - equivalent x y = lift $ equivalent x y - classDesc = lift . classDesc - equateAll x = lift $ equateAll x - equate x y = lift $ equate x y - removeClass x = lift $ removeClass x - getClass x = lift $ getClass x - combineAll x = lift $ combineAll x + equate x y = lift $ equate x y combine x y = lift $ combine x y - x === y = lift $ (===) x y - desc x = lift $ desc x - remove x = lift $ remove x diff --git a/src/Data/Equivalence/STT.hs b/src/Data/Equivalence/STT.hs --- a/src/Data/Equivalence/STT.hs +++ b/src/Data/Equivalence/STT.hs @@ -3,18 +3,18 @@ -------------------------------------------------------------------------------- -- | -- Module : Data.Equivalence.STT --- Copyright : 3gERP, 2010 --- License : All Rights Reserved +-- Copyright : Patrick Bahr, 2010 +-- License : BSD-3-Clause -- --- Maintainer : Patrick Bahr --- Stability : unknown --- Portability : unknown +-- Maintainer : Patrick Bahr, Andreas Abel +-- Stability : stable +-- Portability : non-portable (MPTC) -- -- This is an implementation of Tarjan's Union-Find algorithm (Robert -- E. Tarjan. "Efficiency of a Good But Not Linear Set Union -- Algorithm", JACM 22(2), 1975) in order to maintain an equivalence --- relation. --- +-- relation. +-- -- This implementation is a port of the /union-find/ package using the -- ST monad transformer (instead of the IO monad). -- @@ -39,7 +39,7 @@ -------------------------------------------------------------------------------- module Data.Equivalence.STT - ( + ( -- * Equivalence Relation Equiv , Class @@ -61,15 +61,15 @@ import Control.Monad.ST.Trans import Control.Monad -import Control.Applicative import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map -newtype Class s c a = Class (STRef s (Entry s c a)) +{-| Abstract representation of an equivalence class. -} +newtype Class s c a = Class (STRef s (Entry s c a)) {-| This type represents a reference to an entry in the tree data structure. An entry of type 'Entry' @s c a@ lives in the state space @@ -102,32 +102,32 @@ descriptors of type @c@ and has elements of type @a@. -} data Equiv s c a = Equiv { - -- | maps elements to their entry in the tree data structure - entries :: Entries s c a, - -- | constructs an equivalence class descriptor for a singleton class + -- | Maps elements to their entry in the tree data structure. + entries :: Entries s c a, + -- | Constructs an equivalence class descriptor for a singleton class. singleDesc :: a -> c, - -- | combines the equivalence class descriptor of two classes + -- | Combines the equivalence class descriptor of two classes -- which are meant to be combined. combDesc :: c -> c -> c } {-| This function constructs the initial data structure for -maintaining an equivalence relation. That is it represents, the fines +maintaining an equivalence relation. That is, it represents the finest (or least) equivalence class (of the set of all elements of type @a@). The arguments are used to maintain equivalence class descriptors. -} -leastEquiv :: (Monad m, Applicative m) - => (a -> c) -- ^ used to construct an equivalence class descriptor for a singleton class - -> (c -> c -> c) -- ^ used to combine the equivalence class descriptor of two classes - -- which are meant to be combined. - -> STT s m (Equiv s c a) -leastEquiv mk com = do +leastEquiv + :: (Monad m, Applicative m) + => (a -> c) -- ^ Used to construct an equivalence class descriptor for a singleton class. + -> (c -> c -> c) -- ^ Used to combine the equivalence class descriptor of two classes + -- which are meant to be combined. + -> STT s m (Equiv s c a) +leastEquiv mk com = do es <- newSTRef Map.empty return Equiv {entries = es, singleDesc = mk, combDesc = com} - {-| This function returns the representative entry of the argument's equivalence class (i.e. the root of its tree) or @Nothing@ if it is the representative itself. @@ -182,8 +182,8 @@ return en' else return (fromMaybe en mrepr) else return (fromMaybe entry mrepr) - + {-| This function constructs a new (root) entry containing the given entry's value, inserts it into the lookup table (thereby removing any existing entry). -} @@ -216,11 +216,11 @@ contained in. -} getClass :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m (Class s c a) -getClass eq v = do +getClass eq v = do en <- (getEntry' eq v) liftM Class $ newSTRef en - + getEntry' :: (Monad m, Applicative m, Ord a) => Equiv s c a -> a -> STT s m (Entry s c a) getEntry' eq v = do mentry <- getEntry eq v @@ -247,7 +247,7 @@ equivalence class -} equateEntry :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Entry s c a -> Entry s c a -> STT s m (Entry s c a) -equateEntry Equiv {combDesc = mkDesc} repx@(Entry rx) repy@(Entry ry) = +equateEntry Equiv {combDesc = mkDesc} repx@(Entry rx) repy@(Entry ry) = if (rx /= ry) then do dx <- readSTRef rx dy <- readSTRef ry @@ -368,7 +368,7 @@ {-| This function removes the given equivalence class. If the -equivalence class does not exists anymore @False@ is returned; +equivalence class does not exist anymore, @False@ is returned; otherwise @True@. -} remove :: (Monad m, Applicative m, Ord a) => Equiv s c a -> Class s c a -> STT s m Bool @@ -380,10 +380,10 @@ men <- getEntry eq v case men of Nothing -> return False - Just en -> do + Just en -> do writeSTRef p en (mentry,del) <- representative' en - if del + if del then return False else removeEntry (fromMaybe en mentry) >> return True @@ -401,7 +401,7 @@ Nothing -> return False Just entry -> do (mentry, del) <- representative' entry - if del + if del then return False else removeEntry (fromMaybe entry mentry) >> return True diff --git a/testsuite/tests/Data/Equivalence/Monad_Test.hs b/testsuite/tests/Data/Equivalence/Monad_Test.hs --- a/testsuite/tests/Data/Equivalence/Monad_Test.hs +++ b/testsuite/tests/Data/Equivalence/Monad_Test.hs @@ -10,6 +10,7 @@ import Control.Monad import Data.Set (Set) import qualified Data.Set as Set +import System.Exit @@ -108,7 +109,7 @@ cx <- getClass x remove cx allM check l - where check e = liftM (== Set.singleton e) $ getClass e >>= desc + where check e = liftM (== Set.singleton e) $ getClass e >>= desc prop_removeClass' x y l1' l2' = runInt $ do let l1 = x:l1' @@ -157,5 +158,8 @@ return [] -main = $quickCheckAll +main :: IO () +main = do + success <- $quickCheckAll + if success then exitSuccess else exitFailure