1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
|
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module KeyValueNoTH (main) where
import Data.Acid
import Data.Acid.Advanced
import Control.Applicative
import Control.Monad
import Control.Monad.Reader (ask)
import qualified Control.Monad.State as State
import Data.SafeCopy
import System.Environment
import System.IO
import qualified Data.Map as Map
------------------------------------------------------
-- The Haskell structure that we want to encapsulate
type Key = String
type Value = String
data KeyValue = KeyValue !(Map.Map Key Value)
instance SafeCopy KeyValue where
putCopy (KeyValue state) = contain $ safePut state
getCopy = contain $ liftM KeyValue safeGet
------------------------------------------------------
-- The transaction we will execute over the state.
insertKey :: Key -> Value -> Update KeyValue ()
insertKey key value
= do KeyValue m <- State.get
State.put (KeyValue (Map.insert key value m))
lookupKey :: Key -> Query KeyValue (Maybe Value)
lookupKey key
= do KeyValue m <- ask
return (Map.lookup key m)
------------------------------------------------------
-- This is how AcidState is used:
main :: IO ()
main = do acid <- openLocalState (KeyValue Map.empty)
args <- getArgs
case args of
[key]
-> do mbKey <- query acid (LookupKey key)
case mbKey of
Nothing -> putStrLn $ key ++ " has no associated value."
Just value -> putStrLn $ key ++ " = " ++ value
[key,val]
-> do update acid (InsertKey key val)
putStrLn "Done."
_ -> do putStrLn "Usage:"
putStrLn " key Lookup the value of 'key'."
putStrLn " key value Set the value of 'key' to 'value'."
closeAcidState acid
------------------------------------------------------
-- The gritty details. These things may be done with
-- Template Haskell in the future.
data InsertKey = InsertKey Key Value
data LookupKey = LookupKey Key
instance SafeCopy InsertKey where
putCopy (InsertKey key value) = contain $ safePut key >> safePut value
getCopy = contain $ InsertKey <$> safeGet <*> safeGet
instance Method InsertKey where
type MethodResult InsertKey = ()
type MethodState InsertKey = KeyValue
instance UpdateEvent InsertKey
instance SafeCopy LookupKey where
putCopy (LookupKey key) = contain $ safePut key
getCopy = contain $ LookupKey <$> safeGet
instance Method LookupKey where
type MethodResult LookupKey = Maybe Value
type MethodState LookupKey = KeyValue
instance QueryEvent LookupKey
instance IsAcidic KeyValue where
acidEvents = [ UpdateEvent (\(InsertKey key value) -> insertKey key value) safeCopyMethodSerialiser
, QueryEvent (\(LookupKey key) -> lookupKey key) safeCopyMethodSerialiser
]
|
