これは FOLIO Advent Calendar 2017 14日目の投稿です。
HaskellでDIを実装する一番いい方法は何か、様々な手法を比較しながらベストな方法を探していこうと思います。
記事中のコードは記述を簡潔にするため実行に必要なGHC拡張やimportを書いていません。完全なコードは以下のgistに載せているので参照して下さい。
https://gist.github.com/lotz84/7207fa3a6b806807defd04e773f8dc78
易しい依存性の注入
DI(Dependency Injection, 依存性の注入)とは何でしょうか。Wikipediaから説明を引用すると、
依存性の注入とは、コンポーネント間の依存関係をプログラムのソースコードから排除し、外部の設定ファイルなどで注入できるようにするソフトウェアパターンである。英語の頭文字からDIと略される。
とあります。依存関係を排除するためによく使われる手法は プログラムのインターフェースと実装を何らかの言語機能を使って分離して 依存関係のあるプログラムをそのインターフェースだけを利用して書く方法でしょう。例えば簡単なKey-Valueストア(KVS)とやり取りするプログラムを書くとします。Haskellだと以下のように型クラスを使えばインターフェースと実装を分離することができます。
type Key = ByteString
type Value = ByteString
-- | KVSの簡単なインターフェース
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
上記例のcreateOrUpdate
は型クラスDataStore
を利用して書かれているので実際に使用する際はDataStore
のインスタンスを好きに入れ替えることができます。例えば以下のような2つのDataStore
のインスタンスを考えてみましょう。
-- | 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]
IORefImpl
はIORef
で参照しているリストのデータを操作することで実際に簡単なKVSとして動作します。MockImpl
は単純な出力しか行わないモック用の実装でテストの時など実際のKVSに接続しないような時に使うことを想定しています。このように型クラスを使って実装を分離できるようにすると「テストの時だけモックを使用する」ようなことが簡単に実現できます1。実際にこれらが動作するか見てみましょう。
> createOrUpdate "key" "value" MockImpl
Read: key
Create: key, value
> ref <- newIORef ([] :: [(Key, Value)])
> createOrUpdate "key" "value" (IORefImpl ref)
> readIORef ref
[("key","value")]
期待通りに動いていますね。
Readerモナド
DataStore
の定義をもう一度見てみましょう
class DataStore ds where
create :: Key -> Value -> ds -> IO ()
read :: Key -> ds -> IO (Maybe Value)
update :: Key -> Value -> ds -> IO ()
delete :: Key -> ds -> IO ()
全てのメソッドがds
を引数にとっていますね。これをReaderモナドを使った型に書き直してみましょう。
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 ()
IO
と合成するためにモナド変換子を使っています。この定義を使うと createOrUpdate
の実装は以下のようになります。
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
変数を渡すというパターンをモナドに押し付けたことで 元のコードと比較するとds
だけを綺麗に消すことができました
このReader
とIO
を組み合わせる方法はとても便利で、rioというライブラリではRIO
(=Reader+IO)という専用のモナドが提供されていたり、reflectionと存在型を使って汎用的に実装する方法も考案されています2。型クラスを使ってインターフェースと実装を分離し、Readerモナドを使って依存性の注入を書くコストが減らせたのでかなり理想に近づいてきた気がします。しかし、次のような例を考えてみましょう。
-- | RedisをKVSとして利用する実装
data RedisImpl = RedisImpl
handleError :: Show a => Either a b -> b
handleError = either (error . show) id
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]
この例はhedisを使ってRedisを利用することを想定しています。ですがこの実装ではコンパイルが通りません。なぜならRedisImpl
のDataStore
のインスタンスは
class DataStore ds where
create :: Key -> Value -> ds -> Redis ()
read :: Key -> ds -> Redis (Maybe Value)
update :: Key -> Value -> ds -> Redis ()
delete :: Key -> ds -> Redis ()
のような型クラスを期待していますが、実際の返り値を包む型はRedis
ではなくIO
だからです。この例のようにDIでは注入する実装によって引き起こす副作用が違うことはよくあることです。例えば本番環境ではAmazon SESを使ってメールを送るからIO
でだけど、開発環境ではログを吐きたいからLoggingT
にしたいというケースもあるでしょう。Haskellは副作用を型で表すので、HaskellでのDIは注入する実装によって返り値の型が変えられることが望ましいでしょう。
Tagless Final
ならば型クラスの対象にする型を 引数の型 ではなく 返り値の型 にすればどうでしょうか。
class Monad repr => DataStoreSYM repr where
create :: Key -> Value -> repr ()
read :: Key -> repr (Maybe Value)
update :: Key -> Value -> repr ()
delete :: Key -> repr ()
この方法は驚くほどうまくいきます。実際repr
をReaderT ds IO
やRedis
に置き換えれば今まで見てきた例に一致することがわかるでしょう。このような返り値の型を型クラスにするテクニックはTagless Finalとして知られていてEDSLを実現する手法として研究されています3。DataStoreSYM
は明らかに副作用を起こすことを期待しているのでMonad
の制約も付けて定義しています。DataStoreSYM
を使ってcreateOrUpdate
を定義すると以下のようになります。
createOrUpdate :: DataStoreSYM repr => Key -> Value -> repr ()
createOrUpdate k v = do
peek <- read k
case peek of
Just _ -> update k v
Nothing -> create k v
実装だけ見ればReaderT
を使ったものとまったく一致していますね。DataStoreSYM
のインスタンスも作ってみましょう。
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
DataStoreSYM
のIO
のインスタンスをモックとして実装しています。これは以下のように実行することができます。
> runMockDS $ createOrUpdate "key" "value"
Read: key
Create: key, value
runMockDS
は定義だけ見るとただのid
ですが型をつけることでDataStoreSYM
のどのインスタンスを使うか決定する役割を果たしています。
今度はIORef
を使ってKVSとして動作する実装を作ってみましょう。DataStoreSYM
のメソッドにはIORef
を渡せる引数が無いのでReaderモナドを使ってIORef
を引き回す処理を副作用に押しつけてしまいます。
type IORefDS = ReaderT (IORef [(Key, Value)]) IO
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
> ref <- newIORef ([] :: [(Key, Value)])
> runIORefDS ref $ createOrUpdate "key" "value"
> readIORef ref
[("key","value")]
少し実装が面倒くさい感じは否めないですがなんとかなりました
それでは念願のRedis実装を作ってみましょう。
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]
runRedis :: Redis.Connection -> Redis a -> IO a
runRedis conn redis = Redis.runRedis conn redis
簡単に実装することができました
さて、実際にDIを使用したコードを書いていると複数の依存性を注入したくなることがよくあります。例えば外部サービスのAPIからビットコインの時価を取得してデータベースに保存するプログラムを考えてみましょう。データベースに保存するプログラムはDataStoreSYM
を使って表現できますがビットコインの値段を取得するプログラムは新しく作らなければなりません。まずこれをTagless Finalで書くと
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)
のように書けます。とても簡単に2つのDSLを合成することができました
BitcoinSYM
の実装を作っていきましょう。まずIO
でモック実装を作ります。
instance BitcoinSYM IO where
getPrice = putStrLn "Get BTC price" >> pure 1000000.0
runMockBTC :: IO a -> IO a
runMockBTC = id
saveBTCPrice
をrunMockDS
で実行するかrunMockBTC
で実行するか迷いますが、どちらも同じものなのでとりあえずrunMockBTC
で実行してみましょう。
> runMockBTC saveBTCPrice
Get BTC price
Read: BTC Price
Create: BTC Price, 1000000.0
うまく動いてそうですね
今度は実際に外部に通信して値段を取得する実装を見てみましょう。
type BitFlyer = ReaderT Manager IO
-- | bitFlyerのAPIからビットコインの時価を取得するプログラム
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
APIは株式会社bitFlyerが提供しているものを利用しています4。この実装とsaveBTCPrice
を使っていよいよ外部からビットコインの時価を取得してIORef
に記録してみましょう。
ところがこれがうまくいかないことはすぐにわかると思います。runIORefDS
もrunBitFlyer
もsaveBTCPrice
を実行するのには使えません。原因はIORefDS
もBitFlyer
もどちらも相手のDSLを実行するために必要な情報を持っていないからです。例えばrunIORefDS
でsaveBTCPrice
を実行しようとすれば、まずIORefDS
がBitcoinSYM
のインスタンスではないので怒られるでしょう。それならIORefDS
をBitcoinSYM
のインスタンスにしようと思うかもしれませんがIORefDS
にはManager
の情報がないためrunBitFlyer
と同等の実装を作ることができません。
ならば新しく
type IORefDSAndBitFlyer = ReaderT (IORef [(Key, Value)]) (ReaderT Manager IO)
という型を作って
instance DataStoreSYM IORefDSAndBitFlyer where
create k v = ask >>= (\ref -> liftIO $ modifyIORef ref ((k, v):))
...
instance BitcoinSYM IORefDSAndBitFlyer where
getPrice = lift ask >>= (\manager -> liftIO $ getBitFlyerBitcoinPrice manager)
runIORefDSAndBitFlyer :: Manager -> IORef [(Key, Value)] -> IORefDSAndBitFlyer a -> IO a
runIORefDSAndBitFlyer manager ref dsl = runReaderT (runReaderT dsl ref) manager
のように実装も新しく作るのはどうでしょう。しかしこの作業はDSLを組み合わせるたびに発生してしまうため現実的ではありません
もしかしたらmtl
の型クラスMonadReader
を使って以下のように定義するとうまくいくかもしれません
instance MonadReader (IORef [(Key, Value)]) m => DataStoreSYM m where
create k v = ask >>= (\ref -> liftIO $ modifyIORef ref ((k, v):))
...
instance MonadReader Manager m => BitcoinSYM m where
getPrice = ask >>= (\manager -> liftIO $ getBitFlyerBitcoinPrice manager)
しかしMonadReader
は定義に
class Monad m => MonadReader r m | m -> r where
...
のような関数従属性があるためこれらの実装を組み合わせて使うことができません5
せっかくDSLを綺麗に合成することができても実装側の副作用をうまく合成することができなければ使い勝手はあまりよくありません。Tagless Finalを使いこなすにはまだ準備が少し足りなかったようです。
Freeモナド
そこで一旦Tagless Finalから離れて副作用の合成に注目してみましょう。今度はDSLとしてFreeモナドを使います。
Freeモナドに関する詳しい解説はこの記事では行いませんが、以下の記事がわかりやすいので気になる方は参照してみてください。
以下のコードの実装にはfreeというライブラリを利用します。
さっそくFreeモナドを使ってDataStore
を実装してみましょう。
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
DSLを合成することがもう分かっているのではじめからFreeモナド変換子を使っています6。これを使ってcreateOrUpdate
を実装すると
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
のようになります。
IORef
による実装を見てみましょう
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))
後続の処理を意識しながら逐一翻訳するように実装を書けばインタプリタが出来上がっているのがわかると思います。これは次のように実行することができます。
> ref <- newIORef ([] :: [(Key, Value)])
> runIORefDS ref (createOrUpdate "key" "value")
> readIORef ref
[("key","value")]
実行に必要なIORef
をインタプリタに直接渡すことができるのでReaderモナドを使わずにDataStoreT
を実行する関数を簡単に書くことができました。
次にビットコインの値を取得するDSLを実装してみましょう。
data BitcoinF a = GetPrice (Price -> a) deriving Functor
type BitcoinT m = FreeT BitcoinF m
getPrice = liftF $ GetPrice id
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)
モナド変換子を使って2つのDSLを合成しているのが型からわかると思います。実行するときも新しい何かを定義する必要はありません。
> manager <- newManager tlsManagerSettings
> ref <- newIORef ([] :: [(Key, Value)])
> runBitFlyer manager . runIORefDS ref $ saveBTCPrice
> readIORef ref
[("BTC Price","1235755.0")]
かなり理想のDIに近づいてきた気がしますね
しかしモナドのスタック順に応じてlift
をつけたり付けなかったりするのはやっぱり手間ですよね。
Extensible Effects
Extensible EffectsはData types à la carteのようにCoproductとInjectを用いてモナドを合成する方法の延長線上にある手法で、モナド変換子のように順序を気にすることなくモナドを合成することができます7。
Extensible Effectsについても詳しい解説はこの記事では行いませんが、以下の記事がわかりやすいので気になる方は参照してみてください。
以下のコードの実装にはfreer-effectsというライブラリを利用します。
さっそくEffモナドを使ってDataStore
を実装してみましょう。
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
の実装は以下のようになります。
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
IORef
を使った実装を作ってみましょう。
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)
Freeモナドでの実装と比べると後続の処理すら意識せずに単純な変換を書くだけで済むので簡単です。
> ref <- newIORef ([] :: [(Key, Value)])
> runM . runIORefDS ref $ createOrUpdate "key" "value"
> readIORef ref
[("key","value")]
うまく動いていますね。
次にBitcoin
も実装してみましょう。
data Bitcoin a where
GetPrice :: Bitcoin Price
getPrice :: Member Bitcoin effs => Eff effs Price
getPrice = send GetPrice
runBitFlyer :: Member IO effs => Manager -> Eff (Bitcoin ': effs) a -> Eff effs a
runBitFlyer manager = runNat @IO interpret
where
interpret :: forall a. Bitcoin a -> IO a
interpret GetPrice = getBitFlyerBitcoinPrice manager
これらを組み合わせてsaveBTCPrice
を作ってみましょう。
saveBTCPrice :: (Member BitFlyer effs, Member DataStore effs) => Eff effs ()
saveBTCPrice = do
price <- getPrice
createOrUpdate "BTC Price" (BS.pack $ show price)
Tagless Finalの時と同じようにDSLが型の制約として現れていますね。lift
みたいに順番を意識させる関数なども特に使うことなくそのまま合成できています
> ref <- newIORef ([] :: [(Key, Value)])
> manager <- newManager tlsManagerSettings
> runM . runBitFlyer manager . runIORefDS ref $ saveBTCPrice
> readIORef ref
[("BTC Price","1234662.0")]
動作も期待通りですね
これまでの議論からExtensible Effectsを使えば
- 実装によって返り値の型を変えられる
- 余計なコストを払うことなく2つのDSLが合成できる
というDIに求められる機能が実現できることが分かりました。どうやら実用的なアプリケーションを書いていてDIが必要になった時はExtensible Effectsを使うのが一番良さそうです。
Tagless Final再訪
ところでExtensible Effectsの導入によってモナドの合成がlift
と関数従属性から解き放たれたことによりTagless Finalがまた使えるようになりました。Tagless Finalをフロントエンドとして使い、Extensible Effectsをバックエンドとして使うことで、高いDSLの表現力と柔軟な副作用の合成を同時に実現することができます8。
まずDSLの定義は普通のTagless Finalの時と同じです。
class Monad repr => DataStoreSYM repr where
create :: Key -> Value -> repr ()
read :: Key -> repr (Maybe Value)
update :: Key -> Value -> repr ()
delete :: Key -> repr ()
class Monad repr => BitcoinSYM repr where
getPrice :: repr Price
普通のTagless Finalと同様にこれらを組み合わせることができます。
saveBTCPrice :: (BitcoinSYM repr, DataStoreSYM repr) => repr ()
saveBTCPrice = do
price <- getPrice
createOrUpdate "BTC Price" (BS.pack $ show price)
次に実装を見てみましょう。
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))
data BitFlyer = BitFlyer { getBitFlyer :: Manager }
instance (Member (Reader BitFlyer) effs, Member IO effs) => BitcoinSYM (Eff effs) where
getPrice = asks getBitFlyer >>= (\manager -> send $ getBitFlyerBitcoinPrice manager)
Freerモナドを使うとハンドラを自由に作れて便利なのですが今回はDSLを2回書いてしまうのが手間なので既に用意されているReaderモナドを使って実装しました。では実行してみましょう。
> ref <- newIORef ([] :: [(Key, Value)])
> manager <- newManager tlsManagerSettings
> ds = IORefDS ref
> bitflyer = BitFlyer manager
> runM $ runReader (runReader saveBTCPrice ds) bitflyer
> readIORef ref
[("BTC Price","1286700.0")]
期待通りの動作をしていますね
Tagless Finalで実装することのメリットはHigher-order abstract syntax(HOAS)が利用できることだと思います9。例えばTagless Finalを使った線形ラムダ計算の実装10と組み合わせて、リソース管理の方法も提供するプログラムのDIを実現したりできるかもしれません。