equivalence 0.4.0.1 → 0.4.1

raw patch · 5 files changed

+128/−36 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGES.md +18/−6
• equivalence.cabal +3/−3
• src/Data/Equivalence/Monad.hs +31/−1
• src/Data/Equivalence/STT.hs +24/−0
• testsuite/tests/Data/Equivalence/Monad_Test.hs +52/−26

@@ -1,3 +1,15 @@+0.4.1+-----++_Andreas Abel, 2022-07-26_++* New methods `values` and `classes` to get all values and classes encountered+  [#7](https://github.com/pa-ba/equivalence/issues/7)+  [#13](https://github.com/pa-ba/equivalence/pull/13)+  (contributed by Jimmy Koppel).++Tested with GHC 7.10 - 9.4.1 RC1.+ 0.4.0.1 ------- @@ -10,7 +22,7 @@  _Andreas Abel, 2022-02-03_ -* remove ErrorT instance for compatibility with transformers-0.6 and mtl-2.3+* remove `ErrorT` instance for compatibility with `transformers-0.6` and `mtl-2.3`  0.3.5 -----@@ -21,7 +33,7 @@  0.3.4 ------* MonadFail instance for EquivT+* `MonadFail` instance for `EquivT`  0.3.3 -----@@ -29,16 +41,16 @@  0.3.2 ------* add Applicative constraints for backwards compatibility with GHC 7.8+* add `Applicative` constraints for backwards compatibility with GHC 7.8  0.3.1 ------* use transformers-compat for backwards compatibility with older versions of transformers+* use `transformers-compat` for backwards compatibility with older versions of `transformers`  0.3.0.1 --------* add CHANGES.txt to .cabal file+* add `CHANGES.txt` to `.cabal` file  0.3 ----* add suport for Control.Monad.Except (thus the new dependency constraint 'mtl >= 2.2.1')+* add suport for `Control.Monad.Except` (thus the new dependency constraint `mtl >= 2.2.1`)

@@ -1,10 +1,10 @@ Cabal-Version:   >= 1.10 Name:            equivalence-Version:         0.4.0.1+Version:         0.4.1 License:         BSD3 License-File:    LICENSE Author:          Patrick Bahr-Maintainer:      paba@itu.dk+Maintainer:      Andreas Abel Homepage:        https://github.com/pa-ba/equivalence bug-reports:     https://github.com/pa-ba/equivalence/issues Synopsis:        Maintaining an equivalence relation implemented as union-find using STT.@@ -22,7 +22,7 @@  tested-with:   GHC == 9.4.1-  GHC == 9.2.2+  GHC == 9.2.3   GHC == 9.0.2   GHC == 8.10.7   GHC == 8.8.4

@@ -39,7 +39,8 @@      ) where  import Data.Equivalence.STT hiding (equate, equateAll, equivalent, classDesc, removeClass,-                                    getClass , combine, combineAll, same , desc , remove )+                                    getClass , combine, combineAll, same , desc , remove,+                                    values , classes ) import qualified Data.Equivalence.STT  as S  @@ -204,6 +205,20 @@      remove :: c -> m Bool +    {-| This function returns all values represented by+       some equivalence class.++       @since 0.4.1 -}++    values :: m [v]++    {-| This function returns the list of+       all equivalence classes.++       @since 0.4.1 -}++    classes :: m [c]+     -- 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.@@ -235,7 +250,13 @@     default remove      :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => c -> m Bool     remove               = lift . remove +    default values      :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => m [v]+    values               = lift values +    default classes     :: (MonadEquiv c v d n, MonadTrans t, t n ~ m) => m [c]+    classes              = lift classes++ 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@@ -281,6 +302,14 @@       part <- ask       lift $ S.remove part x +    values = EquivT $ do+      part <- ask+      lift $ S.values part++    classes = EquivT $ do+      part <- ask+      lift $ S.classes part+ instance (MonadEquiv c v d m, Monoid w) => MonadEquiv c v d (WriterT w m) where     equate  x y = lift $ equate x y     combine x y = lift $ combine x y@@ -288,6 +317,7 @@ instance (MonadEquiv c v d m) => MonadEquiv c v d (ExceptT e m) where     equate  x y = lift $ equate x y     combine x y = lift $ combine x y+  instance (MonadEquiv c v d m) => MonadEquiv c v d (StateT s m) where     equate  x y = lift $ equate x y

