diff --git a/acid-state.cabal b/acid-state.cabal --- a/acid-state.cabal +++ b/acid-state.cabal @@ -1,5 +1,5 @@ Name: acid-state -Version: 0.12.3 +Version: 0.12.4 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/ @@ -74,7 +74,7 @@ directory, system-fileio == 0.3.*, system-filepath, - criterion == 0.8.*, + criterion >= 0.8 && < 1.1, mtl, base, acid-state diff --git a/examples/HelloDatabase.hs b/examples/HelloDatabase.hs --- a/examples/HelloDatabase.hs +++ b/examples/HelloDatabase.hs @@ -6,7 +6,6 @@ import Data.Acid -import Control.Applicative ((<$>)) import Control.Monad.Reader (ask) import Control.Monad.State (get, put) import Data.SafeCopy diff --git a/examples/HelloWorldNoTH.hs b/examples/HelloWorldNoTH.hs --- a/examples/HelloWorldNoTH.hs +++ b/examples/HelloWorldNoTH.hs @@ -46,7 +46,7 @@ then do string <- query acid QueryState putStrLn $ "The state is: " ++ string else do update acid (WriteState (unwords args)) - putStrLn $ "The state has been modified!" + putStrLn "The state has been modified!" ------------------------------------------------------ diff --git a/examples/Proxy.hs b/examples/Proxy.hs --- a/examples/Proxy.hs +++ b/examples/Proxy.hs @@ -74,10 +74,10 @@ ["checkpoint", socket] -> do acid <- openRemote socket createCheckpoint acid - _ -> do putStrLn $ "Commands:" - putStrLn $ " server socket Start a new server instance." - putStrLn $ " proxy from to Pipe events between 'from' and 'to'." - putStrLn $ " query socket Prints out the current state." - putStrLn $ " poke socket Spawn 100k transactions." - putStrLn $ " clear socket Reset the state and write a checkpoint." - putStrLn $ " checkpoint socket Create a new checkpoint." + _ -> do putStrLn "Commands:" + putStrLn " server socket Start a new server instance." + putStrLn " proxy from to Pipe events between 'from' and 'to'." + putStrLn " query socket Prints out the current state." + putStrLn " poke socket Spawn 100k transactions." + putStrLn " clear socket Reset the state and write a checkpoint." + putStrLn " checkpoint socket Create a new checkpoint." diff --git a/examples/RemoteClient.hs b/examples/RemoteClient.hs --- a/examples/RemoteClient.hs +++ b/examples/RemoteClient.hs @@ -36,7 +36,7 @@ -> do acid <- open update acid ClearState createCheckpoint acid - _ -> do putStrLn $ "Commands:" - putStrLn $ " query Prints out the current state." - putStrLn $ " poke Spawn 100k transactions." - putStrLn $ " checkpoint Create a new checkpoint." + _ -> do putStrLn "Commands:" + putStrLn " query Prints out the current state." + putStrLn " poke Spawn 100k transactions." + putStrLn " checkpoint Create a new checkpoint." diff --git a/examples/StressTest.hs b/examples/StressTest.hs --- a/examples/StressTest.hs +++ b/examples/StressTest.hs @@ -59,7 +59,7 @@ ["clear"] -> do update acid ClearState createCheckpoint acid - _ -> do putStrLn $ "Commands:" - putStrLn $ " query Prints out the current state." - putStrLn $ " poke Spawn 100k transactions." - putStrLn $ " checkpoint Create a new checkpoint." + _ -> do putStrLn "Commands:" + putStrLn " query Prints out the current state." + putStrLn " poke Spawn 100k transactions." + putStrLn " checkpoint Create a new checkpoint." diff --git a/examples/StressTestNoTH.hs b/examples/StressTestNoTH.hs --- a/examples/StressTestNoTH.hs +++ b/examples/StressTestNoTH.hs @@ -53,10 +53,10 @@ hFlush stdout groupUpdates acid (replicate 100000 PokeState) putStrLn "Done" - _ -> do putStrLn $ "Commands:" - putStrLn $ " query Prints out the current state." - putStrLn $ " poke Spawn 100k transactions." - putStrLn $ " checkpoint Create a new checkpoint." + _ -> do putStrLn "Commands:" + putStrLn " query Prints out the current state." + putStrLn " poke Spawn 100k transactions." + putStrLn " checkpoint Create a new checkpoint." ------------------------------------------------------ -- The gritty details. These things may be done with diff --git a/examples/errors/Exceptions.hs b/examples/errors/Exceptions.hs --- a/examples/errors/Exceptions.hs +++ b/examples/errors/Exceptions.hs @@ -19,7 +19,7 @@ ------------------------------------------------------ -- The Haskell structure that we want to encapsulate -newtype MyState = MyState Integer +data MyState = MyState Integer deriving (Show, Typeable) $(deriveSafeCopy 0 'base ''MyState) @@ -36,12 +36,24 @@ stateError :: Update MyState () stateError = put (error "state error!") +stateNestedError1 :: Update MyState () +stateNestedError1 = put (MyState (error "nested state error (1)")) + +stateNestedError2 :: Integer -> Update MyState () +stateNestedError2 n = put (MyState n) + tick :: Update MyState Integer tick = do MyState n <- get put $ MyState (n+1) return n -$(makeAcidic ''MyState ['failEvent, 'errorEvent, 'stateError, 'tick]) +$(makeAcidic ''MyState [ 'failEvent + , 'errorEvent + , 'stateError + , 'stateNestedError1 + , 'stateNestedError2 + , 'tick + ]) ------------------------------------------------------ -- This is how AcidState is used: @@ -54,7 +66,9 @@ ["2"] -> update acid FailEvent ["3"] -> update acid ErrorEvent ["4"] -> update acid StateError - _ -> do putStrLn "Call with '1', '2', '3' or '4' to test error scenarios." + ["5"] -> update acid StateNestedError1 + ["6"] -> update acid (StateNestedError2 (error "nested state error (2)")) + _ -> do putStrLn "Call with [123456] to test error scenarios." putStrLn "If the tick doesn't get stuck, everything is fine." n <- update acid Tick putStrLn $ "Tick: " ++ show n diff --git a/src/Data/Acid/Core.hs b/src/Data/Acid/Core.hs --- a/src/Data/Acid/Core.hs +++ b/src/Data/Acid/Core.hs @@ -59,9 +59,13 @@ -- of base. We could do something better, but happstack-state is -- end-of-life anyway. showQualifiedTypeRep :: TypeRep -> String -showQualifiedTypeRep tr = - let (TypeRep _f con _rep) = tr - in tyConModule con ++ "." ++ show tr +showQualifiedTypeRep tr = tyConModule con ++ "." ++ show tr + where con = extractTypeRepCon tr +#if MIN_VERSION_base(4,8,0) + extractTypeRepCon (TypeRep _ c _ _) = c +#else + extractTypeRepCon (TypeRep _ c _) = c +#endif #else diff --git a/src/Data/Acid/Local.hs b/src/Data/Acid/Local.hs --- a/src/Data/Acid/Local.hs +++ b/src/Data/Acid/Local.hs @@ -26,12 +26,12 @@ import Data.Acid.Abstract import Control.Concurrent ( newEmptyMVar, putMVar, takeMVar, MVar ) -import Control.Exception ( onException ) +import Control.Exception ( onException, evaluate ) import Control.Monad.State ( runState ) import Control.Monad ( join ) import Control.Applicative ( (<$>), (<*>) ) import Data.ByteString.Lazy ( ByteString ) ---import qualified Data.ByteString.Lazy as Lazy ( length ) +import qualified Data.ByteString.Lazy as Lazy ( length ) import Data.Serialize ( runPutLazy, runGetLazy ) @@ -80,8 +80,11 @@ scheduleLocalUpdate acidState event = do mvar <- newEmptyMVar let encoded = runPutLazy (safePut event) - --evaluate (Lazy.length encoded) -- It would be best to encode the event before we lock the core - -- but it hurts performance /-: + + -- It is important that we encode the event now so that we can catch + -- any exceptions (see nestedStateError in examples/errors/Exceptions.hs) + evaluate (Lazy.length encoded) + modifyCoreState_ (localCore acidState) $ \st -> do let !(result, !st') = runState hotMethod st -- Schedule the log entry. Very important that it happens when 'localCore' is locked diff --git a/src/Data/Acid/TemplateHaskell.hs b/src/Data/Acid/TemplateHaskell.hs --- a/src/Data/Acid/TemplateHaskell.hs +++ b/src/Data/Acid/TemplateHaskell.hs @@ -141,8 +141,12 @@ where -- | rename the type variables in a Pred unify :: [(Name, Name)] -> Pred -> Pred +#if MIN_VERSION_template_haskell(2,10,0) + unify table p = rename p table p -- in 2.10.0: type Pred = Type +#else unify table p@(ClassP n tys) = ClassP n (map (rename p table) tys) unify table p@(EqualP a b) = EqualP (rename p table a) (rename p table b) +#endif -- | rename the type variables in a Type rename :: Pred -> [(Name, Name)] -> Type -> Type