{- |
Conceptually, this library provides a way to arbitrarily extend the
global state represented by the IO monad. Viewed another way, this
library provides a basic facility for setting and retrieving values
from global variables.

The interface takes the form of a very basic key-value store, with
multiple different stores made available through the 'withStore'
function. Stores are referenced by arbitrary strings, and keys
within those stores are treated likewise. The 'putValue', 'getValue',
and 'delValue' functions allow you to store, retrieve, and delete
data from the store.

Internally, data is stored within an IORef which is created using the
'unsafePerformIO hack', but this is hidden within the library so that
it can easily be modified if and when a more 'proper' solution is
implemented.
-}
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

-- | This is the magic bit that makes the data-stores global to the
--   entire program. Sure, it cheats a little, but who doesn't?
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 [])

-- | Create a named key-value store, and then execute the given
--   IO action within its extent. Calls to 'withStore' can be
--   nested, and calling it again with the name of a data-store
--   that has already been initialized will cause the original
--   to be shadowed for the duration of the call to 'withStore'.
withStore :: String -> IO a -> IO a
withStore :: forall a. String -> IO a -> IO a
withStore String
storeName 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 [(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 String
storeName 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
         Maybe (IORef ValueStore)
Nothing -> Maybe Dynamic -> IO (Maybe Dynamic)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Dynamic
forall a. Maybe a
Nothing
         Just 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

-- | Get a value from the given data-store, if it exists. If it
--   doesn't exist, obviously, 'Nothing' will be returned.
getValue :: Typeable a => String -> String -> IO (Maybe a)
getValue :: forall a. Typeable a => String -> String -> IO (Maybe a)
getValue String
storeName String
key = do
    Maybe Dynamic
value <- String -> String -> IO (Maybe Dynamic)
getPrimitive String
storeName String
key
    case Maybe Dynamic
value of
         Maybe Dynamic
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 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

-- | Get a value from the given store, with a default if it
--   doesn't exist.
getDefaultValue :: Typeable a => String -> String -> a -> IO a
getDefaultValue :: forall a. Typeable a => String -> String -> a -> IO a
getDefaultValue String
storeName String
key a
val = do
    Maybe Dynamic
value <- String -> String -> IO (Maybe Dynamic)
getPrimitive String
storeName String
key
    case Maybe Dynamic
value of
         Maybe Dynamic
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 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

-- | Put a value into the given data-store.
putValue :: Typeable a => String -> String -> a -> IO ()
putValue :: forall a. Typeable a => String -> String -> a -> IO ()
putValue String
storeName String
key 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
         Maybe (IORef ValueStore)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Just 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

-- | Delete a value from the given data-store.
delValue :: String -> String -> IO ()
delValue :: String -> String -> IO ()
delValue String
storeName 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
         Maybe (IORef ValueStore)
Nothing -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
         Just 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