    {- |
    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
        store <- ValueStore -> IO (IORef ValueStore)
    forall a. a -> IO (IORef a)
    newIORef ValueStore
    forall k a. Map k a
    M.empty
        let emptyStore = (String
    storeName, IORef ValueStore
    store)
        let 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 = 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
        bracket create (const delete) (const 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
        storeList <- IORef [(String, IORef ValueStore)]
    -> IO [(String, IORef ValueStore)]
    forall a. IORef a -> IO a
    readIORef IORef [(String, IORef ValueStore)]
    globalPeg
        case storeName `L.lookup` storeList of
             Maybe (IORef ValueStore)
    Nothing -> Maybe Dynamic -> IO (Maybe Dynamic)
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Dynamic
    forall a. Maybe a
    Nothing
             Just IORef ValueStore
    st -> do map <- IORef ValueStore -> IO ValueStore
    forall a. IORef a -> IO a
    readIORef IORef ValueStore
    st
                           return $ key `M.lookup` 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
        value <- String -> String -> IO (Maybe Dynamic)
    getPrimitive String
    storeName String
    key
        case value of
             Maybe Dynamic
    Nothing -> Maybe a -> IO (Maybe a)
    forall a. a -> IO 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 a. a -> IO 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
        value <- String -> String -> IO (Maybe Dynamic)
    getPrimitive String
    storeName String
    key
        case value of
             Maybe Dynamic
    Nothing -> a -> IO a
    forall a. 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 a. 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
        storeList <- IORef [(String, IORef ValueStore)]
    -> IO [(String, IORef ValueStore)]
    forall a. IORef a -> IO a
    readIORef IORef [(String, IORef ValueStore)]
    globalPeg
        case storeName `L.lookup` storeList of
             Maybe (IORef ValueStore)
    Nothing -> () -> IO ()
    forall a. a -> IO a
    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
        storeList <- IORef [(String, IORef ValueStore)]
    -> IO [(String, IORef ValueStore)]
    forall a. IORef a -> IO a
    readIORef IORef [(String, IORef ValueStore)]
    globalPeg
        case storeName `L.lookup` storeList of
             Maybe (IORef ValueStore)
    Nothing -> () -> IO ()
    forall a. a -> IO a
    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