module System.IO.Storage
( withStore
, putValue
, getValue
, getDefaultValue
, delValue
) where
import Data.IORef ( IORef, newIORef, modifyIORef, readIORef )
import Data.List as L ( lookup, deleteFirstsBy )
import Data.Map as M ( Map, empty, lookup, insert, delete )
import Data.Dynamic ( Dynamic, toDyn, fromDyn, fromDynamic )
import Data.Typeable ( Typeable )
import Data.Function ( on )
import Control.Exception ( bracket )
import System.IO.Unsafe ( unsafePerformIO )
type ValueStore = M.Map String Dynamic
globalPeg :: IORef [(String, IORef ValueStore)]
{-# NOINLINE globalPeg #-}
globalPeg :: IORef [(String, IORef ValueStore)]
globalPeg = IO (IORef [(String, IORef ValueStore)])
-> IORef [(String, IORef ValueStore)]
forall a. IO a -> a
unsafePerformIO ([(String, IORef ValueStore)]
-> IO (IORef [(String, IORef ValueStore)])
forall a. a -> IO (IORef a)
newIORef [])
withStore :: String -> IO a -> IO a
withStore :: String -> IO a -> IO a
withStore storeName :: String
storeName action :: IO a
action = do
IORef ValueStore
store <- ValueStore -> IO (IORef ValueStore)
forall a. a -> IO (IORef a)
newIORef ValueStore
forall k a. Map k a
M.empty
let emptyStore :: (String, IORef ValueStore)
emptyStore = (String
storeName, IORef ValueStore
store)
let create :: IO ()
create = IORef [(String, IORef ValueStore)]
-> ([(String, IORef ValueStore)] -> [(String, IORef ValueStore)])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(String, IORef ValueStore)]
globalPeg ((String, IORef ValueStore)
emptyStore(String, IORef ValueStore)
-> [(String, IORef ValueStore)] -> [(String, IORef ValueStore)]
forall a. a -> [a] -> [a]
:)
let delete :: IO ()
delete = IORef [(String, IORef ValueStore)]
-> ([(String, IORef ValueStore)] -> [(String, IORef ValueStore)])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [(String, IORef ValueStore)]
globalPeg [(String, IORef ValueStore)] -> [(String, IORef ValueStore)]
forall b. [(String, b)] -> [(String, b)]
deleteStore
IO () -> (() -> IO ()) -> (() -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO ()
create (IO () -> () -> IO ()
forall a b. a -> b -> a
const IO ()
delete) (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
action)
where deleteStore :: [(String, b)] -> [(String, b)]
deleteStore xs :: [(String, b)]
xs = ((String, b) -> (String, b) -> Bool)
-> [(String, b)] -> [(String, b)] -> [(String, b)]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
deleteFirstsBy (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) (String -> String -> Bool)
-> ((String, b) -> String) -> (String, b) -> (String, b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (String, b) -> String
forall a b. (a, b) -> a
fst) [(String, b)]
xs [(String, b)]
forall b. [(String, b)]
dummyStore
dummyStore :: [(String, b)]
dummyStore = [(String
storeName, b
forall a. HasCallStack => a
undefined)]
getPrimitive :: String -> String -> IO (Maybe Dynamic)
getPrimitive :: String -> String -> IO (Maybe Dynamic)
getPrimitive storeName :: String
storeName key :: String
key = do
[(String, IORef ValueStore)]
storeList <- IORef [(String, IORef ValueStore)]
-> IO [(String, IORef ValueStore)]
forall a. IORef a -> IO a
readIORef IORef [(String, IORef ValueStore)]
globalPeg
case String
storeName String -> [(String, IORef ValueStore)] -> Maybe (IORef ValueStore)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`L.lookup` [(String, IORef ValueStore)]
storeList of
Nothing -> Maybe Dynamic -> IO (Maybe Dynamic)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Dynamic
forall a. Maybe a
Nothing
Just st :: IORef ValueStore
st -> do ValueStore
map <- IORef ValueStore -> IO ValueStore
forall a. IORef a -> IO a
readIORef IORef ValueStore
st
Maybe Dynamic -> IO (Maybe Dynamic)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Dynamic -> IO (Maybe Dynamic))
-> Maybe Dynamic -> IO (Maybe Dynamic)
forall a b. (a -> b) -> a -> b
$ String
key String -> ValueStore -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
`M.lookup` ValueStore
map
getValue :: Typeable a => String -> String -> IO (Maybe a)
getValue :: String -> String -> IO (Maybe a)
getValue storeName :: String
storeName key :: String
key = do
Maybe Dynamic
value <- String -> String -> IO (Maybe Dynamic)
getPrimitive String
storeName String
key
case Maybe Dynamic
value of
Nothing -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Maybe a
forall a. Maybe a
Nothing
Just dy :: Dynamic
dy -> Maybe a -> IO (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> IO (Maybe a)) -> Maybe a -> IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dy
getDefaultValue :: Typeable a => String -> String -> a -> IO a
getDefaultValue :: String -> String -> a -> IO a
getDefaultValue storeName :: String
storeName key :: String
key val :: a
val = do
Maybe Dynamic
value <- String -> String -> IO (Maybe Dynamic)
getPrimitive String
storeName String
key
case Maybe Dynamic
value of
Nothing -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ a
val
Just dy :: Dynamic
dy -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> IO a) -> a -> IO a
forall a b. (a -> b) -> a -> b
$ Dynamic -> a -> a
forall a. Typeable a => Dynamic -> a -> a
fromDyn Dynamic
dy a
val
putValue :: Typeable a => String -> String -> a -> IO ()
putValue :: String -> String -> a -> IO ()
putValue storeName :: String
storeName key :: String
key value :: a
value = do
[(String, IORef ValueStore)]
storeList <- IORef [(String, IORef ValueStore)]
-> IO [(String, IORef ValueStore)]
forall a. IORef a -> IO a
readIORef IORef [(String, IORef ValueStore)]
globalPeg
case String
storeName String -> [(String, IORef ValueStore)] -> Maybe (IORef ValueStore)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`L.lookup` [(String, IORef ValueStore)]
storeList of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just st :: IORef ValueStore
st -> IORef ValueStore -> (ValueStore -> ValueStore) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ValueStore
st ((ValueStore -> ValueStore) -> IO ())
-> (a -> ValueStore -> ValueStore) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Dynamic -> ValueStore -> ValueStore
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
key (Dynamic -> ValueStore -> ValueStore)
-> (a -> Dynamic) -> a -> ValueStore -> ValueStore
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ a
value
delValue :: String -> String -> IO ()
delValue :: String -> String -> IO ()
delValue storeName :: String
storeName key :: String
key = do
[(String, IORef ValueStore)]
storeList <- IORef [(String, IORef ValueStore)]
-> IO [(String, IORef ValueStore)]
forall a. IORef a -> IO a
readIORef IORef [(String, IORef ValueStore)]
globalPeg
case String
storeName String -> [(String, IORef ValueStore)] -> Maybe (IORef ValueStore)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`L.lookup` [(String, IORef ValueStore)]
storeList of
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just st :: IORef ValueStore
st -> IORef ValueStore -> (ValueStore -> ValueStore) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef ValueStore
st ((ValueStore -> ValueStore) -> IO ())
-> (String -> ValueStore -> ValueStore) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ValueStore -> ValueStore
forall k a. Ord k => k -> Map k a -> Map k a
M.delete (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
key