1.type-class.hs

{-# LANGUAGE OverloadedStrings #-}
import Prelude hiding (read)

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.IORef

type Key   = ByteString
type Value = ByteString

-- | CRUDを備えたKeyValueストアの簡単なインターフェース
class DataStore ds where
  create :: Key -> Value -> ds -> IO ()
  read   :: Key          -> ds -> IO (Maybe Value)
  update :: Key -> Value -> ds -> IO ()
  delete :: Key          -> ds -> IO ()

-- | 与えられたKeyがすでに存在すればupdate, 存在しなければinsertする
createOrUpdate :: DataStore ds => Key -> Value -> ds -> IO ()
createOrUpdate k v ds = do
  peek <- read k ds
  case peek of
    Just _  -> update k v ds
    Nothing -> create k v ds

-- | IORefを用いたKVSの簡単な実装
newtype IORefImpl = IORefImpl (IORef [(Key, Value)])

updateList :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
updateList k v = map (\r@(k', _) -> if k' == k then (k, v) else r)

deleteList :: Eq k => k -> [(k, v)] -> [(k, v)]
deleteList k = filter (\(k', _) -> k' /= k)

instance DataStore IORefImpl where
  create k v (IORefImpl ref) = modifyIORef ref ((k, v):)
  read   k   (IORefImpl ref) = lookup k <$> readIORef ref
  update k v (IORefImpl ref) = modifyIORef ref (updateList k v)
  delete k   (IORefImpl ref) = modifyIORef ref (deleteList k)

-- | 実際に処理は行わないモック用の実装
data MockImpl = MockImpl

instance DataStore MockImpl where
  create k v _ = BS.putStrLn $ BS.concat ["Create: ", k, ", ", v]
  read   k   _ = Nothing <$ (BS.putStrLn $ BS.concat ["Read: ", k])
  update k v _ = BS.putStrLn $ BS.concat ["Update: ", k, ", ", v]
  delete k   _ = BS.putStrLn $ BS.concat ["Delete: ", k]

2.reader-monad.hs

import Prelude hiding (read)

import Control.Monad.Reader
import Data.ByteString (ByteString)

type Key   = ByteString
type Value = ByteString

class DataStore ds where
  create :: Key -> Value -> ReaderT ds IO ()
  read   :: Key          -> ReaderT ds IO (Maybe Value)
  update :: Key -> Value -> ReaderT ds IO ()
  delete :: Key          -> ReaderT ds IO ()

createOrUpdate :: DataStore ds => Key -> Value -> ReaderT ds IO ()
createOrUpdate k v = do
    peek <- read k
    case peek of
      Just _  -> update k v
      Nothing -> create k v


-- | RedisをKVSとして利用する実装
data RedisImpl = RedisImpl

handleError :: Show a => Either a b -> b
handleError = either (error . show) id

{- -- コンパイルの通らない DataStore のインスタンス
instance DataStore RedisImpl where
  create k v _ = ()          <$  Redis.set k v
  read   k   _ = handleError <$> Redis.get k v
  update k v _ = ()          <$  Redis.set k v
  delete k   _ = ()          <$  Redis.del [k]
-}

3.tagless-final.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}

import Prelude hiding (read)

import Control.Monad.Reader
import Control.Monad.Trans (lift)
import Control.Lens
import Data.Aeson hiding (Value)
import qualified Data.Aeson as Aeson
import Data.Aeson.Lens
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.IORef
import Database.Redis (Redis)
import qualified Database.Redis as Redis
import Network.HTTP.Conduit

type Key   = ByteString
type Value = ByteString

class Monad repr => DataStoreSYM repr where
  create :: Key -> Value -> repr ()
  read   :: Key          -> repr (Maybe Value)
  update :: Key -> Value -> repr ()
  delete :: Key          -> repr ()

createOrUpdate :: DataStoreSYM repr => Key -> Value -> repr ()
createOrUpdate k v = do
  peek <- read k
  case peek of
    Just _  -> update k v
    Nothing -> create k v

instance DataStoreSYM IO where
  create k v = BS.putStrLn $ BS.concat ["Create: ", k, ", ", v]
  read   k   = Nothing <$ (BS.putStrLn $ BS.concat ["Read: ", k])
  update k v = BS.putStrLn $ BS.concat ["Update: ", k, ", ", v]
  delete k   = BS.putStrLn $ BS.concat ["Delete: ", k]

runMockDS :: IO a -> IO a
runMockDS = id

type IORefDS = ReaderT (IORef [(Key, Value)]) IO

updateList :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
updateList k v = map (\r@(k', _) -> if k' == k then (k, v) else r)

deleteList :: Eq k => k -> [(k, v)] -> [(k, v)]
deleteList k = filter (\(k', _) -> k' /= k)

instance DataStoreSYM IORefDS where
  create k v = ask >>= (\ref -> liftIO $ modifyIORef ref ((k, v):))
  read   k   = ask >>= (\ref -> liftIO $ lookup k <$> readIORef ref)
  update k v = ask >>= (\ref -> liftIO $ modifyIORef ref (updateList k v))
  delete k   = ask >>= (\ref -> liftIO $ modifyIORef ref (deleteList k))

runIORefDS :: IORef [(Key, Value)] -> IORefDS a -> IO a
runIORefDS ref dsl = runReaderT dsl ref

handleError :: Show a => Either a b -> b
handleError = either (error . show) id

instance DataStoreSYM Redis where
  create k v = ()          <$  Redis.set k v
  read   k   = handleError <$> Redis.get k
  update k v = ()          <$  Redis.set k v
  delete k   = ()          <$  Redis.del [k]

type Price = Double

class Monad repr => BitcoinSYM repr where
  getPrice :: repr Double

saveBTCPrice :: (BitcoinSYM repr, DataStoreSYM repr) => repr ()
saveBTCPrice = do
  price <- getPrice
  createOrUpdate "BTC Price" (BS.pack $ show price)

instance BitcoinSYM IO where
  getPrice = putStrLn "Get BTC price" >> pure 1000000.0

runMockBTC :: IO a -> IO a
runMockBTC = id

type BitFlyer = ReaderT Manager IO

getBitFlyerBitcoinPrice :: Manager -> IO Price
getBitFlyerBitcoinPrice manager = do
  body <- responseBody <$> httpLbs "https://api.bitflyer.jp/v1/ticker" manager
  pure $ (decode body :: Maybe Aeson.Value) ^?! _Just . key "ltp" . _Double

instance BitcoinSYM BitFlyer where
  getPrice = ask >>= (\manager -> liftIO $ getBitFlyerBitcoinPrice manager)

runBitFlyer :: Manager -> BitFlyer a -> IO a
runBitFlyer manager dsl = runReaderT dsl manager

4.free-monad.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}

import Prelude hiding (read)

import Control.Monad.Free (toFreeT, foldFree)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans (lift)
import Control.Monad.Trans.Free
import Control.Lens
import Data.Aeson hiding (Value)
import qualified Data.Aeson as Aeson
import Data.Aeson.Lens
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.IORef
import Network.HTTP.Conduit

type Key   = ByteString
type Value = ByteString

data DataStoreF a = Create Key Value (() -> a)
                  | Read   Key       (Maybe Value -> a)
                  | Update Key Value (() -> a)
                  | Delete Key       (() -> a)
                  deriving Functor

type DataStoreT m = FreeT DataStoreF m

create k v = liftF $ Create k v id
read   k   = liftF $ Read   k   id
update k v = liftF $ Update k v id
delete k   = liftF $ Delete k   id

createOrUpdate :: Monad m => Key -> Value -> DataStoreT m ()
createOrUpdate k v = do
  peek <- read k
  case peek of
    Just _  -> update k v
    Nothing -> create k v

runMockDS :: MonadIO io => DataStoreT io a -> io a
runMockDS = iterT interpret
  where
    interpret (Create k v r) = r =<< liftIO (BS.putStrLn $ BS.concat ["Create: ", k, ", ", v])
    interpret (Read   k   r) = r =<< liftIO (Nothing <$ (BS.putStrLn $ BS.concat ["Read: ", k]))
    interpret (Update k v r) = r =<< liftIO (BS.putStrLn $ BS.concat ["Update: ", k, ", ", v])
    interpret (Delete k   r) = r =<< liftIO (BS.putStrLn $ BS.concat ["Delete: ", k])

updateList :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
updateList k v = map (\r@(k', _) -> if k' == k then (k, v) else r)

deleteList :: Eq k => k -> [(k, v)] -> [(k, v)]
deleteList k = filter (\(k', _) -> k' /= k)

runIORefDS :: MonadIO io => IORef [(Key, Value)] -> DataStoreT io a -> io a
runIORefDS ref = iterT interpret
  where
    interpret (Create k v r) = r =<< liftIO (modifyIORef ref ((k, v):))
    interpret (Read   k   r) = r =<< liftIO (lookup k <$> readIORef ref)
    interpret (Update k v r) = r =<< liftIO (modifyIORef ref (updateList k v))
    interpret (Delete k   r) = r =<< liftIO (modifyIORef ref (deleteList k))


type Price = Double

data BitcoinF a = GetPrice (Price -> a) deriving Functor

type BitcoinT m = FreeT BitcoinF m

getPrice :: MonadFree BitcoinF m => m Price
getPrice = liftF $ GetPrice id

getBitFlyerBitcoinPrice :: Manager -> IO Price
getBitFlyerBitcoinPrice manager = do
  body <- responseBody <$> httpLbs "https://api.bitflyer.jp/v1/ticker" manager
  pure $ (decode body :: Maybe Aeson.Value) ^?! _Just . key "ltp" . _Double

runBitFlyer :: MonadIO io => Manager -> BitcoinT io a -> io a
runBitFlyer manager = iterT interpret
  where
    interpret (GetPrice r) = r =<< (liftIO $ getBitFlyerBitcoinPrice manager)

saveBTCPrice :: DataStoreT (BitcoinT IO) ()
saveBTCPrice = do
  price <- lift $ getPrice
  createOrUpdate "BTC Price" (BS.pack $ show price)

5.extensible-effects.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}

import Prelude hiding (read)

import Control.Monad.Freer
import Control.Lens
import Data.Aeson hiding (Value)
import qualified Data.Aeson as Aeson
import Data.Aeson.Lens
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.IORef
import Network.HTTP.Conduit

type Key   = ByteString
type Value = ByteString

data DataStore a where
  Create :: Key -> Value -> DataStore ()
  Read   :: Key          -> DataStore (Maybe Value)
  Update :: Key -> Value -> DataStore ()
  Delete :: Key          -> DataStore ()

create k v = send $ Create k v
read   k   = send $ Read   k
update k v = send $ Update k v
delete k v = send $ Delete k

createOrUpdate :: Member DataStore effs => Key -> Value -> Eff effs ()
createOrUpdate k v = do
  peek <- read k
  case peek of
    Just _  -> update k v
    Nothing -> create k v

updateList :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
updateList k v = map (\r@(k', _) -> if k' == k then (k, v) else r)

deleteList :: Eq k => k -> [(k, v)] -> [(k, v)]
deleteList k = filter (\(k', _) -> k' /= k)

runIORefDS :: Member IO effs => IORef [(Key, Value)] -> Eff (DataStore ': effs) a -> Eff effs a
runIORefDS ref = runNat @IO interpret
  where
    interpret :: forall a. DataStore a -> IO a
    interpret (Create k v) = modifyIORef ref ((k, v):)
    interpret (Read   k)   = lookup k <$> readIORef ref
    interpret (Update k v) = modifyIORef ref (updateList k v)
    interpret (Delete k)   = modifyIORef ref (deleteList k)

type Price = Double

data BitFlyer a where
  GetPrice :: BitFlyer Price

getPrice :: Member BitFlyer effs => Eff effs Price
getPrice = send GetPrice

runBitFlyer :: Member IO effs => Manager -> Eff (BitFlyer ': effs) a -> Eff effs a
runBitFlyer manager = runNat @IO interpret
  where
    interpret :: forall a. BitFlyer a -> IO a
    interpret GetPrice = getBitFlyerBitcoinPrice manager

getBitFlyerBitcoinPrice :: Manager -> IO Price
getBitFlyerBitcoinPrice manager = do
  body <- responseBody <$> httpLbs "https://api.bitflyer.jp/v1/ticker" manager
  pure $ (decode body :: Maybe Aeson.Value) ^?! _Just . key "ltp" . _Double

saveBTCPrice :: (Member BitFlyer effs, Member DataStore effs) => Eff effs ()
saveBTCPrice = do
  price <- getPrice
  createOrUpdate "BTC Price" (BS.pack $ show price)

6.tagless-final-and-extensible-effects.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE RankNTypes #-}

import Prelude hiding (read)

import Control.Monad.Freer
import Control.Monad.Freer.Reader
import Control.Lens
import Data.Aeson hiding (Value)
import qualified Data.Aeson as Aeson
import Data.Aeson.Lens
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.IORef
import Network.HTTP.Conduit

type Key   = ByteString
type Value = ByteString

class Monad repr => DataStoreSYM repr where
  create :: Key -> Value -> repr ()
  read   :: Key          -> repr (Maybe Value)
  update :: Key -> Value -> repr ()
  delete :: Key          -> repr ()

createOrUpdate :: DataStoreSYM repr => Key -> Value -> repr ()
createOrUpdate k v = do
  peek <- read k
  case peek of
    Just _  -> update k v
    Nothing -> create k v

updateList :: Eq k => k -> v -> [(k, v)] -> [(k, v)]
updateList k v = map (\r@(k', _) -> if k' == k then (k, v) else r)

deleteList :: Eq k => k -> [(k, v)] -> [(k, v)]
deleteList k = filter (\(k', _) -> k' /= k)

data IORefDS = IORefDS { getIORefDS :: IORef [(Key, Value)] }

instance (Member (Reader IORefDS) effs, Member IO effs) => DataStoreSYM (Eff effs) where
  create k v = asks getIORefDS >>= (\ref -> send $ modifyIORef ref ((k, v):))
  read   k   = asks getIORefDS >>= (\ref -> send $ lookup k <$> readIORef ref)
  update k v = asks getIORefDS >>= (\ref -> send $ modifyIORef ref (updateList k v))
  delete k   = asks getIORefDS >>= (\ref -> send $ modifyIORef ref (deleteList k))

type Price = Double

class Monad repr => BitcoinSYM repr where
  getPrice :: repr Price

data BitFlyer = BitFlyer { getBitFlyer ::  Manager }

instance (Member (Reader BitFlyer) effs, Member IO effs) => BitcoinSYM (Eff effs) where
  getPrice = asks getBitFlyer >>= (\manager -> send $ getBitFlyerBitcoinPrice manager)

getBitFlyerBitcoinPrice :: Manager -> IO Price
getBitFlyerBitcoinPrice manager = do
  body <- responseBody <$> httpLbs "https://api.bitflyer.jp/v1/ticker" manager
  pure $ (decode body :: Maybe Aeson.Value) ^?! _Just . key "ltp" . _Double

saveBTCPrice :: (BitcoinSYM repr, DataStoreSYM repr) => repr ()
saveBTCPrice = do
  price <- getPrice
  createOrUpdate "BTC Price" (BS.pack $ show price)