Skip to content

Instantly share code, notes, and snippets.

@juxtin
Last active August 29, 2017 01:14
Show Gist options
  • Save juxtin/392c0cc0468f42f8fa9bf9b55efd9d78 to your computer and use it in GitHub Desktop.
Save juxtin/392c0cc0468f42f8fa9bf9b55efd9d78 to your computer and use it in GitHub Desktop.
Hiding STM behind a generic IO storage interface
module Main where
import Control.Concurrent.STM
import Data.Map as M
type MapDB = M.Map Integer String
main :: IO ()
main = do
stg <- initStorage
putStrLn "Adding 1 -> 'there'"
put stg 1 "there"
putStrLn "Adding 0 -> 'hi'"
put stg 0 "hi"
putStrLn "Adding 2 -> 'my friend'"
put stg 2 "my friend"
putStrLn "-----------------------"
putStr "0 -> "
(Just hi) <- get stg 0
putStrLn hi
putStr "1 -> "
(Just there) <- get stg 1
putStrLn there
putStr "2 -> "
(Just friend) <- get stg 2
putStrLn friend
mapPut :: MapDB -> Integer -> String -> MapDB
mapPut db key value = M.insert key value db
mapGet :: MapDB -> Integer -> Maybe String
mapGet db key = M.lookup key db
initDB' :: MapDB -> IO (TVar MapDB)
initDB' db = atomically $ newTVar db
initDB :: IO (TVar MapDB)
initDB = initDB' M.empty
deref :: TVar a -> IO a
deref = atomically . readTVar
class Storage a where
put :: a -> Integer -> String -> IO ()
get :: a -> Integer -> IO (Maybe String)
newtype MapStorage = MapStorage (TVar MapDB)
instance Storage MapStorage where
put (MapStorage db) k v = do
db' <- deref db
let new = mapPut db' k v
atomically $ writeTVar db new
return ()
get (MapStorage db) k = do
db' <- deref db
return $ mapGet db' k
initStorage :: IO MapStorage
initStorage = do
db <- initDB
return $ MapStorage db
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment