acid-state 0.14.0 → 0.14.1

raw patch · 9 files changed

+228/−6 lines, 9 filesdep ~arraydep ~basedep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: array, base, bytestring, cereal, containers, criterion, directory, extensible-exceptions, filepath, mtl, network, safecopy, stm, template-haskell

API changes (from Hackage documentation)

Files

• CHANGELOG.md +7/−0
• acid-state.cabal +6/−2
• benchmarks/loading/Benchmark/FileSystem.hs +57/−0
• benchmarks/loading/Benchmark/Model.hs +13/−0
• benchmarks/loading/Benchmark/Prelude.hs +42/−0
• examples/MultipleCheckpoint.hs +77/−0
• src/Data/Acid/Abstract.hs +1/−1
• src/Data/Acid/Log.hs +1/−1
• src/Data/Acid/TemplateHaskell.hs +24/−2

@@ -1,3 +1,10 @@+0.14.1+======++ - fix bug in archiveLog that resulted in logs being moved prematurely (bug #22)+ - tweaks for GHC 8.0.x, template-haskell 2.11.x+ - fix compilation of benchmarks+ 0.14.0 ====== 

@@ -1,5 +1,5 @@ Name:                acid-state-Version:             0.14.0+Version:             0.14.1 Synopsis:            Add ACID guarantees to any serializable Haskell data structure. Description:         Use regular Haskell data structures as your database and get stronger ACID guarantees than most RDBMS offer. Homepage:            http://acid-state.seize.it/@@ -71,12 +71,16 @@     benchmarks/loading   main-is:     Benchmark.hs+  other-modules:+    Benchmark.FileSystem+    Benchmark.Model+    Benchmark.Prelude   build-depends:     random,     directory,     system-fileio == 0.3.*,     system-filepath,-    criterion >= 0.8 && < 1.1,+    criterion >= 0.8 && < 1.2,     mtl,     base,     acid-state

@@ -0,0 +1,57 @@+module Benchmark.FileSystem +  ( +    copy,+    removeTreeIfExists,+    exists,+    getTemporaryDirectory,+    module Filesystem,+    module Filesystem.Path.CurrentOS+  )+  where++import Benchmark.Prelude hiding (stripPrefix, last)+import Filesystem.Path.CurrentOS+import Filesystem+import qualified System.Directory as Directory+import Debug.Trace+import qualified Data.List as List++++removeTreeIfExists :: FilePath -> IO ()+removeTreeIfExists path = removeTree path `catch` \e -> case e of+  _ | isDoesNotExistError e -> return ()+    | otherwise -> throwIO e++exists :: FilePath -> IO Bool+exists path = do+  isDir <- isDirectory path+  isFile <- isFile path+  return $ isDir || isFile ++getTemporaryDirectory :: IO FilePath+getTemporaryDirectory = +  Directory.getTemporaryDirectory >>= return . decodeString++copy :: FilePath -> FilePath -> IO ()+copy from to = do+  isDir <- isDirectory from+  if isDir+    then copyDirectory from to+    else copyFile from to++copyDirectory :: FilePath -> FilePath -> IO ()+copyDirectory path path' = do+  members <- listDirectory path+  let members' = do+        member <- members+        let relative = +              fromMaybe (error "Unexpectedly empty member path") $+              last member+        return $ path' <> relative+  sequence_ $ zipWith copy members members'++last :: FilePath -> Maybe FilePath+last p = case splitDirectories p of+  [] -> Nothing+  l -> Just $ List.last l

@@ -0,0 +1,13 @@+module Benchmark.Model where++import Benchmark.Prelude hiding (insert)+import qualified Data.Acid as Acid++++type Model = [[[Int]]]++insert :: [[Int]] -> Acid.Update Model ()+insert = modify . (:)++Acid.makeAcidic ''Model ['insert]

@@ -0,0 +1,42 @@+module Benchmark.Prelude +  ( +    module Prelude,+    module Control.Monad,+    module Control.Applicative,+    module Control.Arrow,+    module Data.Monoid,+    module Data.Foldable,+    module Data.Traversable,+    module Data.Maybe,+    module Data.List,+    module Data.Data,++    -- mtl+    module Control.Monad.State,+    module Control.Monad.Reader,++    -- exceptions+    module Control.Exception,+    module System.IO.Error,+  )+  where++import Prelude hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath)+import Control.Monad hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Applicative+import Control.Arrow +import Data.Monoid+import Data.Foldable+import Data.Traversable+import Data.Maybe+import Data.List hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.Data++-- mtl+import Control.Monad.State hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.Reader hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)++-- exceptions+import Control.Exception+import System.IO.Error+

