Hiding STM behind a generic IO storage interface

Main.hs

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