acid-state 0.3.3 → 0.4

raw patch · 18 files changed

+602/−244 lines, 18 filesdep +cerealdep +safecopydep +unixdep −binarydep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: cereal, safecopy, unix

Dependencies removed: binary

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• acid-state.cabal +8/−6
• examples/HelloDatabase.hs +2/−4
• examples/HelloWorld.hs +4/−7
• examples/HelloWorldNoTH.hs +12/−12
• examples/KeyValue.hs +5/−8
• examples/KeyValueNoTH.hs +10/−10
• examples/SlowCheckpoint.hs +67/−0
• examples/StressTest.hs +17/−17
• examples/StressTestNoTH.hs +24/−23
• examples/errors/ChangeState.hs +50/−0
• examples/errors/Exceptions.hs +57/−0
• examples/errors/RemoveEvent.hs +50/−0
• src/Data/Acid.hs +4/−0
• src/Data/Acid/Archive.hs +24/−21
• src/Data/Acid/Core.hs +44/−24
• src/Data/Acid/Local.hs +100/−34
• src/Data/Acid/Log.hs +94/−48
• src/Data/Acid/TemplateHaskell.hs +30/−30

@@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented.-Version:             0.3.3+Version:             0.4  -- A short (one-line) description of the package. Synopsis:            Add ACID guarantees to any serializable Haskell data structure.@@ -37,7 +37,7 @@  -- Extra files to be distributed with the package, such as examples or -- a README.-Extra-source-files:  examples/*.hs+Extra-source-files:  examples/*.hs, examples/errors/*.hs  -- Constraint on the version of Cabal needed to build this package. Cabal-version:       >=1.6@@ -54,11 +54,13 @@                        Data.Acid.TemplateHaskell      -- Packages needed in order to build this package.-  Build-depends:       base >= 4 && < 5, binary, bytestring, stm, filepath, directory,-                       mtl, array, containers, template-haskell+  Build-depends:       base >= 4 && < 5, cereal >= 0.3.2.0, safecopy >= 0.5, bytestring, stm,+                       filepath, directory, mtl, array, containers, template-haskell, unix -  Hs-Source-Dirs:         src/-  +  Hs-Source-Dirs:      src/++  GHC-Options:         -fwarn-unused-imports -fwarn-unused-binds+   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools:            

@@ -7,14 +7,12 @@ import Control.Monad.Reader                  ( ask ) import Control.Applicative                   ( (<$>) ) import System.Environment                    ( getArgs )-import qualified Data.Binary as Binary+import Data.SafeCopy  type Message = String data Database = Database [Message] -instance Binary.Binary Database where-    get = Database <$> Binary.get-    put (Database msg) = Binary.put msg+$(deriveSafeCopy 0 'base ''Database)  -- Transactions are defined to run in either the 'Update' monad -- or the 'Query' monad.                                                                                                                                    

@@ -1,13 +1,12 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid.Core import Data.Acid -import qualified Control.Monad.State as State+import Control.Monad.State import Control.Monad.Reader import System.Environment-import Data.Binary+import Data.SafeCopy  import Data.Typeable @@ -17,16 +16,14 @@ data HelloWorldState = HelloWorldState String     deriving (Show, Typeable) -instance Binary HelloWorldState where-    put (HelloWorldState state) = put state-    get = liftM HelloWorldState get+$(deriveSafeCopy 0 'base ''HelloWorldState)  ------------------------------------------------------ -- The transaction we will execute over the state.  writeState :: String -> Update HelloWorldState () writeState newValue-    = State.put (HelloWorldState newValue)+    = put (HelloWorldState newValue)  queryState :: Query HelloWorldState String queryState = do HelloWorldState string <- ask

@@ -4,10 +4,10 @@ import Data.Acid.Core import Data.Acid.Local -import qualified Control.Monad.State as State+import Control.Monad.State import Control.Monad.Reader import System.Environment-import Data.Binary+import Data.SafeCopy  import Data.Typeable @@ -17,16 +17,16 @@ data HelloWorldState = HelloWorldState String     deriving (Show, Typeable) -instance Binary HelloWorldState where-    put (HelloWorldState state) = put state-    get = liftM HelloWorldState get+instance SafeCopy HelloWorldState where+    putCopy (HelloWorldState state) = contain $ safePut state+    getCopy = contain $ liftM HelloWorldState safeGet  ------------------------------------------------------ -- The transaction we will execute over the state.  writeState :: String -> Update HelloWorldState () writeState newValue-    = State.put (HelloWorldState newValue)+    = put (HelloWorldState newValue)  queryState :: Query HelloWorldState String queryState = do HelloWorldState string <- ask@@ -55,18 +55,18 @@   deriving instance Typeable WriteState-instance Binary WriteState where-    put (WriteState st) = put st-    get = liftM WriteState get+instance SafeCopy WriteState where+    putCopy (WriteState st) = contain $ safePut st+    getCopy = contain $ liftM WriteState safeGet instance Method WriteState where     type MethodResult WriteState = ()     type MethodState WriteState = HelloWorldState instance UpdateEvent WriteState  deriving instance Typeable QueryState-instance Binary QueryState where-    put QueryState = return ()-    get = return QueryState+instance SafeCopy QueryState where+    putCopy QueryState = contain $ return ()+    getCopy = contain $ return QueryState instance Method QueryState where     type MethodResult QueryState = String     type MethodState QueryState = HelloWorldState

@@ -1,15 +1,14 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid.Core import Data.Acid -import qualified Control.Monad.State as State+import Control.Monad.State import Control.Monad.Reader import Control.Applicative import System.Environment import System.IO-import Data.Binary+import Data.SafeCopy  import Data.Typeable @@ -24,17 +23,15 @@ data KeyValue = KeyValue !(Map.Map Key Value)     deriving (Typeable) -instance Binary KeyValue where-    put (KeyValue state) = put state-    get = liftM KeyValue get+$(deriveSafeCopy 0 'base ''KeyValue)  ------------------------------------------------------ -- The transaction we will execute over the state.  insertKey :: Key -> Value -> Update KeyValue () insertKey key value-    = do KeyValue m <- State.get-         State.put (KeyValue (Map.insert key value m))+    = do KeyValue m <- get+         put (KeyValue (Map.insert key value m))  lookupKey :: Key -> Query KeyValue (Maybe Value) lookupKey key

@@ -9,7 +9,7 @@ import Control.Applicative import System.Environment import System.IO-import Data.Binary+import Data.SafeCopy  import Data.Typeable @@ -24,9 +24,9 @@ data KeyValue = KeyValue !(Map.Map Key Value)     deriving (Typeable) -instance Binary KeyValue where-    put (KeyValue state) = put state-    get = liftM KeyValue get+instance SafeCopy KeyValue where+    putCopy (KeyValue state) = contain $ safePut state+    getCopy = contain $ liftM KeyValue safeGet  ------------------------------------------------------ -- The transaction we will execute over the state.@@ -72,18 +72,18 @@   deriving instance Typeable InsertKey-instance Binary InsertKey where-    put (InsertKey key value) = put key >> put value-    get = InsertKey <$> get <*> get+instance SafeCopy InsertKey where+    putCopy (InsertKey key value) = contain $ safePut key >> safePut value+    getCopy = contain $ InsertKey <$> safeGet <*> safeGet instance Method InsertKey where     type MethodResult InsertKey = ()     type MethodState InsertKey = KeyValue instance UpdateEvent InsertKey  deriving instance Typeable LookupKey-instance Binary LookupKey where-    put (LookupKey key) = put key-    get = LookupKey <$> get+instance SafeCopy LookupKey where+    putCopy (LookupKey key) = contain $ safePut key+    getCopy = contain $ LookupKey <$> safeGet instance Method LookupKey where     type MethodResult LookupKey = Maybe Value     type MethodState LookupKey = KeyValue

@@ -0,0 +1,67 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}+module Main (main) where++import Data.Acid++import Control.Monad.State+import Control.Concurrent+import Data.Time+import System.IO+import Data.SafeCopy++------------------------------------------------------+-- 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 <- openAcidStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0)+          putStrLn "This example illustrates that the state is still accessible while"+          putStrLn "a checkpoint is being serialized. This is an important property when"+          putStrLn "the size of a checkpoint reaches several hundred megabytes."+          putStrLn "If you don't see any ticks while the creating is being created, something"+          putStrLn "has gone awry."+          putStrLn ""+          doTick acid+          update acid SetComputationallyHeavyData+          forkIO $ do putStrLn "Seriazing checkpoint..."+                      t <- timeIt $ createCheckpoint acid+                      putStrLn $ "Checkpoint created in: " ++ show t+          replicateM_ 20 $+            do doTick acid+               threadDelay (10^5)++doTick acid+    = do tick <- update acid Tick+         putStrLn $ "Tick: " ++ show tick++timeIt action+    = do t1 <- getCurrentTime+         ret <- action+         t2 <- getCurrentTime+         return (diffUTCTime t2 t1)

@@ -1,14 +1,14 @@ {-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-} module Main (main) where -import Data.Acid.Core import Data.Acid+import Data.Acid.Local -import qualified Control.Monad.State as State+import Control.Monad.State import Control.Monad.Reader import System.Environment import System.IO-import Data.Binary+import Data.SafeCopy  import Data.Typeable @@ -16,18 +16,16 @@ -- The Haskell structure that we want to encapsulate  data StressState = StressState !Int-    deriving (Show, Typeable)+    deriving (Typeable) -instance Binary StressState where-    put (StressState state) = put state-    get = liftM StressState get+$(deriveSafeCopy 0 'base ''StressState)  ------------------------------------------------------ -- The transaction we will execute over the state.  pokeState :: Update StressState ()-pokeState = do StressState i <- State.get-               State.put (StressState (i+1))+pokeState = do StressState i <- get+               put (StressState (i+1))  queryState :: Query StressState Int queryState = do StressState i <- ask@@ -39,21 +37,23 @@ -- This is how AcidState is used:  main :: IO ()-main = do acid <- openAcidState (StressState 0)-          args <- getArgs+main = do args <- getArgs           case args of             ["checkpoint"]-              -> createCheckpoint acid+              -> do acid <- openAcidState (StressState 0)+                    createCheckpoint acid             ["query"]-              -> do n <- query acid QueryState+              -> do acid <- openAcidState (StressState 0)+                    n <- query acid QueryState                     putStrLn $ "State value: " ++ show n             ["poke"]-              -> do putStr "Issuing 10k sequential transactions... "+              -> do acid <- openAcidState (StressState 0)+                    putStr "Issuing 100k transactions... "                     hFlush stdout-                    replicateM_ 10000 (update acid PokeState)+                    replicateM_ (100000-1) (scheduleUpdate acid PokeState)+                    update acid PokeState                     putStrLn "Done"             _ -> do putStrLn $ "Commands:"                     putStrLn $ "  query            Prints out the current state."-                    putStrLn $ "  poke             Spawn 10k transactions."+                    putStrLn $ "  poke             Spawn 100k transactions."                     putStrLn $ "  checkpoint       Create a new checkpoint."-          closeAcidState acid

@@ -4,11 +4,11 @@ import Data.Acid.Core import Data.Acid.Local -import qualified Control.Monad.State as State+import Control.Monad.State import Control.Monad.Reader import System.Environment import System.IO-import Data.Binary+import Data.SafeCopy  import Data.Typeable @@ -16,18 +16,18 @@ -- The Haskell structure that we want to encapsulate  data StressState = StressState !Int-    deriving (Show, Typeable)+    deriving (Typeable) -instance Binary StressState where-    put (StressState state) = put state-    get = liftM StressState get+instance SafeCopy StressState where+    putCopy (StressState state) = contain $ safePut state+    getCopy = contain $ liftM StressState safeGet  ------------------------------------------------------ -- The transaction we will execute over the state.  pokeState :: Update StressState ()-pokeState = do StressState i <- State.get-               State.put (StressState (i+1))+pokeState = do StressState i <- get+               put (StressState (i+1))  queryState :: Query StressState Int queryState = do StressState i <- ask@@ -38,27 +38,28 @@ -- This is how AcidState is used:  main :: IO ()-main = do acid <- openAcidState (StressState 0)-          args <- getArgs+main = do args <- getArgs           case args of             ["checkpoint"]-              -> createCheckpoint acid+              -> do acid <- openAcidState (StressState 0)+                    createCheckpoint acid             ["query"]-              -> do n <- query acid QueryState+              -> do acid <- openAcidState (StressState 0)+                    n <- query acid QueryState                     putStrLn $ "State value: " ++ show n             ["poke"]-              -> do putStr "Issuing 10k sequential transactions... "+              -> do acid <- openAcidState (StressState 0)+                    putStr "Issuing 100k transactions... "                     hFlush stdout-                    replicateM_ 10000 (update acid PokeState)+                    replicateM_ (100000-1) (scheduleUpdate acid PokeState)+                    update acid PokeState                     putStrLn "Done"             _ -> do putStrLn $ "Commands:"                     putStrLn $ "  query            Prints out the current state."-                    putStrLn $ "  poke             Spawn 10k transactions."+                    putStrLn $ "  poke             Spawn 100k transactions."                     putStrLn $ "  checkpoint       Create a new checkpoint."-          closeAcidState acid  - ------------------------------------------------------ -- The gritty details. These things may be done with -- Template Haskell in the future.@@ -68,18 +69,18 @@   deriving instance Typeable PokeState-instance Binary PokeState where-    put PokeState = return ()-    get = return PokeState+instance SafeCopy PokeState where+    putCopy PokeState = contain $ return ()+    getCopy = contain $ return PokeState instance Method PokeState where     type MethodResult PokeState = ()     type MethodState PokeState = StressState instance UpdateEvent PokeState  deriving instance Typeable QueryState-instance Binary QueryState where-    put QueryState = return ()-    get = return QueryState+instance SafeCopy QueryState where+    putCopy QueryState = contain $ return ()+    getCopy = contain $ return QueryState instance Method QueryState where     type MethodResult QueryState = Int     type MethodState QueryState = StressState

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}+module Main (main) where++import Data.Acid++import Control.Monad.State+import System.Environment+import Data.SafeCopy++import Data.Typeable++import Control.Exception+import Prelude hiding (catch)++import qualified Data.Text as Text+++------------------------------------------------------+-- The Haskell structure that we want to encapsulate++data FirstState = FirstState String+    deriving (Show)++data SecondState = SecondState Text.Text+    deriving (Show)++$(deriveSafeCopy 0 'base ''FirstState)+$(deriveSafeCopy 0 'base ''SecondState)++------------------------------------------------------+-- The transaction we will execute over the state.++$(makeAcidic ''FirstState [])+$(makeAcidic ''SecondState [])++------------------------------------------------------+-- This is how AcidState is used:++main :: IO ()+main = do putStrLn "This example simulates what happens when you modify your state type"+          putStrLn "without telling AcidState how to migrate from the old version to the new."+          putStrLn "Hopefully this program will fail with a readable error message."+          putStrLn ""+          firstAcid <- openAcidStateFrom "state/ChangeState" (FirstState "first state")+          createCheckpoint firstAcid+          closeAcidState firstAcid++          secondAcid <- openAcidStateFrom "state/ChangeState" (SecondState (Text.pack "This initial value shouldn't be used"))+          closeAcidState secondAcid+          putStrLn "If you see this message then something has gone wrong!"

@@ -0,0 +1,57 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}+module Main (main) where++import Data.Acid++import Control.Monad.State+import System.Environment+import Data.SafeCopy++import Data.Typeable++import Control.Exception+import Prelude hiding (catch)++------------------------------------------------------+-- The Haskell structure that we want to encapsulate++newtype MyState = MyState Integer+    deriving (Show, Typeable)++$(deriveSafeCopy 0 'base ''MyState)++------------------------------------------------------+-- The transaction we will execute over the state.++failEvent :: Update MyState ()+failEvent = fail "fail!"++errorEvent :: Update MyState ()+errorEvent = error "error!"++stateError :: Update MyState ()+stateError = put (error "state error!")++tick :: Update MyState Integer+tick = do MyState n <- get+          put $ MyState (n+1)+          return n++$(makeAcidic ''MyState ['failEvent, 'errorEvent, 'stateError, 'tick])++------------------------------------------------------+-- This is how AcidState is used:++main :: IO ()+main = do acid <- openAcidStateFrom "state/Exceptions" (MyState 0)+          args <- getArgs+          case args of+            ["1"] -> update acid (undefined :: FailEvent)+            ["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."+                        n <- update acid Tick+                        putStrLn $ "Tick: " ++ show n+           `catch` \e -> do putStrLn $ "Caught exception: " ++ show (e:: SomeException)+                            createCheckpointAndClose acid

@@ -0,0 +1,50 @@+{-# LANGUAGE DeriveDataTypeable, TypeFamilies, TemplateHaskell #-}+module Main (main) where++import Data.Acid++import Control.Monad.State+import System.Environment+import Data.SafeCopy++import Data.Typeable++import Control.Exception+import Prelude hiding (catch)++------------------------------------------------------+-- The Haskell structure that we want to encapsulate++data FirstState = FirstState+    deriving (Show)++data SecondState = SecondState+    deriving (Show)++$(deriveSafeCopy 0 'base ''FirstState)+$(deriveSafeCopy 0 'base ''SecondState)++------------------------------------------------------+-- The transaction we will execute over the state.++firstEvent :: Update FirstState ()+firstEvent = return ()++$(makeAcidic ''FirstState ['firstEvent])+$(makeAcidic ''SecondState [])++------------------------------------------------------+-- This is how AcidState is used:++main :: IO ()+main = do putStrLn "This example simulates what happens when you remove an event"+          putStrLn "that is required to replay the journal."+          putStrLn "Hopefully this program will fail with a readable error message."+          putStrLn ""+          firstAcid <- openAcidStateFrom "state/RemoveEvent" FirstState+          update firstAcid FirstEvent+          closeAcidState firstAcid++          secondAcid <- openAcidStateFrom "state/RemoveEvent" SecondState+          closeAcidState secondAcid+          putStrLn "If you see this message then something has gone wrong!"

@@ -19,9 +19,13 @@     , openAcidStateFrom     , closeAcidState     , createCheckpoint+    , createCheckpointAndClose     , update     , query+    , update'+    , query'     , EventResult+    , EventState     , UpdateEvent     , QueryEvent     , Update

@@ -17,8 +17,9 @@  import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString as Strict-import Data.Binary.Get-import Data.Binary.Builder+import qualified Data.Serialize.Get as Serialize+import Data.Serialize.Get hiding (Result(..))+import Data.Serialize.Builder import Data.Monoid  type Entry = Lazy.ByteString@@ -51,23 +52,25 @@  readEntries :: Lazy.ByteString -> Entries readEntries bs-    | Lazy.null bs-    = Done-    | Lazy.length header < headerSize-    = Fail "Incomplete header."-    | Lazy.length content /= fromIntegral contentLength-    = Fail "Insuficient content."-    | crc16 content /= contentHash-    = Fail "Invalid hash"-    | otherwise-    = Next content (readEntries rest)-    where header        = Lazy.take headerSize bs-          headerSize    = 10-          contentLength = fromIntegral $ runGet getWord64le header-          contentHash   = runGet getWord16le $ Lazy.drop 8 header-          content       = Lazy.take contentLength $ Lazy.drop headerSize bs-          rest          = Lazy.drop (contentLength+headerSize) bs--lazyToStrict :: Lazy.ByteString -> Strict.ByteString-lazyToStrict = Strict.concat . Lazy.toChunks+    = worker (Lazy.toChunks bs)+    where worker [] = Done+          worker (x:xs)+              = check (runGetPartial readEntry x) xs+          check result more+              = case result of+                  Serialize.Done entry rest+                      | Strict.null rest    -> Next entry (worker more)+                      | otherwise           -> Next entry (worker (rest:more))+                  Serialize.Fail msg        -> Fail msg+                  Serialize.Partial cont    -> case more of+                                                 []     -> check (cont Strict.empty) []+                                                 (x:xs) -> check (cont x) xs +readEntry :: Get Entry+readEntry+    = do contentLength <- getWord64le+         contentChecksum <-getWord16le+         content <- getLazyByteString (fromIntegral contentLength)+         if crc16 content /= contentChecksum+           then fail "Invalid hash"+           else return content

@@ -23,6 +23,7 @@     , Tagged     , mkCore     , closeCore+    , closeCore'     , modifyCoreState     , modifyCoreState_     , withCoreState@@ -32,37 +33,37 @@     , runColdMethod     ) where -import Control.Concurrent-import Control.Monad-import Control.Monad.State (State, runState )+import Control.Concurrent                 ( MVar, newMVar, withMVar+                                          , modifyMVar, modifyMVar_ )+import Control.Monad                      ( liftM )+import Control.Monad.State                ( State, runState ) import qualified Data.Map as Map-import qualified Data.ByteString.Lazy as Lazy-import qualified Data.ByteString.Lazy.Char8 as Lazy.Char8+import Data.ByteString.Lazy as Lazy       ( ByteString )+import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack ) -import Data.Binary+import Data.Serialize                     ( runPutLazy, runGetLazy )+import Data.SafeCopy                      ( SafeCopy, safeGet, safePut ) -import Data.Typeable-import Unsafe.Coerce (unsafeCoerce)+import Data.Typeable                      ( Typeable, typeOf )+import Unsafe.Coerce                      ( unsafeCoerce )   -- | The basic Method class. Each Method has an indexed result type --   and a unique tag.-class ( Typeable ev, Binary ev-      , Typeable (MethodResult ev), Binary (MethodResult ev)) =>+class ( Typeable ev, SafeCopy ev+      , Typeable (MethodResult ev), SafeCopy (MethodResult ev)) =>       Method ev where     type MethodResult ev     type MethodState ev     methodTag :: ev -> Tag-    methodTag ev = Lazy.Char8.pack (show (typeOf ev))+    methodTag ev = Lazy.pack (show (typeOf ev))  -- | The control structure at the very center of acid-state. --   This module provides access to a mutable state through --   methods. No efforts towards durability, checkpointing or --   sharding happens at this level. --   Important things to keep in mind in this module:--- --     * We don't distinguish between updates and queries.--- --     * We allow direct access to the core state as well --       as through events. data Core st@@ -82,16 +83,23 @@ -- | Mark Core as closed. Any subsequent use will throw an exception. closeCore :: Core st -> IO () closeCore core-    = do swapMVar (coreState core) errorMsg-         return ()+    = closeCore' core (\_st -> return ())++-- | Access the state and then mark the Core as closed. Any subsequent use+--   will throw an exception.+closeCore' :: Core st -> (st -> IO ()) -> IO ()+closeCore' core action+    = modifyMVar_ (coreState core) $ \st ->+      do action st+         return errorMsg     where errorMsg = error "Access failure: Core closed."  -- | Modify the state component. The resulting state is ensured to be in --   WHNF. modifyCoreState :: Core st -> (st -> IO (st, a)) -> IO a modifyCoreState core action-    = modifyMVar (coreState core) $ \st -> do (!st, a) <- action st-                                              return (st, a)+    = modifyMVar (coreState core) $ \st -> do (!st', a) <- action st+                                              return (st', a)  -- | Modify the state component. The resulting state is ensured to be in --   WHNF.@@ -118,13 +126,25 @@          return ( st', a)  -- | Find the state action that corresponds to a tagged and serialized method.-lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> (State st Lazy.ByteString)-lookupColdMethod core (methodTag, methodContent)-    = case Map.lookup methodTag (coreMethods core) of-        Nothing      -> error $ "Method tag doesn't exist: " ++ show methodTag+lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> State st Lazy.ByteString+lookupColdMethod core (storedMethodTag, methodContent)+    = case Map.lookup storedMethodTag (coreMethods core) of+        Nothing      -> missingMethod storedMethodTag         Just (Method method)-          -> liftM encode (method (decode methodContent))-      +          -> liftM (runPutLazy . safePut) (method (lazyDecode methodContent))++lazyDecode :: SafeCopy a => Lazy.ByteString -> a+lazyDecode inp+    = case runGetLazy safeGet inp of+        Left msg  -> error msg+        Right val -> val++missingMethod :: Tag -> a+missingMethod tag+    = error msg+    where msg = "This method is required but not available: " ++ show (Lazy.unpack tag) +++                ". Did you perhaps remove it before creating a checkpoint?"+ -- | Apply an in-memory method to the state. runHotMethod :: Method method => Core (MethodState method) -> method -> IO (MethodResult method) runHotMethod core method@@ -136,7 +156,7 @@ lookupHotMethod :: Method method => Core (MethodState method) -> method -> State (MethodState method) (MethodResult method) lookupHotMethod core method     = case Map.lookup (methodTag method) (coreMethods core) of-        Nothing -> error $ "Method type doesn't exist: " ++ show (typeOf method)+        Nothing -> missingMethod (methodTag method)         Just (Method methodHandler)           -> -- If the methodTag doesn't index the right methodHandler then we're in deep              -- trouble. Luckly, it would take deliberate malevolence for that to happen.

@@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, OverloadedStrings, DeriveDataTypeable, TypeFamilies,-             MagicHash, GeneralizedNewtypeDeriving #-}+             GeneralizedNewtypeDeriving, BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module      :  Data.Acid.Local@@ -18,6 +18,7 @@     , AcidState     , Event(..)     , EventResult+    , EventState     , UpdateEvent     , QueryEvent     , Update@@ -26,23 +27,33 @@     , openAcidStateFrom     , closeAcidState     , createCheckpoint+    , createCheckpointAndClose     , update+    , scheduleUpdate     , query+    , update'+    , query'     ) where  import Data.Acid.Log as Log import Data.Acid.Core -import Control.Concurrent-import qualified Control.Monad.State as State-import Control.Monad.Reader-import Control.Applicative-import qualified Data.ByteString.Lazy as Lazy+import Control.Concurrent             ( newEmptyMVar, putMVar, takeMVar, MVar )+--import Control.Exception              ( evaluate )+import Control.Monad.State            ( MonadState, State, get, runState )+import Control.Monad.Reader           ( Reader, runReader, MonadReader )+import Control.Monad.Trans            ( MonadIO(liftIO) )+import Control.Applicative            ( (<$>), (<*>) )+import Data.ByteString.Lazy           ( ByteString )+--import qualified Data.ByteString.Lazy as Lazy ( length ) -import Data.Binary-import Data.Typeable-import System.FilePath +import Data.Serialize                 ( runPutLazy, runGetLazy )+import Data.SafeCopy                  ( SafeCopy(..), safeGet, safePut+                                      , primitive, contain )+import Data.Typeable                  ( Typeable, typeOf )+import System.FilePath                ( (</>) )+ -- | Events return the same thing as Methods. The exact type of 'EventResult' --   depends on the event. type EventResult ev = MethodResult ev@@ -70,7 +81,7 @@ eventsToMethods = map worker     where worker :: Event st -> MethodContainer st           worker (UpdateEvent fn) = Method (unUpdate . fn)-          worker (QueryEvent fn)  = Method (\ev -> do st <- State.get+          worker (QueryEvent fn)  = Method (\ev -> do st <- get                                                       return (runReader (unQuery $ fn ev) st)                                            ) {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)@@ -89,13 +100,13 @@ -} data AcidState st     = AcidState { localCore        :: Core st-                , localEvents      :: FileLog (Tagged Lazy.ByteString)+                , localEvents      :: FileLog (Tagged ByteString)                 , localCheckpoints :: FileLog Checkpoint                 }  -- | Context monad for Update events.-newtype Update st a = Update { unUpdate :: State.State st a }-    deriving (Monad, State.MonadState st)+newtype Update st a = Update { unUpdate :: State st a }+    deriving (Monad, MonadState st)  -- | Context monad for Query events. newtype Query st a  = Query { unQuery :: Reader st a }@@ -108,48 +119,98 @@ --   It's a run-time error to issue events that aren't supported by the AcidState. update :: UpdateEvent event => AcidState (EventState event) -> event -> IO (EventResult event) update acidState event+    = takeMVar =<< scheduleUpdate acidState event++-- | Issue an Update event and return immediately. The event is not durable+--   before the MVar has been filled but the order of events is honored.+--   The behavior in case of exceptions is exactly the same as for 'update'.+--+--   If EventA is scheduled before EventB, EventA /will/ be executed before EventB:+--+--   @+--do scheduleUpdate acid EventA+--   scheduleUpdate acid EventB+--   @+scheduleUpdate :: UpdateEvent event => AcidState (EventState event) -> event -> IO (MVar (EventResult event))+scheduleUpdate acidState event     = do mvar <- newEmptyMVar-         let encodedEvent = encode event-         Lazy.length encodedEvent `seq`-           modifyCoreState_ (localCore acidState) $ \st ->-             do let !(result, st') = State.runState hotMethod st-                -- Schedule the log entry. Very important that it happens when 'localCore' is locked-                -- to ensure that events are logged in the same order that they are executed.-                pushEntry (localEvents acidState) (methodTag event, encodedEvent) $ putMVar mvar result-                return st'-         takeMVar mvar+         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 /-:+         modifyCoreState_ (localCore acidState) $ \st ->+           do let !(result, !st') = runState hotMethod st+              -- Schedule the log entry. Very important that it happens when 'localCore' is locked+              -- to ensure that events are logged in the same order that they are executed.+              pushEntry (localEvents acidState) (methodTag event, encoded) $ putMVar mvar result+              return st'+         return mvar     where hotMethod = lookupHotMethod (localCore acidState) event +-- | Same as 'update' but lifted into any monad capable of doing IO.+update' :: (UpdateEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event)+update' acidState event+    = liftIO (update acidState event)+ -- | Issue a Query event and wait for its result. Events may be issued in parallel. query  :: QueryEvent event  => AcidState (EventState event) -> event -> IO (EventResult event) query acidState event-    = runHotMethod (localCore acidState) event+    = do mvar <- newEmptyMVar+         withCoreState (localCore acidState) $ \st ->+           do let (result, _st) = runState hotMethod st+              -- Make sure that we do not return the result before the event log has+              -- been flushed to disk.+              pushAction (localEvents acidState) $+                putMVar mvar result+         takeMVar mvar+    where hotMethod = lookupHotMethod (localCore acidState) event +-- | Same as 'query' but lifted into any monad capable of doing IO.+query' :: (QueryEvent event, MonadIO m) => AcidState (EventState event) -> event -> m (EventResult event)+query' acidState event+    = liftIO (query acidState event)+ -- | Take a snapshot of the state and save it to disk. Creating checkpoints --   makes it faster to resume AcidStates and you're free to create them as --   often or seldom as fits your needs. Transactions can run concurrently --   with this call. --    --   This call will not return until the operation has succeeded.-createCheckpoint :: Binary st => AcidState st -> IO ()+createCheckpoint :: SafeCopy st => AcidState st -> IO () createCheckpoint acidState     = do mvar <- newEmptyMVar          withCoreState (localCore acidState) $ \st ->            do eventId <- askCurrentEntryId (localEvents acidState)-              pushEntry (localCheckpoints acidState) (Checkpoint eventId (encode st)) (putMVar mvar ())+              pushAction (localEvents acidState) $+                do let encoded = runPutLazy (safePut st)+                   pushEntry (localCheckpoints acidState) (Checkpoint eventId encoded) (putMVar mvar ())          takeMVar mvar-          +-- | Save a snapshot to disk and close the AcidState as a single atomic+--   action. This is useful when you want to make sure that no events+--   are saved to disk after a checkpoint.+createCheckpointAndClose :: SafeCopy st => AcidState st -> IO ()+createCheckpointAndClose acidState+    = do mvar <- newEmptyMVar+         closeCore' (localCore acidState) $ \st ->+           do eventId <- askCurrentEntryId (localEvents acidState)+              pushAction (localEvents acidState) $+                pushEntry (localCheckpoints acidState) (Checkpoint eventId (runPutLazy (safePut st))) (putMVar mvar ())+         takeMVar mvar+         closeFileLog (localEvents acidState)+         closeFileLog (localCheckpoints acidState) -data Checkpoint = Checkpoint EntryId Lazy.ByteString -instance Binary Checkpoint where-    put (Checkpoint eventEntryId content)-        = do put eventEntryId-             put content-    get = Checkpoint <$> get <*> get+data Checkpoint = Checkpoint EntryId ByteString -class (Binary st) => IsAcidic st where+instance SafeCopy Checkpoint where+    kind = primitive+    putCopy (Checkpoint eventEntryId content)+        = contain $+          do safePut eventEntryId+             safePut content+    getCopy = contain $ Checkpoint <$> safeGet <*> safeGet++class (SafeCopy st) => IsAcidic st where     acidEvents :: [Event st]       -- ^ List of events capable of updating or querying the state. @@ -184,7 +245,9 @@                 Nothing                   -> return 0                 Just (Checkpoint eventCutOff content)-                  -> do modifyCoreState_ core (\_oldState -> return (decode content))+                  -> do modifyCoreState_ core (\_oldState -> case runGetLazy safeGet content of+                                                               Left msg  -> checkpointRestoreError msg+                                                               Right val -> return val)                         return eventCutOff                    eventsLog <- openFileLog eventsLogKey@@ -195,6 +258,9 @@                           , localEvents = eventsLog                           , localCheckpoints = checkpointsLog                           }++checkpointRestoreError msg+    = error $ "Could not parse saved checkpoint due to the following error: " ++ msg  -- | Close an AcidState and associated logs. --   Any subsequent usage of the AcidState will throw an exception.

@@ -1,3 +1,4 @@+{-# LANGUAGE ForeignFunctionInterface #-} -- A log is a stack of entries that supports efficient pushing of -- new entries and fetching of old. It can be considered an -- extendible array of entries.@@ -9,6 +10,7 @@     , openFileLog     , closeFileLog     , pushEntry+    , pushAction     , readEntriesFrom     , newestEntry     , askCurrentEntryId@@ -18,14 +20,21 @@ import System.Directory import System.FilePath import System.IO+import System.Posix                              ( handleToFd, Fd(..), fdWriteBuf+                                                 , closeFd )+import Foreign.C+import Foreign.Ptr import Control.Monad import Control.Concurrent import Control.Concurrent.STM import qualified Data.ByteString.Lazy as Lazy---import qualified Data.ByteString as Strict+import qualified Data.ByteString as Strict+import qualified Data.ByteString.Unsafe as Strict import Data.List import Data.Maybe-import Data.Binary+import qualified Data.Serialize.Get as Get+import qualified Data.Serialize.Put as Put+import Data.SafeCopy                             ( safePut, safeGet, SafeCopy )  import Text.Printf                               ( printf ) @@ -36,7 +45,7 @@  data FileLog object     = FileLog { logIdentifier  :: LogKey object-              , logCurrent     :: MVar (Handle)+              , logCurrent     :: MVar Fd -- Handle               , logNextEntryId :: TVar EntryId               , logQueue       :: TVar ([Lazy.ByteString], [IO ()])               , logThreads     :: [ThreadId]@@ -76,23 +85,28 @@          queue <- newTVarIO ([], [])          nextEntryRef <- newTVarIO 0          tid2 <- forkIO $ fileWriter currentState queue-         let log = FileLog { logIdentifier  = identifier-                           , logCurrent     = currentState-                           , logNextEntryId = nextEntryRef-                           , logQueue       = queue-                           , logThreads     = [tid2] }+         let fLog = FileLog { logIdentifier  = identifier+                            , logCurrent     = currentState+                            , logNextEntryId = nextEntryRef+                            , logQueue       = queue+                            , logThreads     = [tid2] }          if null logFiles             then do let currentEntryId = 0                     currentHandle <- openBinaryFile (logDirectory identifier </> formatLogFile (logPrefix identifier) currentEntryId) WriteMode-                    putMVar currentState currentHandle+                    fd <- handleToFd currentHandle+                    putMVar currentState fd             else do let (lastFileEntryId, lastFilePath) = maximum logFiles                     entries <- readEntities lastFilePath                     let currentEntryId = lastFileEntryId + length entries                     atomically $ writeTVar nextEntryRef currentEntryId-                    currentHandle <- openFile (logDirectory identifier </> formatLogFile (logPrefix identifier) currentEntryId) WriteMode-                    putMVar currentState currentHandle-         return log+                    currentHandle <- openBinaryFile (logDirectory identifier </> formatLogFile (logPrefix identifier) currentEntryId) WriteMode+                    fd <- handleToFd currentHandle+                    putMVar currentState fd+         return fLog +foreign import ccall "fsync" c_fsync :: CInt -> IO CInt++fileWriter :: MVar Fd -> TVar ([Lazy.ByteString], [IO ()]) -> IO () fileWriter currentState queue     = forever $       do (entries, actions) <- atomically $ do (entries, actions) <- readTVar queue@@ -101,20 +115,39 @@                                                -- We don't actually have to reverse the actions                                                -- but I don't think it hurts performance much.                                                return (reverse entries, reverse actions)-         withMVar currentState $ \handle ->+         withMVar currentState $ \fd ->            do let arch = Archive.packEntries entries-              Lazy.hPutStr handle arch-              hFlush handle-              return ()+              writeToDisk fd (repack arch)          sequence_ actions          yield +-- Repack a lazy bytestring into larger blocks that can be efficiently written to disk.+repack :: Lazy.ByteString -> [Strict.ByteString]+repack = worker+    where worker bs+              | Lazy.null bs = []+              | otherwise    = Strict.concat (Lazy.toChunks (Lazy.take blockSize bs)) : worker (Lazy.drop blockSize bs)+          blockSize = 4*1024 +writeToDisk :: Fd -> [Strict.ByteString] -> IO ()+writeToDisk _ [] = return ()+writeToDisk fd@(Fd c_fd) xs+    = do mapM_ worker xs+         c_fsync c_fd+         return ()+    where worker bs+              = do let len = Strict.length bs+                   count <- Strict.unsafeUseAsCString bs $ \ptr -> fdWriteBuf fd (castPtr ptr) (fromIntegral len)+                   if fromIntegral count < len+                      then worker (Strict.drop (fromIntegral count) bs)+                      else return ()++ closeFileLog :: FileLog object -> IO ()-closeFileLog log-    = modifyMVar_ (logCurrent log) $ \handle ->-      do hClose handle-         forkIO $ forM_ (logThreads log) killThread+closeFileLog fLog+    = modifyMVar_ (logCurrent fLog) $ \fd ->+      do closeFd fd+         _ <- forkIO $ forM_ (logThreads fLog) killThread          return $ error "FileLog has been closed"  readEntities :: FilePath -> IO [Lazy.ByteString]@@ -129,13 +162,13 @@ -- Read all durable entries younger than the given EntryId. -- Note that entries written during or after this call won't -- be included in the returned list.-readEntriesFrom :: Binary object => FileLog object -> EntryId -> IO [object]-readEntriesFrom log youngestEntry+readEntriesFrom :: SafeCopy object => FileLog object -> EntryId -> IO [object]+readEntriesFrom fLog youngestEntry     = do -- Cut the log so we can read written entries without interfering          -- with the writing of new entries.-         entryCap <- cutFileLog log+         entryCap <- cutFileLog fLog          -- We're interested in these entries: youngestEntry <= x < entryCap.-         logFiles <- findLogFiles (logIdentifier log)+         logFiles <- findLogFiles (logIdentifier fLog)          let sorted = sort logFiles              findRelevant [] = []              findRelevant [ logFile ]@@ -156,9 +189,9 @@                               []                     -> 0                               ( logFile : _logFiles) -> rangeStart logFile -         archive <- liftM Lazy.concat $ mapM Lazy.readFile (map snd relevant)+         archive <- liftM Lazy.concat $ mapM (Lazy.readFile . snd) relevant          let entries = entriesToList $ readEntries archive-         return $ map decode+         return $ map decode'                 $ take (entryCap - youngestEntry)             -- Take events under the eventCap.                 $ drop (youngestEntry - firstEntryId) entries -- Drop entries that are too young. @@ -166,39 +199,37 @@   cutFileLog :: FileLog object -> IO EntryId-cutFileLog log+cutFileLog fLog     = do mvar <- newEmptyMVar          let action = do currentEntryId <- atomically $-                                           do (entries, _) <- readTVar (logQueue log)-                                              next <- readTVar (logNextEntryId log)+                                           do (entries, _) <- readTVar (logQueue fLog)+                                              next <- readTVar (logNextEntryId fLog)                                               return (next - length entries)-                         modifyMVar_ (logCurrent log) $ \old ->-                           do hClose old-                              openFile (logDirectory key </> formatLogFile (logPrefix key) currentEntryId) WriteMode+                         modifyMVar_ (logCurrent fLog) $ \old ->+                           do closeFd old+                              handleToFd =<< openBinaryFile (logDirectory key </> formatLogFile (logPrefix key) currentEntryId) WriteMode                          putMVar mvar currentEntryId-         atomically $-           do (entries, actions) <- readTVar (logQueue log)-              writeTVar (logQueue log) (entries, action : actions)+         pushAction fLog action          takeMVar mvar-    where key = logIdentifier log+    where key = logIdentifier fLog  -- Finds the newest entry in the log. Doesn't work on open logs. -- Do not use after the log has been opened. -- Implementation: Search the newest log files first. Once a file --                 containing at least one valid entry is found, --                 return the last entry in that file.-newestEntry :: Binary object => LogKey object -> IO (Maybe object)+newestEntry :: SafeCopy object => LogKey object -> IO (Maybe object) newestEntry identifier     = do logFiles <- findLogFiles identifier          let sorted = reverse $ sort logFiles-             (eventIds, files) = unzip sorted+             (_eventIds, files) = unzip sorted          archives <- mapM Lazy.readFile files          return $ worker archives     where worker [] = Nothing           worker (archive:archives)               = case Archive.readEntries archive of                   Done            -> worker archives-                  Next entry next -> Just (decode (lastEntry entry next))+                  Next entry next -> Just (decode' (lastEntry entry next))                   Fail{}          -> worker archives           lastEntry entry Done   = entry           lastEntry entry Fail{} = entry@@ -207,15 +238,30 @@ -- Schedule a new log entry. This call does not block -- The given IO action runs once the object is durable. The IO action -- blocks the serialization of events so it should be swift.-pushEntry :: Binary object => FileLog object -> object -> IO () -> IO ()-pushEntry log object finally+pushEntry :: SafeCopy object => FileLog object -> object -> IO () -> IO ()+pushEntry fLog object finally     = atomically $-      do tid <- readTVar (logNextEntryId log)-         writeTVar (logNextEntryId log) (tid+1)-         (entries, actions) <- readTVar (logQueue log)-         writeTVar (logQueue log) ( encoded : entries, finally : actions )-    where encoded = encode object+      do tid <- readTVar (logNextEntryId fLog)+         writeTVar (logNextEntryId fLog) (tid+1)+         (entries, actions) <- readTVar (logQueue fLog)+         writeTVar (logQueue fLog) ( encoded : entries, finally : actions )+    where encoded = Lazy.fromChunks [ Strict.copy $ Put.runPut (safePut object) ] +-- The given IO action is executed once all previous entries are durable.+pushAction :: FileLog object -> IO () -> IO ()+pushAction fLog finally+    = atomically $+      do (entries, actions) <- readTVar (logQueue fLog)+         writeTVar (logQueue fLog) (entries, finally : actions)+ askCurrentEntryId :: FileLog object -> IO EntryId-askCurrentEntryId log-    = atomically $ readTVar (logNextEntryId log)+askCurrentEntryId fLog+    = atomically $ readTVar (logNextEntryId fLog)+++-- FIXME: Check for unused input.+decode' :: SafeCopy object => Lazy.ByteString -> object+decode' inp+    = case Get.runGetLazy safeGet inp of+        Left msg  -> error msg+        Right val -> val

@@ -9,7 +9,7 @@ import Data.Acid.Core import Data.Acid.Local -import Data.Binary+import Data.SafeCopy import Data.Typeable import Data.Char import Control.Applicative@@ -52,12 +52,12 @@                  _ -> error "Unsupported state type. Only 'data' and 'newtype' are supported."            _ -> error "Given state is not a type." -makeEvent :: Name -> Name -> Q [Dec]-makeEvent eventName stateName+makeEvent :: Name -> Q [Dec]+makeEvent eventName     = do eventInfo <- reify eventName          eventType <- getEventType eventName          d <- makeEventDataType eventName eventType-         b <- makeBinaryInstance eventName eventType+         b <- makeSafeCopyInstance eventName eventType          i <- makeMethodInstance eventName eventType          e <- makeEventInstance eventName eventType          return [d,b,i,e]@@ -70,13 +70,13 @@              -> return eventType            _ -> error $ "Events must be functions: " ++ show eventName ---instance (Binary key, Typeable key, Binary val, Typeable val) => IsAcidic State where+--instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where --  acidEvents = [ UpdateEven (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ] makeIsAcidic eventNames stateName tyvars constructors     = do types <- mapM getEventType eventNames-         let preds = [ ''Binary, ''Typeable ]+         let preds = [ ''SafeCopy, ''Typeable ]              ty = appT (conT ''IsAcidic) stateType-             handlers = map (uncurry makeEventHandler) (zip eventNames types)+             handlers = zipWith makeEventHandler eventNames types          instanceD (mkCxtFromTyVars preds tyvars []) ty                    [ valD (varP 'acidEvents) (normalB (listE handlers)) [] ]     where stateType = foldl appT (conT stateName) [ varT var | PlainTV var <- tyvars ]@@ -88,7 +88,7 @@          let lamClause = conP eventStructName [varP var | var <- vars ]          conE constr `appE` lamE [lamClause] (foldl appE (varE eventName) (map varE vars))     where constr = if isUpdate then 'UpdateEvent else 'QueryEvent-          (tyvars, cxt, args, stateType, resultType, isUpdate) = analyseType eventName eventType+          (_tyvars, _cxt, args, _stateType, _resultType, isUpdate) = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs@@ -98,32 +98,33 @@ makeEventDataType eventName eventType     = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ]          dataD (return cxt) eventStructName tyvars [con] [''Typeable]-    where (tyvars, cxt, args, stateType, resultType, isUpdate) = analyseType eventName eventType+    where (tyvars, cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs --- instance (Binary key, Binary val) => Binary (MyUpdateEvent key val) where+-- instance (SafeCopy key, SafeCopy val) => SafeCopy (MyUpdateEvent key val) where --    put (MyUpdateEvent a b) = do put a; put b --    get = MyUpdateEvent <$> get <*> get-makeBinaryInstance eventName eventType-    = do let preds = [ ''Binary ]-             ty = AppT (ConT ''Binary) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ])+makeSafeCopyInstance eventName eventType+    = do let preds = [ ''SafeCopy ]+             ty = AppT (ConT ''SafeCopy) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ])               getBase = appE (varE 'return) (conE eventStructName)-             getArgs = foldl (\a b -> infixE (Just a) (varE '(<*>)) (Just (varE 'get))) getBase args+             getArgs = foldl (\a b -> infixE (Just a) (varE '(<*>)) (Just (varE 'safeGet))) getBase args+             contained val = varE 'contain `appE` val           putVars <- replicateM (length args) (newName "arg")          let putClause = conP eventStructName [varP var | var <- putVars ]-             putExp    = doE $ [ noBindS $ appE (varE 'put) (varE var) | var <- putVars ] +++             putExp    = doE $ [ noBindS $ appE (varE 'safePut) (varE var) | var <- putVars ] ++                                [ noBindS $ appE (varE 'return) (tupE []) ]           instanceD (mkCxtFromTyVars preds tyvars context)                    (return ty)-                   [ funD 'put [clause [putClause] (normalB putExp) []]-                   , valD (varP 'get) (normalB getArgs) []+                   [ funD 'putCopy [clause [putClause] (normalB (contained putExp)) []]+                   , valD (varP 'getCopy) (normalB (contained getArgs)) []                    ]-    where (tyvars, context, args, stateType, resultType, isUpdate) = analyseType eventName eventType+    where (tyvars, context, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs@@ -133,13 +134,13 @@             map return extraContext  {--instance (Binary key, Typeable key-         ,Binary val, Typeable val) => Method (MyUpdateEvent key val) where+instance (SafeCopy key, Typeable key+         ,SafeCopy val, Typeable val) => Method (MyUpdateEvent key val) where   type MethodResult (MyUpdateEvent key val) = Return   type MethodState (MyUpdateEvent key val) = State key val -} makeMethodInstance eventName eventType-    = do let preds = [ ''Binary, ''Typeable ]+    = do let preds = [ ''SafeCopy, ''Typeable ]              ty = AppT (ConT ''Method) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ])              structType = foldl appT (conT eventStructName) [ varT tyvar | PlainTV tyvar <- tyvars ]          instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context)@@ -147,22 +148,21 @@                    [ tySynInstD ''MethodResult [structType] (return resultType)                    , tySynInstD ''MethodState  [structType] (return stateType)                    ]-    where (tyvars, context, args, stateType, resultType, isUpdate) = analyseType eventName eventType+    where (tyvars, context, _args, stateType, resultType, _isUpdate) = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs ---instance (Binary key, Typeable key---         ,Binary val, Typeable val) => UpdateEvent (MyUpdateEvent key val)+--instance (SafeCopy key, Typeable key+--         ,SafeCopy val, Typeable val) => UpdateEvent (MyUpdateEvent key val) makeEventInstance eventName eventType-    = do let preds = [ ''Binary, ''Typeable ]+    = do let preds = [ ''SafeCopy, ''Typeable ]              eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent              ty = AppT (ConT eventClass) (foldl AppT (ConT eventStructName) [ VarT tyvar | PlainTV tyvar <- tyvars ])-             structType = foldl appT (conT eventStructName) [ varT tyvar | PlainTV tyvar <- tyvars ]          instanceD (cxt $ [ classP classPred [varT tyvar] | PlainTV tyvar <- tyvars, classPred <- preds ] ++ map return context)                    (return ty)                    []-    where (tyvars, context, args, stateType, resultType, isUpdate) = analyseType eventName eventType+    where (tyvars, context, _args, _stateType, _resultType, isUpdate) = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs@@ -172,9 +172,9 @@ analyseType :: Name -> Type -> ([TyVarBndr], Cxt, [Type], Type, Type, Bool) analyseType eventName t     = let (tyvars, cxt, t') = case t of-                                ForallT binds [] t' -> +                                ForallT binds [] t' ->                                   (binds, [], t')-                                ForallT binds cxt t' -> +                                ForallT binds cxt t' ->                                   error $ "Context restrictions on events aren't supported yet: " ++ show eventName                                 _ -> ([], [], t)           args = getArgs t'@@ -193,6 +193,6 @@  makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec] makeAcidic' eventNames stateName tyvars constructors-    = do events <- sequence [ makeEvent eventName stateName | eventName <- eventNames ]+    = do events <- sequence [ makeEvent eventName | eventName <- eventNames ]          acidic <- makeIsAcidic eventNames stateName tyvars constructors          return $ acidic : concat events