@@ -0,0 +1,77 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeFamilies       #-}++module Main (main) where++import           Data.Acid++import           Control.Concurrent+import           Control.Monad.State+import           Data.SafeCopy+import           Data.Time+import           System.IO++------------------------------------------------------+-- The Haskell structure that we want to encapsulate++data SlowCheckpoint = SlowCheckpoint Int Int++$(deriveSafeCopy 0 'base ''SlowCheckpoint)++------------------------------------------------------+-- The transaction we will execute over the state.++-- This transaction adds a very computationally heavy entry+-- into our state. However, since the state is lazy, the+-- chunk will not be forced until we create a checkpoint.+-- Computing 'last [0..100000000]' takes roughly 2 seconds+-- on my machine.       XXX Lemmih, 2011-04-26+setComputationallyHeavyData :: Update SlowCheckpoint ()+setComputationallyHeavyData = do SlowCheckpoint _slow tick <- get+                                 put $ SlowCheckpoint (last [0..100000000]) tick++tick :: Update SlowCheckpoint Int+tick = do SlowCheckpoint slow tick <- get+          put $ SlowCheckpoint slow (tick+1)+          return tick++$(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick])++------------------------------------------------------+-- This is how AcidState is used:++main :: IO ()+main = do acid <- openLocalStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0)+          doTick acid+          createCheckpoint acid+          doTick acid+          createCheckpoint acid+          doTick acid+          createCheckpoint acid+          createArchive acid+          pure ()+{-+          update acid SetComputationallyHeavyData+          forkIO $ do putStrLn "Seriazing checkpoint..."+                      t <- timeIt $ createCheckpoint acid+                      t <- timeIt $ createCheckpoint acid+                      putStrLn $ "Checkpoint created in: " ++ show t+          replicateM_ 20 $+            do doTick acid+               threadDelay (10^5)+-}+--          threadDelay (10^6)+--          tick <- update acid Tick+--          threadDelay (10^6)+--          createArchive acid++doTick acid+    = do tick <- update acid Tick+         putStrLn $ "Tick: " ++ show tick++timeIt action+    = do t1 <- getCurrentTime+         ret <- action+         t2 <- getCurrentTime+         return (diffUTCTime t2 t1)

@@ -48,7 +48,7 @@   = AcidState {                 _scheduleUpdate :: forall event. (UpdateEvent event, EventState event ~ st) => event -> IO (MVar (EventResult event))               , scheduleColdUpdate :: Tagged ByteString -> IO (MVar ByteString)-              , _query :: (QueryEvent event, EventState event ~ st)  => event -> IO (EventResult event)+              , _query :: forall event. (QueryEvent event, EventState event ~ st) => event -> IO (EventResult event)               , queryCold :: Tagged ByteString -> IO ByteString               , -- | Take a snapshot of the state and save it to disk. Creating checkpoints

@@ -262,7 +262,7 @@   logFiles <- findLogFiles (logIdentifier fLog)   let sorted = sort logFiles       relevant = filterLogFiles Nothing (Just entryId) sorted \\-                 filterLogFiles (Just (entryId+1)) (Just entryId) sorted+                 filterLogFiles (Just entryId) (Just (entryId+1))  sorted    createDirectoryIfMissing True archiveDir   forM_ relevant $ \(_startEntry, logFilePath) ->

@@ -48,9 +48,17 @@          case stateInfo of            TyConI tycon              ->case tycon of+#if MIN_VERSION_template_haskell(2,11,0)+                 DataD _cxt _name tyvars _kind constructors _derivs+#else                  DataD _cxt _name tyvars constructors _derivs+#endif                    -> makeAcidic' eventNames stateName tyvars constructors+#if MIN_VERSION_template_haskell(2,11,0)+                 NewtypeD _cxt _name tyvars _kind constructor _derivs+#else                  NewtypeD _cxt _name tyvars constructor _derivs+#endif                    -> makeAcidic' eventNames stateName tyvars [constructor]                  TySynD _name tyvars _ty                    -> makeAcidic' eventNames stateName tyvars []@@ -76,7 +84,11 @@ getEventType eventName     = do eventInfo <- reify eventName          case eventInfo of+#if MIN_VERSION_template_haskell(2,11,0)+           VarI _name eventType _decl+#else            VarI _name eventType _decl _fixity+#endif              -> return eventType            _ -> error $ "Events must be functions: " ++ show eventName @@ -214,9 +226,19 @@ --  deriving (Typeable) makeEventDataType eventName eventType     = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ]+#if MIN_VERSION_template_haskell(2,11,0)+             cxt = mapM conT [''Typeable]+#else+             cxt = [''Typeable]+#endif          case args of-          [_] -> newtypeD (return []) eventStructName tyvars con [''Typeable]-          _   -> dataD (return []) eventStructName tyvars [con] [''Typeable]+#if MIN_VERSION_template_haskell(2,11,0)+          [_] -> newtypeD (return []) eventStructName tyvars Nothing con cxt+          _   -> dataD (return []) eventStructName tyvars Nothing [con] cxt+#else+          [_] -> newtypeD (return []) eventStructName tyvars con cxt+          _   -> dataD (return []) eventStructName tyvars [con] cxt+#endif     where (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []