equivalence 0.2.0 → 0.2.1
raw patch · 4 files changed
+120/−28 lines, 4 filesdep +QuickCheckdep +template-haskelldep +test-frameworkdep ~basebuild-type:Customsetup-changednew-component:exe:testPVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, template-haskell, test-framework, test-framework-quickcheck2
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- Setup.hs +35/−2
- equivalence.cabal +14/−2
- src/Data/Equivalence/STT.hs +53/−24
- testsuite/tests/Data_Test.hs +18/−0
Setup.hs view
@@ -1,4 +1,37 @@ #!/usr/bin/env runhaskell+ import Distribution.Simple-main :: IO ()-main = defaultMain+import Distribution.Simple.LocalBuildInfo+import Distribution.PackageDescription+import System.Cmd+import System.FilePath+import System.Directory+import System.IO.Error+++main = defaultMainWithHooks hooks+ where hooks = simpleUserHooks { runTests = runTests'}+++hpcReportDir = "hpcreport"++runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()+runTests' _ _ _ lbi = do+ res <- try (removeFile tixFile)+ case res of+ Left err+ | not (isDoesNotExistError err) -> putStrLn "tix file could not be removed"+ _ -> return ()+ putStrLn "running tests ..."+ system testprog+ putStrLn "computing code coverage ..."+ hpcReport+ putStrLn "generating code coverage reports ..."+ hpcMarkup+ return ()+ where testprog = (buildDir lbi) </> "test" </> "test"+ tixFile = "test.tix"+ hpcReport = system $ "hpc report test"++exclArgs+ hpcMarkup = system $ "hpc markup test --destdir="++hpcReportDir++exclArgs+ excludedModules = []+ exclArgs = concatMap (" --exclude="++) excludedModules
equivalence.cabal view
@@ -1,5 +1,5 @@ Name: equivalence-Version: 0.2.0+Version: 0.2.1 License: BSD3 License-File: LICENSE Author: Patrick Bahr <paba@diku.dk>@@ -15,9 +15,14 @@ ST monad transformer (instead of the IO monad). Category: Algorithms, Data Stability: provisional-Build-Type: Simple+Build-Type: Custom Cabal-Version: >= 1.6 ++flag test+ description: Build test executable.+ default: False+ Library Build-Depends: base >= 4 && < 5, containers, mtl, STMonadTrans@@ -26,3 +31,10 @@ Data.Equivalence.Monad Hs-Source-Dirs: src +Executable test+ Main-is: Data_Test.hs+ Build-Depends: base >= 4, template-haskell, containers, mtl, QuickCheck >= 2, test-framework, test-framework-quickcheck2+ hs-source-dirs: src testsuite/tests+ ghc-options: -fhpc+ if !flag(test)+ buildable: False
src/Data/Equivalence/STT.hs view
@@ -67,7 +67,7 @@ import Data.Map (Map) import qualified Data.Map as Map -newtype Class s c a = Class (Entry s c a)+newtype Class s c a = Class (STRef s (Entry s c a)) {-| This type represents a reference to an entry in the tree data@@ -75,7 +75,7 @@ indexed by @s@, contains equivalence class descriptors of type @c@ and has elements of type @a@.-} -newtype Entry s c a = Entry (STRef s (EntryData s c a))+newtype Entry s c a = Entry {unentry :: STRef s (EntryData s c a)} {-| This type represents entries (nodes) in the tree data structure. Entry data of type 'EntryData' @s c a@ lives in the state space@@ -168,13 +168,19 @@ equivalence class. This function performs path compression. -} classRep :: (Monad m, Ord a) => Equiv s c a -> Class s c a -> STT s m (Entry s c a)-classRep eq (Class entry) = do+classRep eq (Class p) = do+ entry <- readSTRef p (mrepr,del) <- representative' entry if del -- check whether equivalence class was deleted- then mkEntry' eq entry -- if so, create a new entry- else case mrepr of- Nothing -> return entry- Just repr -> return repr+ then do v <- liftM entryValue $ readSTRef (unentry entry)+ en <- getEntry' eq v -- if so, create a new entry+ (mrepr,del) <- representative' en+ if del then do+ en' <- mkEntry' eq en+ writeSTRef p en'+ return en'+ else return (fromMaybe en mrepr)+ else return (fromMaybe entry mrepr) {-| This function constructs a new (root) entry containing the given@@ -209,7 +215,10 @@ contained in. -} getClass :: (Monad m, Ord a) => Equiv s c a -> a -> STT s m (Class s c a)-getClass eq v = liftM Class (getEntry' eq v)+getClass eq v = do + en <- (getEntry' eq v)+ liftM Class $ newSTRef en+ getEntry' :: (Monad m, Ord a) => Equiv s c a -> a -> STT s m (Entry s c a) getEntry' eq v = do@@ -233,29 +242,38 @@ {-| This function equates the two given elements. That is, it unions the equivalence classes of the two elements and combines their-descriptor. -}+descriptor. The returned entry is the representative of the new+equivalence class -} -equateEntry :: (Monad m, Ord a) => Equiv s c a -> Entry s c a -> Entry s c a -> STT s m ()+equateEntry :: (Monad 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) = - when (rx /= ry) $ do+ if (rx /= ry) then do dx@Root{entryWeight = wx, entryDesc = chx, entryValue = vx} <- readSTRef rx dy@Root{entryWeight = wy, entryDesc = chy, entryValue = vy} <- readSTRef ry if wx >= wy then do writeSTRef ry Node {entryParent = repx, entryValue = vy} writeSTRef rx dx{entryWeight = wx + wy, entryDesc = mkDesc chx chy}+ return repx else do writeSTRef rx Node {entryParent = repy, entryValue = vx} writeSTRef ry dy{entryWeight = wx + wy, entryDesc = mkDesc chx chy}+ return repy+ else return repx -{-| This function equates all elements given in the list by pairwise-applying 'equateEntry'. -} -equateEntries :: (Monad m, Ord a) => Equiv s c a -> [Entry s c a] -> STT s m ()-equateEntries eq es = run es- where run (e:r@(f:_)) = equateEntry eq e f >> run r- run _ = return () +combineEntries :: (Monad m, Ord a)+ => Equiv s c a -> [b] -> (b -> STT s m (Entry s c a)) -> STT s m ()+combineEntries _ [] _ = return ()+combineEntries eq (e:es) rep = do+ er <- rep e+ run er es+ where run er (f:r) = do+ fr <- rep f+ er' <- equateEntry eq er fr+ run er' r+ run _ _ = return () {-| This function combines all equivalence classes in the given@@ -263,7 +281,7 @@ equivalence class! -} combineAll :: (Monad m, Ord a) => Equiv s c a -> [Class s c a] -> STT s m ()-combineAll eq cs = mapM (classRep eq) cs >>= equateEntries eq+combineAll eq cls = combineEntries eq cls (classRep eq) {-| This function combines the two given equivalence@@ -280,7 +298,7 @@ descriptor. -} equateAll :: (Monad m, Ord a) => Equiv s c a -> [a] -> STT s m ()-equateAll eq els = mapM (representative eq) els >>= equateEntries eq+equateAll eq cls = combineEntries eq cls (representative eq) {-| This function equates the two given elements. That is, it unions the equivalence classes of the two elements and combines their@@ -348,11 +366,22 @@ otherwise @True@. -} remove :: (Monad m, Ord a) => Equiv s c a -> Class s c a -> STT s m Bool-remove _ (Class entry) = do- (mentry, del) <- representative' entry- if del - then return False- else removeEntry (fromMaybe entry mentry)+remove eq (Class p) = do+ entry <- readSTRef p+ (mrepr,del) <- representative' entry+ if del then do+ v <- liftM entryValue $ readSTRef (unentry entry)+ men <- getEntry eq v+ case men of+ Nothing -> return False+ Just en -> do + writeSTRef p en+ (mentry,del) <- representative' en+ if del + then return False+ else removeEntry (fromMaybe en mentry)+ >> return True+ else removeEntry (fromMaybe entry mrepr) >> return True {-| This function removes the equivalence class of the given
+ testsuite/tests/Data_Test.hs view
@@ -0,0 +1,18 @@+module Main where++import Test.Framework+import qualified Data.Equivalence.Monad_Test++--------------------------------------------------------------------------------+-- Test Suits+--------------------------------------------------------------------------------++main = defaultMain [tests]++tests = testGroup "Data" [+ Data.Equivalence.Monad_Test.tests+ ]++--------------------------------------------------------------------------------+-- Properties+--------------------------------------------------------------------------------