@@ -57,6 +57,9 @@   , equivalent   , classDesc   , removeClass+  -- Getting all represented items+  , values+  , classes   ) where  import Control.Monad.ST.Trans@@ -405,3 +408,24 @@         then return False         else removeEntry (fromMaybe entry mentry)              >> return True++{-| This function returns all values represented by+   some equivalence class. -}++values :: (Monad m, Applicative m, Ord a) => Equiv s c a -> STT s m [a]+values Equiv {entries = mref} = Map.keys <$> readSTRef mref++{-| This function returns the list of+   all equivalence classes. -}++classes :: (Monad m, Applicative m, Ord a) => Equiv s c a -> STT s m [Class s c a]+classes Equiv {entries = mref} = do+  allEntries <- Map.elems <$> readSTRef mref+  rootEntries <- filterM isRoot allEntries+  mapM (fmap Class . newSTRef) $ rootEntries+    where+      isRoot e = do+        x <- readSTRef (unentry e)+        case x of+          Node {} -> return False+          Root {} -> return True

@@ -1,24 +1,23 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes, TemplateHaskell #-}+{-# LANGUAGE ScopedTypeVariables #-}  module Data.Equivalence.Monad_Test where -import Test.QuickCheck hiding ((===))+import Test.QuickCheck hiding ((===), classes)  import Data.Equivalence.Monad  import Control.Monad+import Data.Function (on) import Data.Set (Set) import qualified Data.Set as Set import System.Exit -- -------------------------------------------------------------------------------- -- Test Suits -------------------------------------------------------------------------------- - -- run :: (Ord a) => STT s Identity (Equiv s (Set a) a) run :: (Ord v) => (forall s. EquivM s (Set v) v a) -> a run = runEquivM Set.singleton Set.union@@ -30,7 +29,13 @@  getClasses l1 = mapM getClass l1 +infixr 9 <.> +-- | Composition: pure function after functorial (monadic) function.+(<.>) :: Functor m => (b -> c) -> (a -> m b) -> a -> m c+(f <.> g) a = f <$> g a++ -------------------------------------------------------------------------------- -- Properties --------------------------------------------------------------------------------@@ -43,7 +48,7 @@   let l = v:l'   equateAll l   d <- classDesc v-  return  (d == Set.fromList l)+  return (d == Set.fromList l)  prop_combineAll l' v = runInt $ do   let l = v:l'@@ -134,28 +139,49 @@   return (Set.fromList l2 == d)  -prop_classes l1 l1' l2 x y = putStrLn (show el ++ ";" ++ show cl) `whenFail` (el == cl)-    where l3 = concat (l2 : l1)-          el = runInt $ do-                 mapM equateAll l1-                 mapM removeClass l2-                 mapM equateAll (l1' :: [[Int]])-                 res <- mapM classDesc l3-                 eq <- equivalent x y-                 return (res,eq)-          cl = runInt $ do-                 cls1 <- mapM getClasses l1-                 mapM combineAll cls1-                 cls2 <- getClasses l2-                 mapM remove cls2-                 cls1' <- mapM getClasses l1'-                 mapM combineAll cls1'-                 cls3 <- getClasses l3-                 res <- mapM desc cls3-                 [cx,cy] <- getClasses [x,y]-                 eq <- cx === cy-                 return (res,eq)+prop_getClasses l1 l1' l2 x y =+  putStrLn (show el ++ ";" ++ show cl) `whenFail` (el == cl)+  where+    l3 = concat (l2 : l1) +    el = runInt $ do+      mapM equateAll l1+      mapM removeClass l2+      mapM equateAll (l1' :: [[Int]])+      res <- mapM classDesc l3+      eq <- equivalent x y+      return (res,eq)++    cl = runInt $ do+      cls1 <- mapM getClasses l1+      mapM combineAll cls1+      cls2 <- getClasses l2+      mapM remove cls2+      cls1' <- mapM getClasses l1'+      mapM combineAll cls1'+      cls3 <- getClasses l3+      res <- mapM desc cls3+      [cx,cy] <- getClasses [x,y]+      eq <- cx === cy+      return (res,eq)++prop_values l = runInt $ do+    mapM (\x -> equate x x) l+    sameSet l <$> values+  where+    sameSet = (==) `on` Set.fromList++prop_classes l = runInt $ do+    mapM equateAll (l :: [[Int]])+    classes1 <- uniqClass =<< mapM getClass =<< values+    sameClasses classes1 =<< classes+  where+    uniqClass []     = return []+    uniqClass (c:cs) = (c :) <$> do+      uniqClass =<< filterM (not <.> (c ===)) cs++    sameClasses []       cs2 = return $ null cs2+    sameClasses (c:cs1') cs2 = sameClasses cs1' =<< filterM (not <.> (c ===)) cs2  return []