packages feed

acid-state 0.14.3 → 0.15.0

raw patch · 160 files changed

+1660/−342 lines, 160 filesdep +deepseqdep +filelockdep +hedgehogdep −extensible-exceptionsdep ~basedep ~cerealdep ~criterionnew-uploaderbinary-addedPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, filelock, hedgehog, hspec, hspec-discover, text, th-expand-syns, time

Dependencies removed: extensible-exceptions

Dependency ranges changed: base, cereal, criterion, mtl, network, safecopy

API changes (from Hackage documentation)

- Data.Acid.Remote: instance GHC.Exception.Exception Data.Acid.Remote.AcidRemoteException
+ Data.Acid.Archive: Done :: Entries
+ Data.Acid.Archive: Fail :: String -> Entries
+ Data.Acid.Archive: Next :: Entry -> Entries -> Entries
+ Data.Acid.Archive: data Entries
+ Data.Acid.Archive: entriesToList :: Entries -> [Entry]
+ Data.Acid.Archive: entriesToListNoFail :: Entries -> [Entry]
+ Data.Acid.Archive: instance GHC.Show.Show Data.Acid.Archive.Entries
+ Data.Acid.Archive: packEntries :: [Entry] -> ByteString
+ Data.Acid.Archive: putEntries :: [Entry] -> Builder
+ Data.Acid.Archive: readEntries :: ByteString -> Entries
+ Data.Acid.Archive: type Entry = ByteString
+ Data.Acid.Common: Query :: Reader st a -> Query st a
+ Data.Acid.Common: Update :: State st a -> Update st a
+ Data.Acid.Common: [QueryEvent] :: QueryEvent ev => (ev -> Query (EventState ev) (EventResult ev)) -> Event (EventState ev)
+ Data.Acid.Common: [UpdateEvent] :: UpdateEvent ev => (ev -> Update (EventState ev) (EventResult ev)) -> Event (EventState ev)
+ Data.Acid.Common: [unQuery] :: Query st a -> Reader st a
+ Data.Acid.Common: [unUpdate] :: Update st a -> State st a
+ Data.Acid.Common: acidEvents :: IsAcidic st => [Event st]
+ Data.Acid.Common: class (SafeCopy st) => IsAcidic st
+ Data.Acid.Common: class Method ev => QueryEvent ev
+ Data.Acid.Common: class Method ev => UpdateEvent ev
+ Data.Acid.Common: data Event st
+ Data.Acid.Common: eventsToMethods :: [Event st] -> [MethodContainer st]
+ Data.Acid.Common: instance Control.Monad.Reader.Class.MonadReader st (Data.Acid.Common.Query st)
+ Data.Acid.Common: instance Control.Monad.State.Class.MonadState st (Data.Acid.Common.Update st)
+ Data.Acid.Common: instance GHC.Base.Applicative (Data.Acid.Common.Query st)
+ Data.Acid.Common: instance GHC.Base.Applicative (Data.Acid.Common.Update st)
+ Data.Acid.Common: instance GHC.Base.Functor (Data.Acid.Common.Query st)
+ Data.Acid.Common: instance GHC.Base.Functor (Data.Acid.Common.Update st)
+ Data.Acid.Common: instance GHC.Base.Monad (Data.Acid.Common.Query st)
+ Data.Acid.Common: instance GHC.Base.Monad (Data.Acid.Common.Update st)
+ Data.Acid.Common: liftQuery :: Query st a -> Update st a
+ Data.Acid.Common: newtype Query st a
+ Data.Acid.Common: newtype Update st a
+ Data.Acid.Common: runGetLazyFix :: Get a -> ByteString -> Either String a
+ Data.Acid.Common: type EventResult ev = MethodResult ev
+ Data.Acid.Common: type EventState ev = MethodState ev
+ Data.Acid.Local: instance GHC.Exception.Type.Exception Data.Acid.Local.StateIsLocked
+ Data.Acid.Local: instance GHC.Show.Show Data.Acid.Local.StateIsLocked
+ Data.Acid.Remote: instance GHC.Exception.Type.Exception Data.Acid.Remote.AcidRemoteException
+ Data.Acid.TemplateHaskell: TypeAnalysis :: [TyVarBndr] -> Cxt -> [Type] -> Type -> Type -> Bool -> TypeAnalysis
+ Data.Acid.TemplateHaskell: [argumentTypes] :: TypeAnalysis -> [Type]
+ Data.Acid.TemplateHaskell: [context] :: TypeAnalysis -> Cxt
+ Data.Acid.TemplateHaskell: [isUpdate] :: TypeAnalysis -> Bool
+ Data.Acid.TemplateHaskell: [resultType] :: TypeAnalysis -> Type
+ Data.Acid.TemplateHaskell: [stateType] :: TypeAnalysis -> Type
+ Data.Acid.TemplateHaskell: [tyvars] :: TypeAnalysis -> [TyVarBndr]
+ Data.Acid.TemplateHaskell: allTyVarBndrNames :: [TyVarBndr] -> [Name]
+ Data.Acid.TemplateHaskell: analyseType :: Name -> Type -> TypeAnalysis
+ Data.Acid.TemplateHaskell: data TypeAnalysis
+ Data.Acid.TemplateHaskell: eventCxts :: Type -> [TyVarBndr] -> Name -> Type -> [Pred]
+ Data.Acid.TemplateHaskell: findTyVars :: Type -> [Name]
+ Data.Acid.TemplateHaskell: getEventType :: Name -> Q Type
+ Data.Acid.TemplateHaskell: instance GHC.Classes.Eq Data.Acid.TemplateHaskell.TypeAnalysis
+ Data.Acid.TemplateHaskell: instance GHC.Show.Show Data.Acid.TemplateHaskell.TypeAnalysis
+ Data.Acid.TemplateHaskell: makeAcidic :: Name -> [Name] -> Q [Dec]
+ Data.Acid.TemplateHaskell: makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
+ Data.Acid.TemplateHaskell: makeEvent :: Name -> Q [Dec]
+ Data.Acid.TemplateHaskell: makeEventDataType :: Name -> Type -> DecQ
+ Data.Acid.TemplateHaskell: makeEventHandler :: Name -> Type -> ExpQ
+ Data.Acid.TemplateHaskell: makeEventInstance :: Name -> Type -> DecQ
+ Data.Acid.TemplateHaskell: makeIsAcidic :: () => [Name] -> Name -> [TyVarBndr] -> p -> Q Dec
+ Data.Acid.TemplateHaskell: makeMethodInstance :: Name -> Type -> DecQ
+ Data.Acid.TemplateHaskell: makeSafeCopyInstance :: Name -> Type -> Q Dec
+ Data.Acid.TemplateHaskell: mkCxtFromTyVars :: [Name] -> [TyVarBndr] -> [Pred] -> CxtQ
+ Data.Acid.TemplateHaskell: renameState :: Type -> Type -> Cxt -> Cxt
+ Data.Acid.TemplateHaskell: tyVarBndrName :: TyVarBndr -> Name
- Data.Acid: openLocalStateFrom :: (IsAcidic st) => FilePath -> st -> IO (AcidState st)
+ Data.Acid: openLocalStateFrom :: IsAcidic st => FilePath -> st -> IO (AcidState st)
- Data.Acid.Advanced: class (Typeable ev, SafeCopy ev, Typeable (MethodResult ev), SafeCopy (MethodResult ev)) => Method ev where type MethodResult ev type MethodState ev methodTag ev = pack (showQualifiedTypeRep (typeOf ev)) where {
+ Data.Acid.Advanced: class (Typeable ev, SafeCopy ev, Typeable (MethodResult ev), SafeCopy (MethodResult ev)) => Method ev where {
- Data.Acid.Core: [Method] :: (Method method) => (method -> State (MethodState method) (MethodResult method)) -> MethodContainer (MethodState method)
+ Data.Acid.Core: [Method] :: Method method => (method -> State (MethodState method) (MethodResult method)) -> MethodContainer (MethodState method)
- Data.Acid.Core: class (Typeable ev, SafeCopy ev, Typeable (MethodResult ev), SafeCopy (MethodResult ev)) => Method ev where type MethodResult ev type MethodState ev methodTag ev = pack (showQualifiedTypeRep (typeOf ev)) where {
+ Data.Acid.Core: class (Typeable ev, SafeCopy ev, Typeable (MethodResult ev), SafeCopy (MethodResult ev)) => Method ev where {
- Data.Acid.Local: LocalState :: Core st -> IORef st -> FileLog (Tagged ByteString) -> FileLog Checkpoint -> PrefixLock -> LocalState st
+ Data.Acid.Local: LocalState :: Core st -> IORef st -> FileLog (Tagged ByteString) -> FileLog Checkpoint -> FileLock -> LocalState st
- Data.Acid.Local: [localLock] :: LocalState st -> PrefixLock
+ Data.Acid.Local: [localLock] :: LocalState st -> FileLock
- Data.Acid.Local: openLocalStateFrom :: (IsAcidic st) => FilePath -> st -> IO (AcidState st)
+ Data.Acid.Local: openLocalStateFrom :: IsAcidic st => FilePath -> st -> IO (AcidState st)
- Data.Acid.Local: prepareLocalStateFrom :: (IsAcidic st) => FilePath -> st -> IO (IO (AcidState st))
+ Data.Acid.Local: prepareLocalStateFrom :: IsAcidic st => FilePath -> st -> IO (IO (AcidState st))
- Data.Acid.Memory: openMemoryState :: (IsAcidic st) => st -> IO (AcidState st)
+ Data.Acid.Memory: openMemoryState :: IsAcidic st => st -> IO (AcidState st)
- Data.Acid.Remote: CommChannel :: (ByteString -> IO ()) -> (Int -> IO (ByteString)) -> IO () -> CommChannel
+ Data.Acid.Remote: CommChannel :: (ByteString -> IO ()) -> (Int -> IO ByteString) -> IO () -> CommChannel
- Data.Acid.Remote: [ccGetSome] :: CommChannel -> Int -> IO (ByteString)
+ Data.Acid.Remote: [ccGetSome] :: CommChannel -> Int -> IO ByteString
- Data.Acid.Remote: sharedSecretCheck :: Set ByteString -> (CommChannel -> IO Bool)
+ Data.Acid.Remote: sharedSecretCheck :: Set ByteString -> CommChannel -> IO Bool
- Data.Acid.Remote: sharedSecretPerform :: ByteString -> (CommChannel -> IO ())
+ Data.Acid.Remote: sharedSecretPerform :: ByteString -> CommChannel -> IO ()

Files

CHANGELOG.md view
@@ -1,12 +1,37 @@+0.15.0+======++ - change text of error messages to include module names+   ([#116](https://github.com/acid-state/acid-state/pull/116))+ - depend on filelock library to avoid locking bug+   ([#91](https://github.com/acid-state/acid-state/pull/91))+ - permit events that are polymorphic in the base monad, with a MonadReader/MonadState constraint+   ([#94](https://github.com/acid-state/acid-state/pull/94))+ - fix a minor memory leak+   ([#104](https://github.com/acid-state/acid-state/pull/104))+ - add a test suite and extend examples+   ([#98](https://github.com/acid-state/acid-state/pull/98))+ - improve benchmarks+   ([#113](https://github.com/acid-state/acid-state/pull/113))+ - expose internal modules (subject to change in the future)++0.14.3+======++ - support building on GHC 8.2+ - update links from seize.it to github.com+ 0.14.2 ====== - - createCheckpoint now cuts a new events file (bug #74)+ - createCheckpoint now cuts a new events file+   ([#74](https://github.com/acid-state/acid-state/pull/74))  0.14.1 ====== - - fix bug in archiveLog that resulted in logs being moved prematurely (bug #22)+ - fix bug in archiveLog that resulted in logs being moved prematurely+   ([#22](https://github.com/acid-state/acid-state/issues/22))  - tweaks for GHC 8.0.x, template-haskell 2.11.x  - fix compilation of benchmarks @@ -22,4 +47,4 @@    which are compiled against safecopy 0.8 / cereal 0.4.   - additional fixes for TH and kinded type variables-   [https://github.com/acid-state/acid-state/pull/56](https://github.com/acid-state/acid-state/pull/56)+   ([#56](https://github.com/acid-state/acid-state/pull/56))
acid-state.cabal view
@@ -1,5 +1,5 @@ Name:                acid-state-Version:             0.14.3+Version:             0.15.0 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:            https://github.com/acid-state/acid-state@@ -10,43 +10,53 @@ Category:            Database Build-type:          Simple Cabal-version:       >=1.10-tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.3 Extra-source-files:         CHANGELOG.md-        examples/*.hs-        examples/errors/*.hs-        src-win32/*.hs-        src-unix/*.hs+        test-state/OldStateTest1/*.log+        test-state/OldStateTest1/*.version+        test-state/OldStateTest2/*.log+        test-state/OldStateTest2/*.version+        test-state/OldStateTest3/*.log+        test-state/OldStateTest3/*.version  Source-repository head   type:          git   location:      https://github.com/acid-state/acid-state +flag skip-state-machine-test+  description: If enabled, do not build/run the state-machine test+  default: False+  manual: True+ Library   Exposed-Modules:     Data.Acid,+                       Data.Acid.Archive,+                       Data.Acid.Common,                        Data.Acid.Local, Data.Acid.Memory,                        Data.Acid.Memory.Pure, Data.Acid.Remote,                        Data.Acid.Advanced,                        Data.Acid.Log, Data.Acid.CRC,-                       Data.Acid.Abstract, Data.Acid.Core+                       Data.Acid.Abstract, Data.Acid.Core,+                       Data.Acid.TemplateHaskell -  Other-modules:       Data.Acid.Archive,-                       Paths_acid_state,-                       Data.Acid.TemplateHaskell, Data.Acid.Common, FileIO+  Other-modules:       Paths_acid_state,+                       FileIO    Build-depends:       array,-                       base >= 4 && < 5,+                       base >= 4.5.1.0 && < 5,                        bytestring >= 0.10.2,                        cereal >= 0.4.1.0,                        containers,-                       extensible-exceptions,                        safecopy >= 0.6,                        stm >= 2.4,                        directory,+                       filelock,                        filepath,                        mtl,-                       network,-                       template-haskell+                       network < 2.9,+                       template-haskell,+                       th-expand-syns    if os(windows)      Build-depends:       Win32@@ -63,8 +73,81 @@   default-language:    Haskell2010   GHC-Options:         -fwarn-unused-imports -fwarn-unused-binds +test-suite specs+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , acid-state+                     , deepseq+                     , hspec+                     , hspec-discover+                     , mtl+                     , safecopy+                     , template-haskell+  build-tool-depends: hspec-discover:hspec-discover+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  other-modules:       Data.Acid.TemplateHaskellSpec+  default-language:    Haskell2010 +test-suite state-machine+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             StateMachine.hs+  build-depends:       base+                     , acid-state+                     , containers+                     , deepseq >= 1.4.0.0+                     , directory+                     , hedgehog+                     , mtl+                     , safecopy+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  other-modules:       Data.Acid.KeyValueStateMachine+                       Data.Acid.StateMachineTest+  default-language:    Haskell2010 +  if flag(skip-state-machine-test)+    buildable: False++test-suite examples+  type:                exitcode-stdio-1.0+  hs-source-dirs:      examples+                       examples/errors+  main-is:             Examples.hs+  build-depends:       base+                     , acid-state+                     , cereal+                     , containers+                     , directory+                     , mtl+                     , network+                     , safecopy+                     , text+                     , time+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  other-modules:       ChangeState+                       ChangeVersion+                       CheckpointCutsEvent+                       Exceptions+                       HelloDatabase+                       HelloWorld+                       HelloWorldNoTH+                       KeyValue+                       KeyValueNoTH+                       MonadStateConstraint+                       ParameterisedState+                       RemoteClient+                       RemoteCommon+                       RemoteServer+                       RemoveEvent+                       SlowCheckpoint+                       StressTest+                       StressTestNoTH+  if !os(windows)+     other-modules:    Proxy+  default-language:    Haskell2010+ benchmark loading-benchmark   type:     exitcode-stdio-1.0@@ -81,7 +164,7 @@     directory,     system-fileio == 0.3.*,     system-filepath,-    criterion >= 0.8 && < 1.2,+    criterion >= 1.0.0.0 && < 1.6,     mtl,     base,     acid-state
benchmarks/loading/Benchmark.hs view
@@ -1,78 +1,175 @@+{-# LANGUAGE RecordWildCards #-}  import Benchmark.Prelude import Criterion.Main import qualified Data.Acid as Acid+import qualified Data.Acid.Memory as Memory import qualified Benchmark.FileSystem as FS import qualified Benchmark.Model as Model; import Benchmark.Model (Model) import qualified System.Random as Random  - main :: IO ()-main = do+main = defaultMain [benchmark defaultBenchmarkInterfaces [100,200,300,400]] -  workingPath <- do-    workingPath <- FS.getTemporaryDirectory-    rndStr <- replicateM 16 $ Random.randomRIO ('a', 'z')-    return $ workingPath <> "acid-state" <> "benchmarks" <> "loading" <> FS.decodeString rndStr+benchmark :: [BenchmarkInterface] -> [Int] -> Benchmark+benchmark bis sizes = env setupWorkingPath $ \ workingPath ->+    bgroup "" $ map (benchmarksGroup bis workingPath) sizes ++-- | An acid-state interface to be benchmarked.+data BenchmarkInterface = forall m .+    BenchmarkInterface+        { benchName    :: String+          -- ^ Name of the interface, for use in constructing benchmarks.+        , benchPersist :: Bool+          -- ^ Does this interface actually persist data to disk? If+          -- it doesn't, some benchmarks are not applicable.+        , benchOpen    :: FS.FilePath -> IO (Acid.AcidState m)+          -- ^ Open an acid-state component with the given path.  Note+          -- that the type of the state is encapsulated within+          -- 'BenchmarkInterface'.+        , benchUpdate  :: Acid.AcidState m -> [[Int]] -> IO ()+          -- ^ Execute an 'insert' update against the acid-state.+        , benchQuery   :: Acid.AcidState m -> IO Int+          -- ^ Execute a 'sumUp' query against the state.+        }++memoryBenchmarkInterface :: BenchmarkInterface+memoryBenchmarkInterface =+    BenchmarkInterface { benchName    = "Memory"+                       , benchPersist = False+                       , benchOpen    = const $ Memory.openMemoryState mempty+                       , benchUpdate  = \ inst v -> Acid.update inst (Model.Insert v)+                       , benchQuery   = \ inst -> Acid.query inst Model.SumUp+                       }++localBenchmarkInterface :: BenchmarkInterface+localBenchmarkInterface =+    BenchmarkInterface { benchName    = "Local"+                       , benchPersist = True+                       , benchOpen    = \ p -> Acid.openLocalStateFrom (FS.encodeString p) mempty+                       , benchUpdate  = \ inst v -> Acid.update inst (Model.Insert v)+                       , benchQuery   = \ inst -> Acid.query inst Model.SumUp+                       }++defaultBenchmarkInterfaces :: [BenchmarkInterface]+defaultBenchmarkInterfaces = [memoryBenchmarkInterface, localBenchmarkInterface]+++setupWorkingPath :: IO FS.FilePath+setupWorkingPath = do+  workingPath <- do workingPath <- FS.getTemporaryDirectory+                    rndStr <- replicateM 16 $ Random.randomRIO ('a', 'z')+                    return $ workingPath <> "acid-state" <> "benchmarks" <> "loading" <> FS.decodeString rndStr   putStrLn $ "Working under the following temporary directory: " ++ FS.encodeString workingPath   FS.removeTreeIfExists workingPath   FS.createTree workingPath+  return workingPath -  defaultMain =<< sequence-    [-      prepareBenchmarksGroup workingPath $ 100,-      prepareBenchmarksGroup workingPath $ 200,-      prepareBenchmarksGroup workingPath $ 300,-      prepareBenchmarksGroup workingPath $ 400-    ] +benchmarksGroup :: [BenchmarkInterface] -> FS.FilePath -> Int -> Benchmark+benchmarksGroup bis workingPath size =+  bgroup (show size)+  [ bgroup (benchName bi) $+      initializeBenchmarksGroup bi workingPath' size+    : if benchPersist bi then [openCloseBenchmarksGroup  bi workingPath' size] else []+  | bi <- bis+  ]+  where+    workingPath' = workingPath <> FS.decodeString (show size)  -prepareBenchmarksGroup :: FS.FilePath -> Int -> IO Benchmark-prepareBenchmarksGroup workingPath size = do+-- | The Initialize benchmarks measure how long it takes to open an+-- empty 'AcidState' component, call 'initialize' to populate it with+-- data, and optionally checkpoint before closing.+initializeBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> Benchmark+initializeBenchmarksGroup bi workingPath size =+  bgroup "Initialize"+  [ bench "Without checkpoint" $ perRunEnv (prepareInitialize bi workingPath) $ \ _ ->+        initializeClose bi workingPath size+  , bench "With checkpoint" $ perRunEnv (prepareInitialize bi workingPath) $ \ _ ->+        initializeCheckpointClose bi workingPath size+  ]++prepareInitialize :: BenchmarkInterface -> FS.FilePath -> IO ()+prepareInitialize bi workingPath =+    when (benchPersist bi) $ do FS.removeTreeIfExists workingPath+                                FS.createTree workingPath+++-- | The OpenClose benchmarks measure how long it takes to open an+-- existing on-disk 'AcidState' component (either from a checkpoint or+-- from a transaction log), optionally execute a query over the entire+-- state, then close.  These benchmarks are not applicable if the+-- interface being benchmarked does not persist data.+openCloseBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> Benchmark+openCloseBenchmarksGroup bi workingPath size =+  env (prepareOpenCloseBenchmarksGroup bi workingPath size) $ \ ~(logsInstancePath, checkpointInstancePath) -> bgroup "OpenClose"+    [+      bench "From Logs" $ nfIO $+        openClose bi logsInstancePath+    , bench "From Checkpoint" $ nfIO $+        openClose bi checkpointInstancePath+    , bench "From Logs (with query)" $ nfIO $+        openQueryClose bi logsInstancePath+    , bench "From Checkpoint (with query)" $ nfIO $+        openQueryClose bi checkpointInstancePath+    ]++-- | Set up data on disk for the open/close benchmarks.  This+-- initializes an instance, creates a copy of it (for restoring from+-- transaction logs), then checkpoints.+prepareOpenCloseBenchmarksGroup :: BenchmarkInterface -> FS.FilePath -> Int -> IO (FS.FilePath, FS.FilePath)+prepareOpenCloseBenchmarksGroup bi workingPath size = do   putStrLn $ "Preparing instances for size " ++ show size    let-    workingPath' = workingPath <> (FS.decodeString $ show size)-    logsInstancePath = workingPath' <> "logs-instance"-    checkpointInstancePath = workingPath' <> "checkpoint-instance"+    logsInstancePath = workingPath <> "logs-instance"+    checkpointInstancePath = workingPath <> "checkpoint-instance"    FS.createTree logsInstancePath   FS.createTree checkpointInstancePath    putStrLn "Initializing"-  inst <- initialize checkpointInstancePath size+  initialize bi checkpointInstancePath size $ \inst -> do -  putStrLn "Copying"-  FS.copy checkpointInstancePath logsInstancePath-  FS.removeFile $ logsInstancePath <> "open.lock"+    putStrLn "Copying"+    FS.copy checkpointInstancePath logsInstancePath+    FS.removeFile $ logsInstancePath <> "open.lock" -  putStrLn "Checkpointing"-  Acid.createCheckpoint inst+    putStrLn "Checkpointing"+    Acid.createCheckpoint inst -  putStrLn "Closing"-  Acid.closeAcidState inst+    putStrLn "Closing"+    Acid.closeAcidState inst -  return $ bgroup (show size)-    [-      bench "From Logs" $ nfIO $-        load logsInstancePath >>= Acid.closeAcidState,-      bench "From Checkpoint" $ nfIO $-        load checkpointInstancePath >>= Acid.closeAcidState-    ]+    return (logsInstancePath, checkpointInstancePath)  +initialize :: BenchmarkInterface -> FS.FilePath ->  Int -> (forall m . Acid.AcidState m -> IO r) -> IO r+initialize BenchmarkInterface{..} p size k = do+    inst <- benchOpen p+    let values = replicate size $ replicate 100 $ replicate 100 1+    mapM_ (benchUpdate inst) values+    k inst -load :: FS.FilePath -> IO (Acid.AcidState Model)-load path = Acid.openLocalStateFrom (FS.encodeString path) mempty+initializeClose :: BenchmarkInterface -> FS.FilePath -> Int -> IO ()+initializeClose bi p size = initialize bi p size Acid.closeAcidState -initialize :: FS.FilePath -> Int -> IO (Acid.AcidState Model)-initialize path size = do-  inst <- Acid.openLocalStateFrom (FS.encodeString path) mempty-  let values = replicate size $ replicate 100 $ replicate 100 1-  mapM_ (Acid.update inst . Model.Insert) values-  return inst+initializeCheckpointClose :: BenchmarkInterface -> FS.FilePath -> Int -> IO ()+initializeCheckpointClose bi p size =+  initialize bi p size $ \ inst -> do+    Acid.createCheckpoint inst+    Acid.closeAcidState inst  +openClose :: BenchmarkInterface -> FS.FilePath -> IO ()+openClose BenchmarkInterface{..} p = benchOpen p >>= Acid.closeAcidState++openQueryClose :: BenchmarkInterface -> FS.FilePath -> IO Int+openQueryClose BenchmarkInterface{..} p = do+    inst <- benchOpen p+    n <- benchQuery inst+    Acid.closeAcidState inst+    return n
benchmarks/loading/Benchmark/Model.hs view
@@ -10,4 +10,7 @@ insert :: [[Int]] -> Acid.Update Model () insert = modify . (:) -Acid.makeAcidic ''Model ['insert]+sumUp :: Acid.Query Model Int+sumUp = sum . map (sum . map sum) <$> ask++Acid.makeAcidic ''Model ['insert, 'sumUp]
examples/CheckpointCutsEvent.hs view
@@ -18,14 +18,17 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-module Main (main) where+module CheckpointCutsEvent (main) where  -- import           Control.Concurrent+import           Control.Applicative import           Control.Monad.Reader import           Control.Monad.State import           Data.Acid+import           Data.List import           Data.SafeCopy import           Data.Typeable+import           System.Directory import           System.Environment  ------------------------------------------------------@@ -47,10 +50,38 @@   main :: IO ()-main =-  do acid <- openLocalState (Counter 0)+main = do+     putStrLn "CheckpointCutsEvent test"+     exists <- doesDirectoryExist fp+     when exists $ removeDirectoryRecursive fp+     acid <- openLocalStateFrom fp (Counter 0)      replicateM_ 10 $ do is <- replicateM 10 (update acid IncCounter)                          print is                          createCheckpoint acid                          createArchive acid      closeAcidState acid+     checkDirectoryContents fp expected_state+     checkDirectoryContents (fp ++ "/Archive") expected_archive+     s <- readFile (fp ++ "/events-0000000100.log")+     unless (s == "") $ error "non-empty events file"+     putStrLn "CheckpointCutsEvent done"+  where+    fp = "state/CheckpointCutsEvent"++    expected_state   = [".","..","Archive","checkpoints-0000000009.log","checkpoints-0000000010.log"+                       ,"checkpoints.version","events-0000000100.log","events.version","open.lock"]+    expected_archive = [".","..","checkpoints-0000000000.log","checkpoints-0000000001.log"+                       ,"checkpoints-0000000002.log","checkpoints-0000000003.log","checkpoints-0000000004.log"+                       ,"checkpoints-0000000005.log","checkpoints-0000000006.log","checkpoints-0000000007.log"+                       ,"checkpoints-0000000008.log","events-0000000000.log","events-0000000010.log"+                       ,"events-0000000020.log","events-0000000030.log","events-0000000040.log"+                       ,"events-0000000050.log","events-0000000060.log","events-0000000070.log"+                       ,"events-0000000080.log","events-0000000090.log"]+++checkDirectoryContents :: FilePath -> [FilePath] -> IO ()+checkDirectoryContents fp expected_fs = do+    putStrLn $ "Checking contents of " ++ fp+    fs <- sort <$> getDirectoryContents fp+    unless (fs == expected_fs) $ error $ "bad contents of " ++ fp ++ ": expected "+                                         ++ show expected_fs ++ " but got " ++ show fs
+ examples/Examples.hs view
@@ -0,0 +1,17 @@+module Main (main) where++import qualified ChangeState+import qualified ChangeVersion+import qualified CheckpointCutsEvent+import qualified Exceptions+import qualified RemoveEvent+import qualified SlowCheckpoint++main :: IO ()+main = do+  ChangeState.test+  ChangeVersion.test+  CheckpointCutsEvent.main+  Exceptions.test+  RemoveEvent.test+  SlowCheckpoint.main
examples/HelloDatabase.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module HelloDatabase (main) where  import           Data.Acid
examples/HelloWorld.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module HelloWorld (main) where  import           Control.Monad.Reader import           Control.Monad.State
examples/HelloWorldNoTH.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module HelloWorldNoTH (main) where  import           Data.Acid import           Data.Acid.Advanced
examples/KeyValue.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module KeyValue (main) where  import           Data.Acid import           Data.Acid.Remote
examples/KeyValueNoTH.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module KeyValueNoTH (main) where  import           Data.Acid import           Data.Acid.Advanced
+ examples/MonadStateConstraint.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeFamilies       #-}++module MonadStateConstraint (main) where++import           Control.Monad.Reader+import           Control.Monad.State+import           Data.Acid+import           Data.SafeCopy+import           Data.Typeable+import           System.Environment++------------------------------------------------------+-- The Haskell structure that we want to encapsulate++data HelloWorldState = HelloWorldState String+    deriving (Show, Typeable)++$(deriveSafeCopy 0 'base ''HelloWorldState)++------------------------------------------------------+-- The transaction we will execute over the state.++writeState :: MonadState HelloWorldState m => String -> m ()+writeState newValue+    = put (HelloWorldState newValue)++queryState :: MonadReader HelloWorldState m => m String+queryState = do HelloWorldState string <- ask+                return string++$(makeAcidic ''HelloWorldState ['writeState, 'queryState])++------------------------------------------------------+-- This is how AcidState is used:++main :: IO ()+main = do acid <- openLocalState (HelloWorldState "Hello world")+          args <- getArgs+          if null args+             then do string <- query acid QueryState+                     putStrLn $ "The state is: " ++ string+             else do update acid (WriteState (unwords args))+                     putStrLn "The state has been modified!"
+ examples/ParameterisedState.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE StandaloneDeriving #-}++module ParameterisedState (main) where++import Control.Monad.State.Strict++import Data.Acid+import qualified Data.Map as Map+import Data.SafeCopy (SafeCopy(..), deriveSafeCopy, base)+import Data.Serialize+import Data.Typeable+import GHC.Generics++data Entry k = Entry+    { key :: !k+    , val :: !Int+    }+    deriving (Eq, Ord, Generic)++instance Serialize k => Serialize (Entry k)++$(deriveSafeCopy 0 'base ''Entry)++newtype Store k = Store { store :: Map.Map k (Entry k) }+    deriving (Eq, Generic)++#if __GLASGOW_HASKELL__ <= 708+deriving instance Typeable1 Store+#endif++instance (Ord k, Serialize k) => SafeCopy (Store k)+instance (Ord k, Serialize k) => Serialize (Store k)++insertStore+    :: (Ord k, Serialize k)+    => Entry k+    -> Update (Store k) k+insertStore item = do+    modify $ \(Store s) -> Store $ Map.insert (key item) item s+    return (key item)++makeAcidic ''Store [ 'insertStore ]+++main :: IO ()+main = do st <- openLocalState (Store Map.empty :: Store String)+          k  <- update st (InsertStore (Entry "A" 42))+          putStrLn k
examples/Proxy.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module Proxy (main) where  import           Data.Acid import           Data.Acid.Advanced   (scheduleUpdate)
examples/RemoteClient.hs view
@@ -1,4 +1,4 @@-module Main (main) where+module RemoteClient (main) where  import           Control.Monad.Reader import           Data.Acid
examples/RemoteServer.hs view
@@ -1,4 +1,4 @@-module Main where+module RemoteServer where  import           Control.Exception (bracket) import           Data.Acid         (closeAcidState, openLocalState)
examples/SlowCheckpoint.hs view
@@ -2,14 +2,19 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+-- With optimizations enabled, serializing the checkpoint can happen too quickly+{-# OPTIONS_GHC -O0 #-} +module SlowCheckpoint (main) where+ import           Data.Acid  import           Control.Concurrent+import           Control.Monad.Reader import           Control.Monad.State import           Data.SafeCopy import           Data.Time+import           System.Directory import           System.IO  ------------------------------------------------------@@ -36,13 +41,20 @@           put $ SlowCheckpoint slow (tick+1)           return tick -$(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick])+askTick :: Query SlowCheckpoint Int+askTick = do SlowCheckpoint _ tick <- ask+             return tick +$(makeAcidic ''SlowCheckpoint ['setComputationallyHeavyData, 'tick, 'askTick])+ ------------------------------------------------------ -- This is how AcidState is used:  main :: IO ()-main = do acid <- openLocalStateFrom "state/SlowCheckpoint" (SlowCheckpoint 0 0)+main = do putStrLn "SlowCheckpoint test"+          exists <- doesDirectoryExist fp+          when exists $ removeDirectoryRecursive fp+          acid <- openLocalStateFrom fp (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."@@ -51,12 +63,20 @@           putStrLn ""           doTick acid           update acid SetComputationallyHeavyData-          forkIO $ do putStrLn "Seriazing checkpoint..."+          forkIO $ do putStrLn "Serializing checkpoint..."                       t <- timeIt $ createCheckpoint acid-                      putStrLn $ "Checkpoint created in: " ++ show t+                      n <- query acid AskTick+                      putStrLn $ "Checkpoint created in: " ++ show t ++ " (saw " ++ show n ++ " ticks)"+                      when (n < threshold) $ error $ "Not enough ticks! Expected at least " ++ show threshold           replicateM_ 20 $             do doTick acid                threadDelay (10^5)+          putStrLn "SlowCheckpoint done"+  where+    fp = "state/SlowCheckpoint"++    -- We must see at least this many ticks for the test to be considered a success+    threshold = 5  doTick acid     = do tick <- update acid Tick
examples/StressTest.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module StressTest (main) where  import           Data.Acid import           Data.Acid.Advanced   (groupUpdates)
examples/StressTestNoTH.hs view
@@ -2,7 +2,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module StressTestNoTH (main) where  import           Data.Acid import           Data.Acid.Advanced
examples/errors/ChangeState.hs view
@@ -1,19 +1,16 @@-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module ChangeState (main, test) where  import           Data.Acid +import           Control.Exception import           Control.Monad.State import           Data.SafeCopy+import           System.Directory import           System.Environment--import           Data.Typeable--import           Control.Exception-import           Prelude             hiding (catch)+import           Data.List (isSuffixOf)  import qualified Data.Text           as Text @@ -43,9 +40,24 @@           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 <- openLocalStateFrom "state/ChangeState" (FirstState "first state")+          firstAcid <- openLocalStateFrom fp (FirstState "first state")           createCheckpoint firstAcid           closeAcidState firstAcid-          secondAcid <- openLocalStateFrom "state/ChangeState" (SecondState (Text.pack "This initial value shouldn't be used"))+          secondAcid <- openLocalStateFrom fp (SecondState (Text.pack "This initial value shouldn't be used"))           closeAcidState secondAcid-          putStrLn "If you see this message then something has gone wrong!"+          error "If you see this message then something has gone wrong!"++test :: IO ()+test = do+    putStrLn "ChangeState test"+    exists <- doesDirectoryExist fp+    when exists $ removeDirectoryRecursive fp+    handle hdl main+    putStrLn "ChangeState done"+  where+    hdl (ErrorCall msg)+      | "Could not parse saved checkpoint due to the following error: too few bytes\nFrom:\tChangeState.SecondState:\n\tdemandInput\n\n" `isSuffixOf` msg +      = putStrLn $ "Caught error: " ++ msg+    hdl e = throwIO e++fp = "state/ChangeState"
+ examples/errors/ChangeVersion.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE TypeFamilies       #-}++module ChangeVersion (main, test) where++import           Data.Acid++import           Control.Exception+import           Control.Monad.State+import           Data.SafeCopy+import           System.Directory+import           System.Environment++------------------------------------------------------+-- The Haskell structure that we want to encapsulate++data FirstState = FirstState String+    deriving (Show)++data SecondState = SecondState Int+    deriving (Show)++$(deriveSafeCopy 0 'base ''FirstState)+$(deriveSafeCopy 1 'base ''SecondState)+-- The version number difference is important here, as safecopy has no+-- way to reliably notice if we change a type and fail to update its+-- migration history.  In some cases the serialised data will fail to+-- parse (see the "ChangeState" example), but it depends on the types+-- involved, and this will not always be the case.++------------------------------------------------------+-- 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 safecopy"+          putStrLn "version without specifying how to migrate from the old version to the new."+          putStrLn "Hopefully this program will fail with a readable error message."+          putStrLn ""+          firstAcid <- openLocalStateFrom fp (FirstState "first state")+          createCheckpoint firstAcid+          closeAcidState firstAcid+          secondAcid <- openLocalStateFrom fp (SecondState 42)+          closeAcidState secondAcid+          error "If you see this message then something has gone wrong!"++test :: IO ()+test = do+    putStrLn "ChangeVersion test"+    exists <- doesDirectoryExist fp+    when exists $ removeDirectoryRecursive fp+    handle hdl main+    putStrLn "ChangeVersion done"+  where+    hdl (ErrorCall msg)+      | msg == "Could not parse saved checkpoint due to the following error: Failed reading: safecopy: ChangeVersion.SecondState: Cannot find getter associated with this version number: Version {unVersion = 0}\nEmpty call stack\n"+      = putStrLn $ "Caught error: " ++ msg+    hdl e = throwIO e++fp = "state/ChangeVersion"
examples/errors/Exceptions.hs view
@@ -2,13 +2,14 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module Exceptions (main, test) where  import           Data.Acid import           Data.Acid.Local     (createCheckpointAndClose)  import           Control.Monad.State import           Data.SafeCopy+import           System.Directory import           System.Environment  import           Data.Typeable@@ -70,7 +71,40 @@             ["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+                        do_tick acid            `catch` \e -> do putStrLn $ "Caught exception: " ++ show (e:: SomeException)                             createCheckpointAndClose acid++do_tick :: AcidState MyState -> IO ()+do_tick acid = do n <- update acid Tick+                  putStrLn $ "Tick: " ++ show n++test :: IO ()+test = do putStrLn "Exceptions test"+          exists <- doesDirectoryExist fp+          when exists $ removeDirectoryRecursive fp+          acid <- openLocalStateFrom fp (MyState 0)+          do_tick acid+          handle hdl $ update acid (undefined :: FailEvent)+          do_tick acid+          handle hdl $ update acid FailEvent+          do_tick acid+          handle hdl $ update acid ErrorEvent+          do_tick acid+          handle hdl $ update acid StateError+          do_tick acid+          -- We can't currently cope with an error being thrown during serialization of the state (see #38)+          -- handle hdl $ update acid StateNestedError1+          do_tick acid+          handle hdl $ update acid (StateNestedError2 (error "nested state error (2)"))+          do_tick acid+          n <- update acid Tick+          unless (n == expected_n) $ error $ "Wrong tick value, expected " ++ show expected_n+          createCheckpointAndClose acid+          putStrLn "Exceptions done"+  where+    fp = "state/Exceptions"++    hdl e = putStrLn $ "Caught exception: " ++ show (e:: SomeException)++    expected_n = 7
examples/errors/RemoveEvent.hs view
@@ -2,13 +2,15 @@ {-# LANGUAGE TemplateHaskell    #-} {-# LANGUAGE TypeFamilies       #-} -module Main (main) where+module RemoveEvent (main, test) where  import           Data.Acid  import           Control.Monad.State import           Data.SafeCopy+import           System.Directory import           System.Environment+import           Data.List (isSuffixOf)  import           Data.Typeable @@ -44,10 +46,25 @@           putStrLn "that is required to replay the journal."           putStrLn "Hopefully this program will fail with a readable error message."           putStrLn ""-          firstAcid <- openLocalStateFrom "state/RemoveEvent" FirstState+          firstAcid <- openLocalStateFrom fp FirstState           update firstAcid FirstEvent           closeAcidState firstAcid -          secondAcid <- openLocalStateFrom "state/RemoveEvent" SecondState+          secondAcid <- openLocalStateFrom fp SecondState           closeAcidState secondAcid-          putStrLn "If you see this message then something has gone wrong!"+          error "If you see this message then something has gone wrong!"++test :: IO ()+test = do+    putStrLn "RemoveEvent test"+    exists <- doesDirectoryExist fp+    when exists $ removeDirectoryRecursive fp+    handle hdl main+    putStrLn "RemoveEvent done"+  where+    hdl (ErrorCall msg)+      | "This method is required but not available: \"RemoveEvent.FirstEvent\". Did you perhaps remove it before creating a checkpoint?" `isSuffixOf` msg+      = putStrLn $ "Caught error: " ++ msg+    hdl e = throwIO e++fp = "state/RemoveEvent"
src-unix/FileIO.hs view
@@ -1,31 +1,17 @@ {-# LANGUAGE ForeignFunctionInterface #-}-module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where+module FileIO(FHandle,open,write,flush,close) where import System.Posix(Fd(Fd),                     openFd,                     fdWriteBuf,-                    fdToHandle,                     closeFd,-                    OpenMode(WriteOnly,ReadWrite),-                    exclusive, trunc,+                    OpenMode(WriteOnly),                     defaultFileFlags,                     stdFileMode                    ) import Data.Word(Word8,Word32) import Foreign(Ptr) import Foreign.C(CInt(..))-import System.IO -import Data.Maybe (listToMaybe)-import qualified System.IO.Error as SE-import System.Posix.Process (getProcessID)-import System.Posix.Signals (nullSignal, signalProcess)-import System.Posix.Types (ProcessID)-import Control.Exception.Extensible as E-import System.Directory         ( createDirectoryIfMissing, removeFile)-import System.FilePath--newtype PrefixLock = PrefixLock FilePath- data FHandle = FHandle Fd  -- should handle opening flags correctly@@ -43,111 +29,3 @@  close :: FHandle -> IO () close (FHandle fd) = closeFd fd---- Unix needs to use a special open call to open files for exclusive writing---openExclusively :: FilePath -> IO Handle---openExclusively fp =---    fdToHandle =<< openFd fp ReadWrite (Just 0o600) flags---    where flags = defaultFileFlags {exclusive = True, trunc = True}-----obtainPrefixLock :: FilePath -> IO PrefixLock-obtainPrefixLock prefix = do-    checkLock fp >> takeLock fp-    where fp = prefix ++ ".lock"---- |Read the lock and break it if the process is dead.-checkLock :: FilePath -> IO ()-checkLock fp = readLock fp >>= maybeBreakLock fp---- |Read the lock and return the process id if possible.-readLock :: FilePath -> IO (Maybe ProcessID)-readLock fp = try (readFile fp) >>=-              return . either (checkReadFileError fp) (fmap (fromInteger . read) . listToMaybe . lines)---- |Is this a permission error?  If so we don't have permission to--- remove the lock file, abort.-checkReadFileError :: [Char] -> IOError -> Maybe ProcessID-checkReadFileError fp e | SE.isPermissionError e = throw (userError ("Could not read lock file: " ++ show fp))-                        | SE.isDoesNotExistError e = Nothing-                        | True = throw e--maybeBreakLock :: FilePath -> Maybe ProcessID -> IO ()-maybeBreakLock fp Nothing =-    -- The lock file exists, but there's no PID in it.  At this point,-    -- we will break the lock, because the other process either died-    -- or will give up when it failed to read its pid back from this-    -- file.-    breakLock fp-maybeBreakLock fp (Just pid) = do-  -- The lock file exists and there is a PID in it.  We can break the-  -- lock if that process has died.-  -- getProcessStatus only works on the children of the calling process.-  -- exists <- try (getProcessStatus False True pid) >>= either checkException (return . isJust)-  exists <- doesProcessExist pid-  case exists of-    True -> throw (lockedBy fp pid)-    False -> breakLock fp--doesProcessExist :: ProcessID -> IO Bool-doesProcessExist pid =-    -- Implementation 1-    -- doesDirectoryExist ("/proc/" ++ show pid)-    -- Implementation 2-    try (signalProcess nullSignal pid) >>= return . either checkException (const True)-    where checkException e | SE.isDoesNotExistError e = False-                           | True = throw e---- |We have determined the locking process is gone, try to remove the--- lock.-breakLock :: FilePath -> IO ()-breakLock fp = try (removeFile fp) >>= either checkBreakError (const (return ()))---- |An exception when we tried to break a lock, if it says the lock--- file has already disappeared we are still good to go.-checkBreakError :: IOError -> IO ()-checkBreakError e | SE.isDoesNotExistError e = return ()-                  | True = throw e---- |Try to create lock by opening the file with the O_EXCL flag and--- writing our PID into it.  Verify by reading the pid back out and--- matching, maybe some other process slipped in before we were done--- and broke our lock.-takeLock :: FilePath -> IO PrefixLock-takeLock fp = do-  createDirectoryIfMissing True (takeDirectory fp)-  h <- openFd fp ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True}) >>= fdToHandle-  pid <- getProcessID-  hPutStrLn h (show pid) >> hClose h-  -- Read back our own lock and make sure its still ours-  readLock fp >>= maybe (throw (cantLock fp pid))-                        (\ pid' -> if pid /= pid'-                                   then throw (stolenLock fp pid pid')-                                   else return (PrefixLock fp))---- |An exception saying the data is locked by another process.-lockedBy :: (Show a) => FilePath -> a -> SomeException-lockedBy fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Locked by " ++ show pid) Nothing (Just fp))---- |An exception saying we don't have permission to create lock.-cantLock :: FilePath -> ProcessID -> SomeException-cantLock fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ " could not create a lock") Nothing (Just fp))---- |An exception saying another process broke our lock before we--- finished creating it.-stolenLock :: FilePath -> ProcessID -> ProcessID -> SomeException-stolenLock fp pid pid' = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ "'s lock was stolen by process " ++ show pid') Nothing (Just fp))---- |Relinquish the lock by removing it and then verifying the removal.-releasePrefixLock :: PrefixLock -> IO ()-releasePrefixLock (PrefixLock fp) =-    dropLock >>= either checkDrop return-    where-      dropLock = try (removeFile fp)-      checkDrop e | SE.isDoesNotExistError e = return ()-                  | True = throw e---
src-win32/FileIO.hs view
@@ -1,4 +1,4 @@-module FileIO(FHandle,open,write,flush,close,obtainPrefixLock,releasePrefixLock,PrefixLock) where+module FileIO(FHandle,open,write,flush,close) where import System.Win32(HANDLE,                     createFile,                     gENERIC_WRITE,@@ -11,21 +11,9 @@ import Data.Word(Word8,Word32) import Foreign(Ptr) import System.IO-import System.Directory(createDirectoryIfMissing,removeFile)-import Control.Exception.Extensible(try,throw)-import Control.Exception(SomeException,IOException)-import qualified Control.Exception as E  -type PrefixLock = (FilePath, Handle)- data FHandle = FHandle HANDLE -tryE :: IO a -> IO (Either SomeException a)-tryE = try--catchIO :: IO a -> (IOException -> IO a) -> IO a-catchIO = E.catch- open :: FilePath -> IO FHandle open filename =     fmap FHandle $ createFile filename gENERIC_WRITE fILE_SHARE_NONE Nothing cREATE_ALWAYS fILE_ATTRIBUTE_NORMAL Nothing@@ -38,27 +26,3 @@  close :: FHandle -> IO () close (FHandle handle) = closeHandle handle---- Windows opens files for exclusive writing by default-openExclusively :: FilePath -> IO Handle-openExclusively fp = openFile fp ReadWriteMode--obtainPrefixLock :: FilePath -> IO PrefixLock-obtainPrefixLock prefix = do-    createDirectoryIfMissing True prefix-    -- catchIO obtainLock onError-    catchIO obtainLock onError-    where fp = prefix ++ ".lock"-          obtainLock = do-              h <- openExclusively fp-              return (fp, h)-          onError e = do-              putStrLn "There may already be an instance of this application running, which could result in a loss of data."-              putStrLn ("Please make sure there is no other application attempting to access '" ++ prefix ++ "'")-              throw e--releasePrefixLock :: PrefixLock -> IO ()-releasePrefixLock (fp, h) = do-     tryE $ hClose h-     tryE $ removeFile fp-     return ()
src/Data/Acid/Abstract.hs view
@@ -132,7 +132,7 @@          Just (Just x) -> x          _ ->            error $-            "Data.Acid: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r)+            "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf sub) ++ " -> " ++ show (typeOf r) #else downcast :: Typeable1 sub => AcidState st -> sub st downcast AcidState{acidSubState = AnyState sub}@@ -142,5 +142,5 @@          Just (Just x) -> x          _ ->            error $-            "Data.Acid: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r)+            "Data.Acid.Abstract: Invalid subtype cast: " ++ show (typeOf1 sub) ++ " -> " ++ show (typeOf1 r) #endif
src/Data/Acid/Archive.hs view
@@ -30,7 +30,7 @@ entriesToList :: Entries -> [Entry] entriesToList Done              = [] entriesToList (Next entry next) = entry : entriesToList next-entriesToList (Fail msg)        = error msg+entriesToList (Fail msg)        = error $ "Data.Acid.Archive: " <> msg  entriesToListNoFail :: Entries -> [Entry] entriesToListNoFail Done              = []
src/Data/Acid/Core.hs view
@@ -40,6 +40,7 @@ import Control.Monad                      ( liftM ) import Control.Monad.State                ( State, runState ) import qualified Data.Map as Map+import Data.Monoid                        ((<>)) import Data.ByteString.Lazy as Lazy       ( ByteString ) import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack ) @@ -117,7 +118,7 @@     = modifyMVar_ (coreState core) $ \st ->       do action st          return errorMsg-    where errorMsg = error "Access failure: Core closed."+    where errorMsg = error "Data.Acid.Core: Access failure: Core closed."  -- | Modify the state component. The resulting state is ensured to be in --   WHNF.@@ -160,12 +161,12 @@ lazyDecode :: SafeCopy a => Lazy.ByteString -> a lazyDecode inp     = case runGetLazy safeGet inp of-        Left msg  -> error msg+        Left msg  -> error $ "Data.Acid.Core: " <> msg         Right val -> val  missingMethod :: Tag -> a missingMethod tag-    = error msg+    = error $ "Data.Acid.Core: " <> msg     where msg = "This method is required but not available: " ++ show (Lazy.unpack tag) ++                 ". Did you perhaps remove it before creating a checkpoint?"
src/Data/Acid/Local.hs view
@@ -30,22 +30,21 @@ import Data.Acid.Abstract  import Control.Concurrent             ( newEmptyMVar, putMVar, takeMVar, MVar )-import Control.Exception              ( onException, evaluate )+import Control.Exception              ( onException, evaluate, Exception, throwIO ) 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 Data.Serialize                 ( runPutLazy, runGetLazy ) import Data.SafeCopy                  ( SafeCopy(..), safeGet, safePut                                       , primitive, contain ) import Data.Typeable                  ( Typeable, typeOf ) import Data.IORef-import System.FilePath                ( (</>) )--import FileIO                         ( obtainPrefixLock, releasePrefixLock, PrefixLock )+import System.FilePath                ( (</>), takeDirectory )+import System.FileLock+import System.Directory               ( createDirectoryIfMissing )   {-| State container offering full ACID (Atomicity, Consistency, Isolation and Durability)@@ -66,10 +65,13 @@                  , localCopy        :: IORef st                  , localEvents      :: FileLog (Tagged ByteString)                  , localCheckpoints :: FileLog Checkpoint-                 , localLock        :: PrefixLock+                 , localLock        :: FileLock                  } deriving (Typeable) +newtype StateIsLocked = StateIsLocked FilePath deriving (Show, Typeable) +instance Exception StateIsLocked+ -- | 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'.@@ -201,7 +203,7 @@          takeMVar mvar          closeFileLog (localEvents acidState)          closeFileLog (localCheckpoints acidState)-         releasePrefixLock (localLock acidState)+         unlockFile (localLock acidState)   where acidState = downcast abstract_state  @@ -278,15 +280,15 @@     True -> do       (n, st) <- loadCheckpoint       return $ do-        lock  <- obtainPrefixLock lockFile+        lock  <- maybeLockFile lockFile         replayEvents lock n st     False -> do-      lock    <- obtainPrefixLock lockFile-      (n, st) <- loadCheckpoint `onException` releasePrefixLock lock+      lock    <- maybeLockFile lockFile+      (n, st) <- loadCheckpoint `onException` unlockFile lock       return $ do         replayEvents lock n st   where-    lockFile = directory </> "open"+    lockFile = directory </> "open.lock"     eventsLogKey = LogKey { logDirectory = directory                           , logPrefix = "events" }     checkpointsLogKey = LogKey { logDirectory = directory@@ -317,10 +319,16 @@                                       , localCheckpoints = checkpointsLog                                       , localLock = lock                                       }+    maybeLockFile path = do+      createDirectoryIfMissing True (takeDirectory path)+      maybe (throwIO (StateIsLocked path))+                            return =<< tryLockFile path Exclusive + 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. closeLocalState :: LocalState st -> IO ()@@ -328,7 +336,7 @@     = do closeCore (localCore acidState)          closeFileLog (localEvents acidState)          closeFileLog (localCheckpoints acidState)-         releasePrefixLock (localLock acidState)+         unlockFile (localLock acidState)  createLocalArchive :: LocalState st -> IO () createLocalArchive state@@ -361,4 +369,3 @@               , closeAcidState = closeLocalState local               , acidSubState = mkAnyState local               }-
src/Data/Acid/Log.hs view
@@ -35,6 +35,7 @@ import qualified Data.ByteString.Unsafe as Strict import Data.List import Data.Maybe+import Data.Monoid                               ((<>)) import qualified Data.Serialize.Get as Get import qualified Data.Serialize.Put as Put import Data.SafeCopy                             ( safePut, safeGet, SafeCopy )@@ -148,7 +149,7 @@   modifyMVar_ (logCurrent fLog) $ \handle -> do     close handle     _ <- forkIO $ forM_ (logThreads fLog) killThread-    return $ error "FileLog has been closed"+    return $ error "Data.Acid.Log: FileLog has been closed"  readEntities :: FilePath -> IO [Lazy.ByteString] readEntities path = do@@ -157,7 +158,7 @@  where   worker Done              = []   worker (Next entry next) = entry : worker next-  worker (Fail msg)        = error msg+  worker (Fail msg)        = error $ "Data.Acid.Log: " <> msg  ensureLeastEntryId :: FileLog object -> EntryId -> IO () ensureLeastEntryId fLog youngestEntry = do@@ -310,9 +311,9 @@     case Archive.readEntries archive of       Done            -> worker logFiles       Next entry next -> return $ Just (decode' (lastEntry entry next))-      Fail msg        -> error msg+      Fail msg        -> error $ "Data.Acid.Log: " <> msg   lastEntry entry Done          = entry-  lastEntry entry (Fail msg)    = error msg+  lastEntry entry (Fail msg)    = error $ "Data.Acid.Log: " <> msg   lastEntry _ (Next entry next) = lastEntry entry next  -- Schedule a new log entry. This call does not block@@ -321,7 +322,7 @@ pushEntry :: SafeCopy object => FileLog object -> object -> IO () -> IO () pushEntry fLog object finally = atomically $ do   tid <- readTVar (logNextEntryId fLog)-  writeTVar (logNextEntryId fLog) (tid+1)+  writeTVar (logNextEntryId fLog) $! tid+1   (entries, actions) <- readTVar (logQueue fLog)   writeTVar (logQueue fLog) ( encoded : entries, finally : actions )  where@@ -342,5 +343,5 @@ decode' :: SafeCopy object => Lazy.ByteString -> object decode' inp =   case Get.runGetLazy safeGet inp of-    Left msg  -> error msg+    Left msg  -> error $ "Data.Acid.Log: " <> msg     Right val -> val
src/Data/Acid/Remote.hs view
@@ -108,6 +108,7 @@ import Data.Acid.Abstract import Data.Acid.Core import Data.Acid.Common+import Data.Monoid                                   ((<>)) import qualified Data.ByteString                     as Strict import Data.ByteString.Char8                         ( pack ) import qualified Data.ByteString.Lazy                as Lazy@@ -291,7 +292,7 @@              1 -> liftM RunUpdate get              2 -> return CreateCheckpoint              3 -> return CreateArchive-             _ -> error $ "Serialize.get for Command, invalid tag: " ++ show tag+             _ -> error $ "Data.Acid.Remote: Serialize.get for Command, invalid tag: " ++ show tag  data Response = Result Lazy.ByteString | Acknowledgement | ConnectionError @@ -305,7 +306,7 @@              0 -> liftM Result get              1 -> return Acknowledgement              2 -> return ConnectionError-             _ -> error $ "Serialize.get for Response, invalid tag: " ++ show tag+             _ -> error $ "Data.Acid.Remote: Serialize.get for Response, invalid tag: " ++ show tag  {- | Server inner-loop @@ -429,7 +430,7 @@                  getResponse leftover =                      do debugStrLn $ "listener: listening for Response."                         let go inp = case inp of-                                   Fail msg _     -> error msg+                                   Fail msg _     -> error $ "Data.Acid.Remote: " <> msg                                    Partial cont   -> do debugStrLn $ "listener: ccGetSome"                                                         bs <- ccGetSome cc 1024                                                         go (cont bs)@@ -487,7 +488,7 @@   = do let encoded = runPutLazy (safePut event)        resp <- remoteQueryCold acidState (methodTag event, encoded)        return (case runGetLazyFix safeGet resp of-                 Left msg -> error msg+                 Left msg -> error $ "Data.Acid.Remote: " <> msg                  Right result -> result)  remoteQueryCold :: RemoteState st -> Tagged Lazy.ByteString -> IO Lazy.ByteString@@ -497,7 +498,7 @@          (Result result) -> return result          ConnectionError -> do debugStrLn "retrying query event."                                remoteQueryCold rs event-         Acknowledgement    -> error "remoteQueryCold got Acknowledgement. That should never happen."+         Acknowledgement    -> error "Data.Acid.Remote: remoteQueryCold got Acknowledgement. That should never happen."  scheduleRemoteUpdate :: UpdateEvent event => RemoteState (EventState event) -> event -> IO (MVar (EventResult event)) scheduleRemoteUpdate (RemoteState fn _shutdown) event@@ -506,7 +507,7 @@        respRef <- fn (RunUpdate (methodTag event, encoded))        forkIO $ do Result resp <- takeMVar respRef                    putMVar parsed (case runGetLazyFix safeGet resp of-                                      Left msg -> error msg+                                      Left msg -> error $ "Data.Acid.Remote: " <> msg                                       Right result -> result)        return parsed
src/Data/Acid/TemplateHaskell.hs view
@@ -1,22 +1,25 @@-{-# LANGUAGE TemplateHaskell, CPP #-}+{-# LANGUAGE TemplateHaskell, CPP, NamedFieldPuns #-}+ {- Holy crap this code is messy. -}-module Data.Acid.TemplateHaskell-    ( makeAcidic-    ) where+module Data.Acid.TemplateHaskell where  import Language.Haskell.TH import Language.Haskell.TH.Ppr+import Language.Haskell.TH.ExpandSyns  import Data.Acid.Core import Data.Acid.Common -import Data.List ((\\), nub)+import Data.List ((\\), nub, delete) import Data.Maybe (mapMaybe) import Data.SafeCopy import Data.Typeable import Data.Char+import Data.Monoid ((<>)) import Control.Applicative import Control.Monad+import Control.Monad.State (MonadState)+import Control.Monad.Reader (MonadReader)  {-| Create the control structures required for acid states     using Template Haskell.@@ -62,8 +65,8 @@                    -> makeAcidic' eventNames stateName tyvars [constructor]                  TySynD _name tyvars _ty                    -> makeAcidic' eventNames stateName tyvars []-                 _ -> error "Unsupported state type. Only 'data', 'newtype' and 'type' are supported."-           _ -> error "Given state is not a type."+                 _ -> error "Data.Acid.TemplateHaskell: Unsupported state type. Only 'data', 'newtype' and 'type' are supported."+           _ -> error "Data.Acid.TemplateHaskell: Given state is not a type."  makeAcidic' :: [Name] -> Name -> [TyVarBndr] -> [Con] -> Q [Dec] makeAcidic' eventNames stateName tyvars constructors@@ -89,8 +92,8 @@ #else            VarI _name eventType _decl _fixity #endif-             -> return eventType-           _ -> error $ "Events must be functions: " ++ show eventName+             -> expandSyns eventType+           _ -> error $ "Data.Acid.TemplateHaskell: Events must be functions: " ++ show eventName  --instance (SafeCopy key, Typeable key, SafeCopy val, Typeable val) => IsAcidic State where --  acidEvents = [ UpdateEvent (\(MyUpdateEvent arg1 arg2 -> myUpdateEvent arg1 arg2) ]@@ -140,17 +143,29 @@ -- need to rename the variables in the context to match. -- -- The contexts returned by this function will have the variables renamed.-eventCxts :: Type        -- ^ State type (used for error messages)+--+-- Additionally, if the event uses MonadReader or MonadState it might look+-- like this:+--+-- > setState :: (MonadState x m, IsFoo x) => m ()+--+-- In this case we have to rename 'x' to the actual state we're going to+-- use. This is done by 'renameState'.+eventCxts :: Type        -- ^ State type           -> [TyVarBndr] -- ^ type variables that will be used for the State type in the IsAcidic instance           -> Name        -- ^ 'Name' of the event           -> Type        -- ^ 'Type' of the event           -> [Pred]      -- ^ extra context to add to 'IsAcidic' instance eventCxts targetStateType targetTyVars eventName eventType =-    let (_tyvars, cxt, _args, stateType, _resultType, _isUpdate)+    let TypeAnalysis { context = cxt, stateType }                     = analyseType eventName eventType-        eventTyVars = findTyVars stateType -- find the type variable names that this event is using for the State type-        table       = zip eventTyVars (map tyVarBndrName targetTyVars) -- create a lookup table-    in map (unify table) cxt -- rename the type variables+        -- find the type variable names that this event is using+        -- for the State type+        eventTyVars = findTyVars stateType+        -- create a lookup table+        table       = zip eventTyVars (map tyVarBndrName targetTyVars)+    in map (unify table) -- rename the type variables+       (renameState stateType targetStateType cxt)     where       -- | rename the type variables in a Pred       unify :: [(Name, Name)] -> Pred -> Pred@@ -177,8 +192,10 @@       renameName :: Pred -> [(Name, Name)] -> Name -> Name       renameName pred table n =           case lookup n table of-            Nothing -> error $ unlines [ show $ ppr_sig eventName eventType+            Nothing -> error $ unlines [ "Data.Acid.TemplateHaskell: "                                        , ""+                                       , show $ ppr_sig eventName eventType+                                       , ""                                        , "can not be used as an UpdateEvent because the class context: "                                        , ""                                        , pprint pred@@ -191,6 +208,21 @@                                        ]             (Just n') -> n' +-- | See the end of comment for 'eventCxts'.+renameState :: Type -> Type -> Cxt -> Cxt+renameState tfrom tto cxt = map renamePred cxt+  where+#if MIN_VERSION_template_haskell(2,10,0)+    renamePred p = renameType p -- in 2.10.0: type Pred = Type+#else+    renamePred (ClassP n tys) = ClassP n (map renameType tys)+    renamePred (EqualP a b)   = EqualP (renameType a) (renameType b)+#endif+    renameType n | n == tfrom = tto+    renameType (AppT a b)     = AppT (renameType a) (renameType b)+    renameType (SigT a k)     = SigT (renameType a) k+    renameType typ            = typ+ -- UpdateEvent (\(MyUpdateEvent arg1 arg2) -> myUpdateEvent arg1 arg2) makeEventHandler :: Name -> Type -> ExpQ makeEventHandler eventName eventType@@ -199,7 +231,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+          TypeAnalysis { tyvars, argumentTypes = args, stateType, isUpdate } = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs@@ -208,7 +240,7 @@           assertTyVarsOk =               case tyVarNames \\ stateTypeTyVars of                 [] -> return ()-                ns -> error $ unlines+                ns -> error $ "Data.Acid.TemplateHaskell: " <> unlines                       [show $ ppr_sig eventName eventType                       , ""                       , "can not be used as an UpdateEvent because it contains the type variables: "@@ -220,10 +252,9 @@                       , pprint stateType                       ] -- --data MyUpdateEvent = MyUpdateEvent Arg1 Arg2 --  deriving (Typeable)+makeEventDataType :: Name -> Type -> DecQ makeEventDataType eventName eventType     = do let con = normalC eventStructName [ strictType notStrict (return arg) | arg <- args ] #if MIN_VERSION_template_haskell(2,12,0)@@ -241,7 +272,7 @@           [_] -> newtypeD (return []) eventStructName tyvars con cxt           _   -> dataD (return []) eventStructName tyvars [con] cxt #endif-    where (tyvars, _cxt, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType+    where TypeAnalysis { tyvars, argumentTypes = args } = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs@@ -267,7 +298,7 @@                    [ funD 'putCopy [clause [putClause] (normalB (contained putExp)) []]                    , valD (varP 'getCopy) (normalB (contained getArgs)) []                    ]-    where (tyvars, context, args, _stateType, _resultType, _isUpdate) = analyseType eventName eventType+    where TypeAnalysis { tyvars, context, argumentTypes = args } = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs@@ -282,27 +313,39 @@   type MethodResult (MyUpdateEvent key val) = Return   type MethodState (MyUpdateEvent key val) = State key val -}-makeMethodInstance eventName eventType-    = do let preds = [ ''SafeCopy, ''Typeable ]-             ty = AppT (ConT ''Method) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))-             structType = foldl appT (conT eventStructName) (map varT (allTyVarBndrNames tyvars))-         instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return context)-                   (return ty)+makeMethodInstance eventName eventType = do+    let preds =+            [ ''SafeCopy, ''Typeable ]+        ty =+            AppT (ConT ''Method) (foldl AppT (ConT eventStructName) (map VarT (allTyVarBndrNames tyvars)))+        structType =+            foldl appT (conT eventStructName) (map varT (allTyVarBndrNames tyvars))+        instanceContext  =+            cxt $+                [ classP classPred [varT tyvar]+                | tyvar <- allTyVarBndrNames tyvars+                , classPred <- preds+                ]+                ++ map return context+    instanceD+        instanceContext+        (return ty) #if __GLASGOW_HASKELL__ >= 707-                   [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType))-                   , tySynInstD ''MethodState  (tySynEqn [structType] (return stateType))+        [ tySynInstD ''MethodResult (tySynEqn [structType] (return resultType))+        , tySynInstD ''MethodState  (tySynEqn [structType] (return stateType)) #else-                   [ tySynInstD ''MethodResult [structType] (return resultType)-                   , tySynInstD ''MethodState  [structType] (return stateType)+        [ tySynInstD ''MethodResult [structType] (return resultType)+        , tySynInstD ''MethodState  [structType] (return stateType) #endif-                   ]-    where (tyvars, context, _args, stateType, resultType, _isUpdate) = analyseType eventName eventType+        ]+    where TypeAnalysis { tyvars, context, stateType, resultType } = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs  --instance (SafeCopy key, Typeable key --         ,SafeCopy val, Typeable val) => UpdateEvent (MyUpdateEvent key val)+makeEventInstance :: Name -> Type -> DecQ makeEventInstance eventName eventType     = do let preds = [ ''SafeCopy, ''Typeable ]              eventClass = if isUpdate then ''UpdateEvent else ''QueryEvent@@ -310,34 +353,90 @@          instanceD (cxt $ [ classP classPred [varT tyvar] | tyvar <- allTyVarBndrNames tyvars, classPred <- preds ] ++ map return context)                    (return ty)                    []-    where (tyvars, context, _args, _stateType, _resultType, isUpdate) = analyseType eventName eventType+    where TypeAnalysis { tyvars, context, isUpdate } = analyseType eventName eventType           eventStructName = mkName (structName (nameBase eventName))           structName [] = []           structName (x:xs) = toUpper x : xs +data TypeAnalysis = TypeAnalysis+    { tyvars :: [TyVarBndr]+    , context :: Cxt+    , argumentTypes :: [Type]+    , stateType :: Type+    , resultType :: Type+    , isUpdate :: Bool+    } deriving (Eq, Show) --- (tyvars, cxt, args, state type, result type, is update)-analyseType :: Name -> Type -> ([TyVarBndr], Cxt, [Type], Type, Type, Bool)-analyseType eventName t-    = let (tyvars, cxt, t') = case t of-                                ForallT binds [] t' ->-                                  (binds, [], t')-                                ForallT binds cxt t' ->-                                  (binds, cxt, t')-                                _ -> ([], [], t)-          args = getArgs t'-          (stateType, resultType, isUpdate) = findMonad t'-      in (tyvars, cxt, args, stateType, resultType, isUpdate)-    where getArgs ForallT{} = error $ "Event has an invalid type signature: Nested forall: " ++ show eventName-          getArgs (AppT (AppT ArrowT a) b) = a : getArgs b-          getArgs _ = []+analyseType :: Name -> Type -> TypeAnalysis+analyseType eventName t = go [] [] [] t+  where+#if MIN_VERSION_template_haskell(2,10,0)+    getMonadReader :: Cxt -> Name -> [(Type, Type)]+    getMonadReader cxt m = do+       constraint@(AppT (AppT (ConT c) x) m') <- cxt+       guard (c == ''MonadReader && m' == VarT m)+       return (constraint, x) -          findMonad (AppT (AppT ArrowT a) b)-              = findMonad b-          findMonad (AppT (AppT (ConT con) state) result)-              | con == ''Update = (state, result, True)-              | con == ''Query  = (state, result, False)-          findMonad _ = error $ "Event has an invalid type signature: Not an Update or a Query: " ++ show eventName+    getMonadState :: Cxt -> Name -> [(Type, Type)]+    getMonadState cxt m = do+       constraint@(AppT (AppT (ConT c) x) m') <- cxt+       guard (c == ''MonadState && m' == VarT m)+       return (constraint, x)+#else+    getMonadReader :: Cxt -> Name -> [(Pred, Type)]+    getMonadReader cxt m = do+       constraint@(ClassP c [x, m']) <- cxt+       guard (c == ''MonadReader && m' == VarT m)+       return (constraint, x)++    getMonadState :: Cxt -> Name -> [(Pred, Type)]+    getMonadState cxt m = do+       constraint@(ClassP c [x, m']) <- cxt+       guard (c == ''MonadState && m' == VarT m)+       return (constraint, x)+#endif++    -- a -> b+    go tyvars cxt args (AppT (AppT ArrowT a) b)+        = go tyvars cxt (args ++ [a]) b+    -- Update st res+    -- Query st res+    go tyvars context argumentTypes (AppT (AppT (ConT con) stateType) resultType)+        | con == ''Update =+            TypeAnalysis+                { tyvars, context, argumentTypes, stateType, resultType+                , isUpdate = True+                }+        | con == ''Query  =+            TypeAnalysis+                { tyvars, context, argumentTypes, stateType, resultType+                , isUpdate = False+                }+    -- (...) => a+    go tyvars cxt args (ForallT tyvars2 cxt2 a)+        = go (tyvars ++ tyvars2) (cxt ++ cxt2) args a+    -- (MonadState state m) => ... -> m result+    -- (MonadReader state m) => ... -> m result+    go tyvars' cxt argumentTypes (AppT (VarT m) resultType)+        | [] <- queries, [(cx, stateType)] <- updates+            = TypeAnalysis+                { tyvars,  argumentTypes , stateType, resultType+                , isUpdate = True+                , context = delete cx cxt+                }++        | [(cx, stateType)] <- queries, [] <- updates+            = TypeAnalysis+                { tyvars,  argumentTypes , stateType, resultType+                , isUpdate = False+                , context = delete cx cxt+                }+      where+        queries = getMonadReader cxt m+        updates = getMonadState cxt m+        tyvars = filter ((/= m) . tyVarBndrName) tyvars'+    -- otherwise, fail+    go _ _ _ _ = error $ "Data.Acid.TemplateHaskell: Event has an invalid type signature: Not an Update, Query, MonadState, or MonadReader: " ++ show eventName  -- | find the type variables -- | e.g. State a b  ==> [a,b]
+ test-state/OldStateTest1/checkpoints-0000000000.log view
+ test-state/OldStateTest1/checkpoints.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest1/events-0000000000.log view
binary file changed (absent → 71486 bytes)
+ test-state/OldStateTest1/events-0000000681.log view
+ test-state/OldStateTest1/events.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest2/checkpoints-0000000000.log view
+ test-state/OldStateTest2/checkpoints.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest2/events-0000000000.log view
binary file changed (absent → 328 bytes)
+ test-state/OldStateTest2/events-0000000003.log view
binary file changed (absent → 446 bytes)
+ test-state/OldStateTest2/events-0000000007.log view
binary file changed (absent → 512 bytes)
+ test-state/OldStateTest2/events-0000000012.log view
binary file changed (absent → 225 bytes)
+ test-state/OldStateTest2/events-0000000014.log view
binary file changed (absent → 327 bytes)
+ test-state/OldStateTest2/events-0000000017.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000019.log view
binary file changed (absent → 1259 bytes)
+ test-state/OldStateTest2/events-0000000031.log view
binary file changed (absent → 1141 bytes)
+ test-state/OldStateTest2/events-0000000042.log view
binary file changed (absent → 215 bytes)
+ test-state/OldStateTest2/events-0000000044.log view
binary file changed (absent → 206 bytes)
+ test-state/OldStateTest2/events-0000000046.log view
binary file changed (absent → 1147 bytes)
+ test-state/OldStateTest2/events-0000000057.log view
binary file changed (absent → 205 bytes)
+ test-state/OldStateTest2/events-0000000059.log view
binary file changed (absent → 116 bytes)
+ test-state/OldStateTest2/events-0000000060.log view
binary file changed (absent → 936 bytes)
+ test-state/OldStateTest2/events-0000000069.log view
binary file changed (absent → 872 bytes)
+ test-state/OldStateTest2/events-0000000078.log view
binary file changed (absent → 111 bytes)
+ test-state/OldStateTest2/events-0000000079.log view
binary file changed (absent → 303 bytes)
+ test-state/OldStateTest2/events-0000000082.log view
binary file changed (absent → 1663 bytes)
+ test-state/OldStateTest2/events-0000000098.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000100.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000102.log view
binary file changed (absent → 209 bytes)
+ test-state/OldStateTest2/events-0000000104.log view
binary file changed (absent → 867 bytes)
+ test-state/OldStateTest2/events-0000000112.log view
binary file changed (absent → 553 bytes)
+ test-state/OldStateTest2/events-0000000117.log view
binary file changed (absent → 494 bytes)
+ test-state/OldStateTest2/events-0000000122.log view
binary file changed (absent → 414 bytes)
+ test-state/OldStateTest2/events-0000000126.log view
binary file changed (absent → 110 bytes)
+ test-state/OldStateTest2/events-0000000127.log view
binary file changed (absent → 396 bytes)
+ test-state/OldStateTest2/events-0000000131.log view
binary file changed (absent → 1059 bytes)
+ test-state/OldStateTest2/events-0000000141.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest2/events-0000000143.log view
binary file changed (absent → 653 bytes)
+ test-state/OldStateTest2/events-0000000149.log view
+ test-state/OldStateTest2/events.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest3/checkpoints-0000000000.log view
binary file changed (absent → 96 bytes)
+ test-state/OldStateTest3/checkpoints-0000000001.log view
binary file changed (absent → 192 bytes)
+ test-state/OldStateTest3/checkpoints-0000000003.log view
binary file changed (absent → 134 bytes)
+ test-state/OldStateTest3/checkpoints-0000000004.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000005.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000006.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000007.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/checkpoints-0000000008.log view
binary file changed (absent → 292 bytes)
+ test-state/OldStateTest3/checkpoints-0000000009.log view
binary file changed (absent → 301 bytes)
+ test-state/OldStateTest3/checkpoints-0000000010.log view
binary file changed (absent → 301 bytes)
+ test-state/OldStateTest3/checkpoints-0000000011.log view
binary file changed (absent → 330 bytes)
+ test-state/OldStateTest3/checkpoints-0000000012.log view
binary file changed (absent → 664 bytes)
+ test-state/OldStateTest3/checkpoints-0000000014.log view
binary file changed (absent → 708 bytes)
+ test-state/OldStateTest3/checkpoints-0000000016.log view
binary file changed (absent → 354 bytes)
+ test-state/OldStateTest3/checkpoints-0000000017.log view
binary file changed (absent → 708 bytes)
+ test-state/OldStateTest3/checkpoints-0000000019.log view
binary file changed (absent → 354 bytes)
+ test-state/OldStateTest3/checkpoints-0000000020.log view
binary file changed (absent → 747 bytes)
+ test-state/OldStateTest3/checkpoints-0000000022.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000023.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000024.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000025.log view
binary file changed (absent → 1169 bytes)
+ test-state/OldStateTest3/checkpoints-0000000028.log view
binary file changed (absent → 388 bytes)
+ test-state/OldStateTest3/checkpoints-0000000029.log view
binary file changed (absent → 778 bytes)
+ test-state/OldStateTest3/checkpoints-0000000031.log view
binary file changed (absent → 392 bytes)
+ test-state/OldStateTest3/checkpoints-0000000032.log view
binary file changed (absent → 392 bytes)
+ test-state/OldStateTest3/checkpoints-0000000033.log view
binary file changed (absent → 393 bytes)
+ test-state/OldStateTest3/checkpoints-0000000034.log view
binary file changed (absent → 1175 bytes)
+ test-state/OldStateTest3/checkpoints-0000000037.log view
binary file changed (absent → 1183 bytes)
+ test-state/OldStateTest3/checkpoints-0000000040.log view
binary file changed (absent → 387 bytes)
+ test-state/OldStateTest3/checkpoints-0000000041.log view
binary file changed (absent → 781 bytes)
+ test-state/OldStateTest3/checkpoints-0000000043.log view
binary file changed (absent → 391 bytes)
+ test-state/OldStateTest3/checkpoints-0000000044.log view
binary file changed (absent → 400 bytes)
+ test-state/OldStateTest3/checkpoints-0000000045.log view
binary file changed (absent → 400 bytes)
+ test-state/OldStateTest3/checkpoints-0000000046.log view
binary file changed (absent → 404 bytes)
+ test-state/OldStateTest3/checkpoints-0000000047.log view
+ test-state/OldStateTest3/checkpoints.version view
@@ -0,0 +1,1 @@+0.15.0
+ test-state/OldStateTest3/events-0000000000.log view
binary file changed (absent → 120 bytes)
+ test-state/OldStateTest3/events-0000000001.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000002.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000003.log view
binary file changed (absent → 310 bytes)
+ test-state/OldStateTest3/events-0000000006.log view
binary file changed (absent → 1075 bytes)
+ test-state/OldStateTest3/events-0000000016.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest3/events-0000000018.log view
binary file changed (absent → 541 bytes)
+ test-state/OldStateTest3/events-0000000023.log view
binary file changed (absent → 399 bytes)
+ test-state/OldStateTest3/events-0000000027.log view
binary file changed (absent → 214 bytes)
+ test-state/OldStateTest3/events-0000000029.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000030.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000031.log view
binary file changed (absent → 226 bytes)
+ test-state/OldStateTest3/events-0000000033.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000034.log view
binary file changed (absent → 213 bytes)
+ test-state/OldStateTest3/events-0000000036.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000037.log view
binary file changed (absent → 111 bytes)
+ test-state/OldStateTest3/events-0000000038.log view
binary file changed (absent → 324 bytes)
+ test-state/OldStateTest3/events-0000000041.log view
binary file changed (absent → 324 bytes)
+ test-state/OldStateTest3/events-0000000044.log view
binary file changed (absent → 665 bytes)
+ test-state/OldStateTest3/events-0000000051.log view
binary file changed (absent → 300 bytes)
+ test-state/OldStateTest3/events-0000000054.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000055.log view
binary file changed (absent → 353 bytes)
+ test-state/OldStateTest3/events-0000000058.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000059.log view
binary file changed (absent → 117 bytes)
+ test-state/OldStateTest3/events-0000000060.log view
binary file changed (absent → 113 bytes)
+ test-state/OldStateTest3/events-0000000061.log view
binary file changed (absent → 113 bytes)
+ test-state/OldStateTest3/events-0000000062.log view
binary file changed (absent → 214 bytes)
+ test-state/OldStateTest3/events-0000000064.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000065.log view
binary file changed (absent → 115 bytes)
+ test-state/OldStateTest3/events-0000000066.log view
binary file changed (absent → 117 bytes)
+ test-state/OldStateTest3/events-0000000067.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000068.log view
binary file changed (absent → 225 bytes)
+ test-state/OldStateTest3/events-0000000070.log view
binary file changed (absent → 558 bytes)
+ test-state/OldStateTest3/events-0000000075.log view
binary file changed (absent → 110 bytes)
+ test-state/OldStateTest3/events-0000000076.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000077.log view
binary file changed (absent → 116 bytes)
+ test-state/OldStateTest3/events-0000000078.log view
binary file changed (absent → 113 bytes)
+ test-state/OldStateTest3/events-0000000079.log view
binary file changed (absent → 234 bytes)
+ test-state/OldStateTest3/events-0000000081.log view
binary file changed (absent → 223 bytes)
+ test-state/OldStateTest3/events-0000000083.log view
binary file changed (absent → 533 bytes)
+ test-state/OldStateTest3/events-0000000088.log view
binary file changed (absent → 120 bytes)
+ test-state/OldStateTest3/events-0000000089.log view
binary file changed (absent → 326 bytes)
+ test-state/OldStateTest3/events-0000000092.log view
binary file changed (absent → 190 bytes)
+ test-state/OldStateTest3/events-0000000094.log view
binary file changed (absent → 346 bytes)
+ test-state/OldStateTest3/events-0000000097.log view
binary file changed (absent → 212 bytes)
+ test-state/OldStateTest3/events-0000000099.log view
binary file changed (absent → 95 bytes)
+ test-state/OldStateTest3/events-0000000100.log view
+ test-state/OldStateTest3/events.version view
@@ -0,0 +1,1 @@+0.15.0
+ test/Data/Acid/KeyValueStateMachine.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module instantiates the general framework in+-- 'Data.Acid.StateMachineTest' with an acid-state component that+-- implements a simple key-value store.+module Data.Acid.KeyValueStateMachine (tests) where++import           Control.DeepSeq+import           Control.Exception+import           Control.Monad.Reader+import           Control.Monad.State+import           Data.Acid+import           Data.Acid.StateMachineTest+import           Data.SafeCopy+import qualified Data.Map as Map+import           Data.Typeable+import           GHC.Generics+import           Hedgehog+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+++type Key = Int+type Value = String++data KeyValue = KeyValue !(Map.Map Key Value)+    deriving (Eq, Show, Typeable)++$(deriveSafeCopy 0 'base ''KeyValue)++-- | Insert a key into the key-value store.+insertKey :: Key -> Value -> Update KeyValue ()+insertKey key value+    = do KeyValue m <- get+         put (KeyValue (Map.insert key value m))++-- | A slightly more complicated update transaction: reverse the value+-- at the given key, and return the resulting state.  Crucially, this+-- is non-idempotent, unlike 'insertKey'.+reverseKey :: Key -> Update KeyValue KeyValue+reverseKey key+    = do KeyValue m <- get+         let r = KeyValue (Map.adjust reverse key m)+         put r+         return r++-- | An update that may fail: reverse the value at the given key, or+-- fail if it is missing.+reverseKeyOrFail :: Key -> Bomb -> Update KeyValue ()+reverseKeyOrFail key _+    = do KeyValue m <- get+         case Map.lookup key m of+           Nothing  -> failUpdate "key not in map"+           Just val -> put (KeyValue (Map.insert key (reverse val) m))++-- | An update that attempts to put an undefined state.  This transaction should+-- simply fail and not modify the state.+breakState :: Update KeyValue ()+breakState = put (throw (TransactionError "broken state"))++-- | An update that puts a partially-defined state.  Unfortunately+-- acid-state does not handle this case gracefully, and will fail with+-- 'BlockedIndefinitelyOnMVar' (see #38).  Thus this update is not+-- included in 'keyValueCommands' below.+breakState2 :: Update KeyValue ()+breakState2 = put (KeyValue (Map.singleton 1 (throw (TransactionError "broken state"))))++-- | Look up a key from the store.+lookupKey :: Key -> Query KeyValue (Maybe Value)+lookupKey key+    = do KeyValue m <- ask+         return (Map.lookup key m)++-- | Look up a key from the store, or fail if it is missing.+lookupKeyOrFail :: Key -> Bomb -> Query KeyValue Value+lookupKeyOrFail key _+    = do KeyValue m <- ask+         maybe (failQuery "key not in map") return (Map.lookup key m)++-- | Query the current value of the state.  This is not used in the+-- generated commands, but is used for checking the state we get back+-- in 'prop_restore_old_state_1' etc.+askState :: Query KeyValue KeyValue+askState = ask++$(makeAcidic ''KeyValue ['insertKey, 'reverseKey, 'reverseKeyOrFail, 'breakState, 'breakState2, 'lookupKey, 'lookupKeyOrFail, 'askState])++deriving instance Generic InsertKey+deriving instance Generic ReverseKey+deriving instance Generic ReverseKeyOrFail+deriving instance Generic BreakState+deriving instance Generic LookupKey+deriving instance Generic LookupKeyOrFail++deriving instance Show InsertKey+deriving instance Show ReverseKey+deriving instance Show ReverseKeyOrFail+deriving instance Show BreakState+deriving instance Show LookupKey+deriving instance Show LookupKeyOrFail++instance NFData InsertKey+instance NFData ReverseKey+instance NFData ReverseKeyOrFail+instance NFData BreakState+instance NFData LookupKey+instance NFData LookupKeyOrFail++genKey :: Gen Key+genKey = Gen.int (Range.constant 1 10)++genValue :: Gen Value+genValue = Gen.string (Range.constant 0 10) Gen.alphaNum++keyValueCommands :: MonadIO m => [Command Gen m (Model KeyValue)]+keyValueCommands = [ acidUpdate        (InsertKey        <$> genKey <*> genValue)+                   , acidUpdate        (ReverseKey       <$> genKey)+                   , acidUpdateMayFail (ReverseKeyOrFail <$> genKey <*> genBomb)+                   , acidUpdateMayFail (pure BreakState)+                   , acidQuery         (LookupKey        <$> genKey)+                   , acidQueryMayFail  (LookupKeyOrFail  <$> genKey <*> genBomb)+                   ]++-- | Possible initial states; because of #20 we can currently only use+-- one of these when testing the properties.+initialStates :: [KeyValue]+initialStates = [ KeyValue Map.empty+                , KeyValue (Map.singleton 1 "foo")+                ]++prop_sequential :: Property+prop_sequential = acidStateSequentialProperty (acidStateInterface fp) (pure (head initialStates)) (Range.linear 1 10) keyValueCommands+  where+    fp = "state/KeyValueSequentialTest"++prop_parallel :: Property+prop_parallel = acidStateParallelProperty (acidStateInterface fp) (pure (head initialStates)) (Range.linear 1 10) (Range.linear 1 10) keyValueCommands+  where+    fp = "state/KeyValueParallelTest"++prop_restore_old_state_1 :: Property+prop_restore_old_state_1 = restoreOldStateProperty (acidStateInterface fp) (KeyValue Map.empty) AskState r+  where+    fp = "test-state/OldStateTest1"+    r  = KeyValue (Map.fromList [(1,""),(2,""),(3,"y5Pl"),(4,""),(5,"Zc"),(6,"8aENKK")+                                ,(7,"FDzyGCz"),(8,""),(9,"xq"),(10,"1Ra1obuINa")])++prop_restore_old_state_2 :: Property+prop_restore_old_state_2 = restoreOldStateProperty (acidStateInterface fp) (KeyValue Map.empty) AskState r+  where+    fp = "test-state/OldStateTest2"+    r  = KeyValue (Map.fromList [(1,"PLwR1S6F"),(2,"0yrcVQM0c"),(3,"zAA"),(4,"prAocOc")+                                ,(5,"HM"),(6,"ENdfLrrW"),(7,"sESXGsI"),(8,"AFa69uu5")+                                ,(9,"XBvIQHX"),(10,"A2CzkvW")])++prop_restore_old_state_3 :: Property+prop_restore_old_state_3 = restoreOldStateProperty (acidStateInterface fp) (KeyValue Map.empty) AskState r+  where+    fp = "test-state/OldStateTest3"+    r  = KeyValue (Map.fromList [(1,"4"),(2,"RQ1xEc5"),(3,"aT0Hqk"),(4,"Duf")+                                ,(5,"tssCng7e0d"),(6,"uQW0hCVze"),(7,"FSCZPMGL")+                                ,(8,"q1WI9He"),(9,"IYHbWmO"),(10,"lCErPJC3")])+++tests :: IO Bool+tests = checkParallel $$(discover)
+ test/Data/Acid/StateMachineTest.hs view
@@ -0,0 +1,505 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++-- | This module provides a general framework for state-machine testing of+-- acid-state components.  It needs to be instantiated with a+-- particular acid-state component to get a concrete test.+module Data.Acid.StateMachineTest+  ( acidUpdate+  , acidUpdateMayFail+  , acidUpdateCheckFail+  , acidQuery+  , acidQueryMayFail+  , acidQueryCheckFail+  , acidStateSequentialProperty+  , acidStateParallelProperty+  , restoreOldStateProperty+  , acidStateInterface+  , AcidStateInterface(..)++  , Model(..)+  , open+  , close+  , checkpoint+  , checkpointClose+  , kill++    -- * Testing exceptions+  , TransactionError(..)+  , failQuery+  , failUpdate+  , Bomb(..)+  , explodeWHNF+  , explodeNF+  , genBomb+  ) where++import           Control.DeepSeq+import           Control.Exception (Exception, IOException, throw, catch, try, evaluate)+import           Control.Monad.Reader+import           Control.Monad.State+import qualified Data.Acid as Acid+import qualified Data.Acid.Common as Common+import qualified Data.Acid.Core as Core+import qualified Data.Acid.Local as Local+import           Data.Maybe+import qualified Data.SafeCopy as SafeCopy+import           Data.Typeable+import           Hedgehog+import qualified Hedgehog.Gen as Gen+import           System.Directory (removeDirectoryRecursive, removeFile)+import           System.IO.Unsafe (unsafePerformIO)++-- | Exception to be thrown when a query or update fails.+--+-- At the moment the only way to implement failing transactions is by+-- throwing an exception from pure code. The state machine tests+-- assume that all failures use 'failQuery' or 'failUpdate', which+-- throw this exception. Thus we can catch this exception in cases+-- where transaction failures are accepted.+--+-- Even if acid-state provided a pure way to throw and catch errors in+-- the 'Update' and 'Query' monads, we would still need to test that+-- it correctly handles exceptions thrown during transactions.+data TransactionError = TransactionError String+  deriving Show+instance Exception TransactionError++-- | Cause a 'Query' to fail in a (possibly) expected manner.  See+-- 'acidQueryMayFail' and 'acidQueryCheckFail'.+failQuery :: String -> Acid.Query s a+failQuery s = throw (TransactionError s)++-- | Cause an 'Update' to fail in a (possibly) expected manner.  See+-- 'acidUpdateMayFail' and 'acidUpdateCheckFail'.+failUpdate :: String -> Acid.Update s a+failUpdate s = throw (TransactionError s)++-- | Container for exceptions thrown from pure code.  This is+-- intended for use as an argument to transactions, for testing+-- transactions that cannot be serialised.+data Bomb = Bomb { unBomb :: Int }++instance NFData Bomb where+  rnf (Bomb n) = rnf n++-- | Slightly hacky 'Show' instance that will attempt to show+-- something sensible even if evaluating the 'Bomb' throws an+-- exception.+instance Show Bomb where+  show b = "(Bomb " ++ s ++ ")"+    where+      s = unsafePerformIO $ evaluate (show (unBomb b)) `catch` \ TransactionError{} -> return "(exploded)"++-- | Throw an exception when evaluated to WHNF.+explodeWHNF :: Bomb+explodeWHNF = throw (TransactionError "boom!")++-- | Throw an exception when evaluated to NF (but not when+-- evaluated to WHNF).+explodeNF :: Bomb+explodeNF = Bomb (throw (TransactionError "boom!"))++-- | Generate a bomb that may or may not explode (throw an exception)+-- when evaluated.+genBomb :: Gen Bomb+genBomb = Gen.element [Bomb 0, Bomb 1, Bomb 2, Bomb 3, explodeWHNF, explodeNF]++$(SafeCopy.deriveSafeCopy 0 'SafeCopy.base ''Bomb)+++-- | Model of an acid-state component, for state machine property+-- testing.  We start in 'StateAbsent' and can transition to+-- 'StateOpen' by opening the state for the first time.  Thereafter we+-- can transition between 'StateOpen' and 'StateClosed' by opening and+-- closing the state.  Both of the latter keep track of the current+-- value of the state.+data Model s (v :: * -> *)+    = StateAbsent    -- ^ State is not present on disk+    | StateClosed s  -- ^ State is present on disk, but not in memory+    | StateOpen   s (Var (Opaque (Acid.AcidState s)) v) -- ^ State is open in memory++-- | Return the handle to the acid-state component if it is open, or+-- return 'Nothing' if it is closed or absent.+modelHandle :: Model s v -> Maybe (Var (Opaque (Acid.AcidState s)) v)+modelHandle (StateOpen _ hdl) = Just hdl+modelHandle _                 = Nothing++-- | Is the state currently open?+isOpen :: Model s v -> Bool+isOpen = isJust . modelHandle++-- | Return the current value of the state, if it is present.+modelValue :: Model s v -> Maybe s+modelValue (StateClosed s) = Just s+modelValue (StateOpen s _) = Just s+modelValue StateAbsent     = Nothing+++-- | Description of the interface for performing+-- meta-operations on an acid-state, such as opening, closing and+-- checkpointing it.  The testing code is abstracted over this+-- interface so that we can substitute alternate serialisation+-- backends.+data AcidStateInterface s =+    (Typeable s, Acid.IsAcidic s, Show s)+    => AcidStateInterface+        { openState            :: s -> IO (Acid.AcidState s)+        , closeState           :: Acid.AcidState s -> IO ()+        , checkpointState      :: Acid.AcidState s -> IO ()+        , checkpointCloseState :: Acid.AcidState s -> IO ()+        , resetState           :: IO ()+        , statePath            :: FilePath+        }++-- | Standard implementation of the acid-state interface, using+-- 'SafeCopy'-based serialisation.+--+-- This takes the path to the state directory as an argument.+-- Warning: this path will be deleted/overwritten!+acidStateInterface :: (Acid.IsAcidic s, SafeCopy.SafeCopy s, Typeable s, Show s)+                   => FilePath -> AcidStateInterface s+acidStateInterface fp =+    AcidStateInterface { openState            = Acid.openLocalStateFrom fp+                       , closeState           = Acid.closeAcidState+                       , checkpointState      = Acid.createCheckpoint+                       , checkpointCloseState = Local.createCheckpointAndClose+                       , resetState           = removeDirectoryRecursive fp+                                                  `catch` (\ (_ :: IOException) -> return ())+                       , statePath            = fp+                       }+++data Open s (v :: * -> *) = Open s+  deriving Show++instance HTraversable (Open s) where+  htraverse _ (Open s) = pure (Open s)++-- | Command to open the state, given the interface to use and a+-- generator for possible initial state values.+open :: MonadIO m => AcidStateInterface s -> Gen s -> Command Gen m (Model s)+open AcidStateInterface{..} gen_initial_state =+    Command gen execute [ Require require, Update update ]+  where+    require model _ = not (isOpen model)++    gen StateAbsent   = Just (Open <$> gen_initial_state)+    gen StateClosed{} = Just (Open <$> gen_initial_state)+    gen StateOpen{}   = Nothing++    execute (Open initial_state) = liftIO (Opaque <$> openState initial_state)++    update StateAbsent     (Open s) hdl = StateOpen s hdl+    update (StateClosed s) (Open _) hdl = StateOpen s hdl+    update StateOpen{}     _        _   = error "open: state already open!"+++data WithState s (v :: * -> *) = WithState String (Var (Opaque (Acid.AcidState s)) v)+  deriving (Show)++instance HTraversable (WithState s) where+  htraverse k (WithState l v) = WithState l <$> htraverse k v++genWithState :: Applicative g => String -> Model s v -> Maybe (g (WithState s v))+genWithState l model = pure . WithState l <$> modelHandle model++-- | Command to close the state.+close :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s)+close AcidStateInterface{..} =+    Command (genWithState "Close") execute [ Require require, Update update ]+  where+    require model _ = isOpen model++    execute (WithState _ (Var (Concrete (Opaque st)))) = liftIO (closeState st)+    update (StateOpen s _) _ _ = StateClosed s+    update _               _ _ = error "close: not open"++-- | Command to take a checkpoint of the state.+checkpoint :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s)+checkpoint AcidStateInterface{..} =+    Command (genWithState "checkpoint") execute [ Require require ]+  where+    require model _ = isOpen model+    execute (WithState _ (Var (Concrete (Opaque st)))) = liftIO (checkpointState st)++-- | Command to take a checkpoint and close the state, as a single atomic action.+checkpointClose :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s)+checkpointClose AcidStateInterface{..} =+    Command (genWithState "checkpointClose") execute [ Require require, Update update ]+  where+    require model _ = isOpen model+    execute (WithState _ (Var (Concrete (Opaque st)))) = liftIO (checkpointCloseState st)+    update (StateOpen s _) _ _ = StateClosed s+    update _               _ _ = error "checkpointClose: not open"++-- | Command to simulate killing the process without closing the+-- state.  This does not actually stop the old thread, though.+--+-- The lock file is removed so that the state can be reopened+-- (otherwise further commands would immediately fail).+kill :: MonadIO m => AcidStateInterface s -> Command Gen m (Model s)+kill AcidStateInterface{..} =+    Command (genWithState "kill") execute [ Require require, Update update ]+  where+    require model _ = isOpen model+    execute WithState{} = liftIO $ removeFile (statePath ++ "/open.lock")+    update (StateOpen s _) _ _ = StateClosed s+    update _               _ _ = error "kill: not open"++++data AcidCommand s e (v :: * -> *) = AcidCommand e (Var (Opaque (Acid.AcidState s)) v)+  deriving (Show)++instance HTraversable (AcidCommand s e) where+  htraverse k (AcidCommand e s) = AcidCommand e <$> htraverse k s++-- | Translate an acid-state update into a command that executes the+-- update, given a generator of inputs.  If the update fails, the+-- property as a whole fails.+acidUpdate :: forall s e m .+              ( Acid.IsAcidic s+              , Acid.EventState e ~ s+              , Acid.UpdateEvent e+              , Show e+              , NFData e+              , Eq (Acid.EventResult e)+              , Show (Acid.EventResult e)+              , Typeable (Acid.EventResult e)+              , MonadIO m+              )+           => Gen e -> Command Gen m (Model s)+acidUpdate = acidUpdateCheckFail (\ _ _ _ _ -> failure)++-- | Translate an acid-state update into a command that executes the+-- update, given a generator of inputs.  If the update fails, the+-- property as a whole succeeds.+acidUpdateMayFail :: forall s e m .+              ( Acid.IsAcidic s+              , Acid.EventState e ~ s+              , Acid.UpdateEvent e+              , Show e+              , NFData e+              , Eq (Acid.EventResult e)+              , Show (Acid.EventResult e)+              , Typeable (Acid.EventResult e)+              , MonadIO m+              )+           => Gen e -> Command Gen m (Model s)+acidUpdateMayFail = acidUpdateCheckFail (\ _ _ _ _ -> return ())++-- | Translate an acid-state update into a command that executes the+-- update, given a generator of inputs.  If the update fails, the+-- given predicate is tested on the old and new states, the event and+-- the 'TransactionError' exception.+acidUpdateCheckFail :: forall s e m .+              ( Acid.IsAcidic s+              , Acid.EventState e ~ s+              , Acid.UpdateEvent e+              , Show e+              , NFData e+              , Eq (Acid.EventResult e)+              , Show (Acid.EventResult e)+              , Typeable (Acid.EventResult e)+              , MonadIO m+              )+           => (s -> s -> e -> TransactionError -> Test ())+           -> Gen e -> Command Gen m (Model s)+acidUpdateCheckFail allow_failure gen_event =+    Command gen execute [ Require require, Update update, Ensure ensure ]+  where+    -- Generate updates only when state is open+    gen :: Model s Symbolic -> Maybe (Gen (AcidCommand s e Symbolic))+    gen model = case modelHandle model of+                  Just st -> Just (AcidCommand <$> gen_event <*> pure st)+                  Nothing -> Nothing++    -- Execute a concrete update directly using acid-state+    execute :: AcidCommand s e Concrete -> m (Either TransactionError (Acid.EventResult e))+    execute (AcidCommand e (Var (Concrete (Opaque st)))) = liftIO (try (Acid.update st e))++    -- Shrinking updates requires the state to be open+    require :: Model s Symbolic -> AcidCommand s e Symbolic -> Bool+    require model _ = isOpen model++    -- Updates cause the model state to be updated.  This needs+    -- 'unsafePerformIO' because the update function must be pure, but+    -- we need to deal with the possibility of the transaction+    -- throwing a 'TransactionError' exception, in which case the+    -- state of the model should not change.  We need to deepseq the+    -- update event itself, in case it contains a nested error that+    -- will show up during serialisation but is not forced by+    -- executing the transaction.+    update :: Model s v+           -> AcidCommand s e v+           -> Var (Either TransactionError (Acid.EventResult e)) v+           -> Model s v+    update (StateOpen s hdl) (AcidCommand c _) _ =+        unsafePerformIO $ do+            s' <- evaluate (c `deepseq` execState (lookupMethod c) s)+                    `catch` \ (_ :: TransactionError) -> return s+            return (StateOpen s' hdl)+    update _ _ _ = error "acidUpdate: state not open"++    -- Evaluating the update directly on the model value of the old+    -- state should give the same result+    ensure :: Model s Concrete+           -> Model s Concrete+           -> AcidCommand s e Concrete+           -> Either TransactionError (Acid.EventResult e)+           -> Test ()+    ensure model0 model1 (AcidCommand c _) (Left  e) = case (modelValue model0, modelValue model1) of+      (Just v0, Just v1) -> allow_failure v0 v1 c e+      _                  -> failure+    ensure model _ (AcidCommand c _) (Right o) = case modelValue model of+      Just v  -> evalState (lookupMethod c) v === o+      Nothing -> failure++-- | Translate an acid-state query into a command that executes the+-- query, given a generator of inputs.  If the query fails, the+-- property as a whole fails.+acidQuery :: forall s e m .+              ( Acid.IsAcidic s+              , Acid.EventState e ~ s+              , Acid.QueryEvent e+              , Show e+              , Eq (Acid.EventResult e)+              , Show (Acid.EventResult e)+              , Typeable (Acid.EventResult e)+              , MonadIO m+              , Eq s+              , Show s+              )+           => Gen e -> Command Gen m (Model s)+acidQuery = acidQueryCheckFail (\ _ _ _ -> failure)++-- | Translate an acid-state query into a command that executes the+-- query, given a generator of inputs.  If the query fails, the+-- property as a whole succeeds.+acidQueryMayFail :: forall s e m .+              ( Acid.IsAcidic s+              , Acid.EventState e ~ s+              , Acid.QueryEvent e+              , Show e+              , Eq (Acid.EventResult e)+              , Show (Acid.EventResult e)+              , Typeable (Acid.EventResult e)+              , MonadIO m+              , Eq s+              , Show s+              )+           => Gen e -> Command Gen m (Model s)+acidQueryMayFail = acidQueryCheckFail (\ _ _ _ -> return ())++-- | Translate an acid-state query into a command that executes the+-- query, given a generator of inputs.  If the query fails, the given+-- predicate is tested on the state, the event and the+-- 'TransactionError' exception.+acidQueryCheckFail :: forall s e m .+              ( Acid.IsAcidic s+              , Acid.EventState e ~ s+              , Acid.QueryEvent e+              , Show e+              , Eq (Acid.EventResult e)+              , Show (Acid.EventResult e)+              , Typeable (Acid.EventResult e)+              , MonadIO m+              , Eq s+              , Show s+              )+           => (s -> e -> TransactionError -> Test ()) -> Gen e -> Command Gen m (Model s)+acidQueryCheckFail allow_failure gen_event = Command gen execute+   [ Require require+   , Ensure unchanged_model+   , Ensure correct_output+   ]+  where+    -- Generate queries only when state is open+    gen model = case modelHandle model of+                  Just st -> Just (AcidCommand <$> gen_event <*> pure st)+                  Nothing -> Nothing++    -- Execute a concrete query directly using acid-state+    execute (AcidCommand e (Var (Concrete (Opaque st)))) =+        liftIO (try (evaluate =<< Acid.query st e))++    -- Shrinking queries requires the state to be open+    require model _ = isOpen model++    -- Queries should not change the value in the model+    unchanged_model model0 model1 _ _ = modelValue model0 === modelValue model1++    -- Evaluating the query directly on the model value of the old+    -- state should give the same result+    correct_output model _ (AcidCommand c _) r = case modelValue model of+      Just v  -> case r of+                   Right o -> evalState (lookupMethod c) v === o+                   Left e  -> allow_failure v c e+      Nothing -> failure++-- | Extract the underlying method implementation in the pure 'State'+-- monad for an acid-state query or update.+lookupMethod :: (Core.Method m, Acid.IsAcidic (Core.MethodState m))+             => m -> State (Core.MethodState m) (Core.MethodResult m)+lookupMethod m = Core.lookupHotMethod mmap m+  where+    mmap = Core.mkMethodMap (Common.eventsToMethods Common.acidEvents)+++-- | Test the sequential property (agreement between model and+-- implementation) for an acid-state component, given the interface, a+-- generator for initial values of the state, and a list of commands+-- built from 'acidQuery' and 'acidUpdate'.  Additional commands will+-- be added to open and close the state.+--+-- Note that if the generator for initial values can return more than+-- one result, this will fail due to #20.+acidStateSequentialProperty :: AcidStateInterface s -> Gen s -> Range Int -> [Command Gen (TestT IO) (Model s)] -> Property+acidStateSequentialProperty i gen_initial_state range commands = property $ do+    actions <- forAll $ Gen.sequential range StateAbsent $+                 [ open i gen_initial_state+                 , close i+                 , checkpoint i+                 , checkpointClose i+                 , kill i+                 ] ++ commands ++ commands+    test $ do liftIO $ resetState i+              executeSequential StateAbsent actions++-- | Test the parallel property (absence of race conditions) for an+-- acid-state component, given the interface, a generator for initial+-- values of the state, and a list of commands built from 'acidQuery'+-- and 'acidUpdate'.  Additional commands will be added to open and+-- close the state.+--+-- Note that if the generator for initial values can return more than+-- one result, this will fail due to #20.+--+-- The state cannot be opened twice in parallel, so the length of the+-- sequential prefix must be at least 1, so that the open command+-- happens exactly once.+acidStateParallelProperty :: AcidStateInterface s -> Gen s -> Range Int -> Range Int -> [Command Gen (TestT IO) (Model s)] -> Property+acidStateParallelProperty i gen_initial_state prefix_range parallel_range commands = property $ do+    actions <- forAll $ Gen.parallel prefix_range parallel_range StateAbsent $+                 [ open i gen_initial_state+                 , checkpoint i+                 ] ++ commands ++ commands+    test $ do liftIO $ resetState i+              executeParallel StateAbsent actions++-- | Test that restoring an acid-state component (with the given initial+-- value), then executing the given query, results in the given+-- expected value.  This is mostly useful to test that restoring from+-- files created by an older version of acid-state can still be read.+restoreOldStateProperty :: (Acid.EventState e ~ s, Acid.EventResult e ~ r, Acid.QueryEvent e, Eq r, Show r)+                        => AcidStateInterface s -> s -> e -> r -> Property+restoreOldStateProperty i initial_state q expected_result = withTests 1 $ property $ test $ do+    liftIO $ removeFile (statePath i ++ "/open.lock") `catch` (\ (_ :: IOException) -> return ())+    st <- liftIO $ openState i initial_state+    r  <- liftIO $ Acid.query st q+    r === expected_result
+ test/Data/Acid/TemplateHaskellSpec.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Acid.TemplateHaskellSpec where++import Test.Hspec hiding (context)++import Data.SafeCopy (SafeCopy)+import Data.Typeable (Typeable)+import Control.DeepSeq (force)+import Control.Exception (evaluate)+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Control.Monad.Reader+import Control.Monad.State++import Data.Acid+import Data.Acid.TemplateHaskell++spec :: Spec+spec = do+    let name = mkName "foo"+        nameT = ConT name+        upperName = mkName "Foo"+        upperNameT = ConT upperName++    describe "makeEventInstance" $ do+        it "works with monomorphic types" $ do+            eventType <- runQ [t| Int -> Query Char () |]+            makeEventInstance name eventType+                `quoteShouldBe`+                    [d| instance QueryEvent $(return upperNameT) |]++        it "requires instances on polymorphic types" $ do+            let a = VarT (mkName "a")+                a' = return a+            eventType <- runQ [t| (Ord $(a')) => $(a') -> Update Char $(a') |]++            makeEventInstance name eventType+                `quoteShouldBe`+                    [d| instance (Ord $(a')) => UpdateEvent $(return upperNameT)+                    |]+++    describe "analyseType" $ do+        it "can work with the Query type" $ do+            typ <- runQ [t| Int -> Query String Char |]++            analyseType name typ+                `shouldBe` TypeAnalysis+                    { tyvars = []+                    , context = []+                    , argumentTypes = [ConT ''Int]+                    , stateType = ConT ''String+                    , resultType = ConT ''Char+                    , isUpdate = False+                    }++        it "can work with the Update type" $ do+            typ <- runQ [t| Int -> Update String Char |]++            analyseType name typ+                `shouldBe` TypeAnalysis+                    { tyvars = []+                    , context = []+                    , argumentTypes = [ConT ''Int]+                    , stateType = ConT ''String+                    , resultType = ConT ''Char+                    , isUpdate = True+                    }++        it "can work with MonadReader" $ do+            typ <- runQ [t| forall m. (MonadReader Int m) => Int -> m () |]+            analyseType name typ+                `shouldBe` TypeAnalysis+                    { tyvars = []+                    , context = []+                    , argumentTypes = [ConT ''Int]+                    , stateType = ConT ''Int+                    , resultType = TupleT 0+                    , isUpdate = False+                    }++        it "can work with MonadState" $ do+            typ <- runQ [t| forall m. (MonadState Int m) => Int -> m () |]+            analyseType name typ+                `shouldBe` TypeAnalysis+                    { tyvars = []+                    , context = []+                    , argumentTypes = [ConT ''Int]+                    , stateType = ConT ''Int+                    , resultType = TupleT 0+                    , isUpdate = True+                    }++        it "can work with many type variables (note that eventCxts later rejects this)" $ do+            let m = mkName "m"+            typ <- runQ [t| (MonadReader Int $(varT m)) => Int -> Query Int ($(varT m) ()) |]+            analyseType name typ+                `shouldBe` TypeAnalysis+                    { tyvars = []+                    , context =+#if MIN_VERSION_template_haskell(2,10,0)+                        [ ConT ''MonadReader+                            `AppT` ConT ''Int+                            `AppT` VarT m+                        ]+#else+                        [ ClassP ''MonadReader [ConT ''Int, VarT m]+                        ]+#endif+                    , argumentTypes = [ConT ''Int]+                    , stateType = ConT ''Int+                    , resultType = VarT m `AppT` TupleT 0+                    , isUpdate = False+                    }++    describe "eventCxts" $ do+        let binders = []+            stateType = ConT ''Char+        it "rejects types with constrainted type variables unknown to state" $ do+            let predicate eventType =+                    evaluate+                        . force+                        . map show+                        $ eventCxts stateType binders name eventType+            eventType <- runQ [t| forall a. (Ord a) => Int -> Query Char a |]++            predicate eventType+                `shouldThrow`+                    anyErrorCall++        it "accepts types with unconstrained type variables" $ do+            eventType <- runQ [t| forall a. Int -> Query Char a |]++            eventCxts stateType binders name eventType+                `shouldBe`+                    []+        let x = mkName "x"++        it "accepts constrained type variables in the state" $ do+            let binders = [PlainTV (mkName "x")]+                stateType = ConT ''Maybe `AppT` VarT x+            eventType <- runQ [t| forall a. (Ord a) => Int -> Query (Maybe a) Int|]++            eventCxts stateType binders name eventType+                `shouldBe`+#if MIN_VERSION_template_haskell(2,10,0)+                    [ConT ''Ord `AppT` VarT x]+#else+                    [ClassP ''Ord [VarT x]]+#endif++        it "can rename a polymorphic state" $ do+            eventType <- runQ [t| forall r m. (MonadReader r m, Ord r) => Int -> m Char |]+            eventCxts stateType binders name eventType+                `shouldBe`+#if MIN_VERSION_template_haskell(2,10,0)+                    [ConT ''Ord `AppT` ConT ''Char]+#else+                    [ClassP ''Ord [ConT ''Char]]+#endif+++quoteShouldBe :: (Eq a, Show a) => Q a -> Q [a] -> Expectation+quoteShouldBe qa qb = do+    actual <- runQ qa+    [expected] <- runQ qb+    actual `shouldBe` expected
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/StateMachine.hs view
@@ -0,0 +1,9 @@+module Main (main) where++import           Control.Monad (unless)+import           Data.Acid.KeyValueStateMachine+import           System.Exit (exitFailure)++main :: IO ()+main = do ok <- tests+          unless ok exitFailure