Haskell
DI
DependencyInjection
FOLIODay 14

Extensible EffectsとTagless Finalで実装するDI

これは FOLIO Advent Calendar 2017 14日目の投稿です。

HaskellでDIを実装する一番いい方法は何か、様々な手法を比較しながらベストな方法を探していこうと思います。

記事中のコードは記述を簡潔にするため実行に必要なGHC拡張やimportを書いていません。完全なコードは以下のgistに載せているので参照して下さい。
https://gist.github.com/lotz84/7207fa3a6b806807defd04e773f8dc78

:new_moon: 易しい依存性の注入

DI(Dependency Injection, 依存性の注入)とは何でしょうか。Wikipediaから説明を引用すると、

依存性の注入とは、コンポーネント間の依存関係をプログラムのソースコードから排除し、外部の設定ファイルなどで注入できるようにするソフトウェアパターンである。英語の頭文字からDIと略される。

出典: 依存性の注入 - Wikipedia

とあります。依存関係を排除するためによく使われる手法は プログラムのインターフェースと実装を何らかの言語機能を使って分離して 依存関係のあるプログラムをそのインターフェースだけを利用して書く方法でしょう。例えば簡単な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]

IORefImplIORefで参照しているリストのデータを操作することで実際に簡単な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")]

期待通りに動いていますね。

:waxing_crescent_moon: 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だけを綺麗に消すことができました :tada:

このReaderIOを組み合わせる方法はとても便利で、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を利用することを想定しています。ですがこの実装ではコンパイルが通りません。なぜならRedisImplDataStoreのインスタンスは

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は注入する実装によって返り値の型が変えられることが望ましいでしょう。

:first_quarter_moon: Tagless Final

ならば型クラスの対象にする型を 引数の型 ではなく 返り値の型 にすればどうでしょうか。

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

この方法は驚くほどうまくいきます。実際reprReaderT ds IORedisに置き換えれば今まで見てきた例に一致することがわかるでしょう。このような返り値の型を型クラスにするテクニックはTagless Finalとして知られていてEDSLを実現する手法として研究されています3DataStoreSYMは明らかに副作用を起こすことを期待しているので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

DataStoreSYMIOのインスタンスをモックとして実装しています。これは以下のように実行することができます。

> 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")]

少し実装が面倒くさい感じは否めないですがなんとかなりました :relieved:

それでは念願の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

簡単に実装することができました :tada:

さて、実際に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を合成することができました :relaxed:

BitcoinSYMの実装を作っていきましょう。まずIOでモック実装を作ります。

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

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

saveBTCPricerunMockDSで実行するかrunMockBTCで実行するか迷いますが、どちらも同じものなのでとりあえずrunMockBTCで実行してみましょう。

> runMockBTC saveBTCPrice
Get BTC price
Read: BTC Price
Create: BTC Price, 1000000.0

うまく動いてそうですね :thinking:

今度は実際に外部に通信して値段を取得する実装を見てみましょう。

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に記録してみましょう。

ところがこれがうまくいかないことはすぐにわかると思います。runIORefDSrunBitFlyersaveBTCPriceを実行するのには使えません。原因はIORefDSBitFlyerもどちらも相手のDSLを実行するために必要な情報を持っていないからです。例えばrunIORefDSsaveBTCPriceを実行しようとすれば、まずIORefDSBitcoinSYMのインスタンスではないので怒られるでしょう。それならIORefDSBitcoinSYMのインスタンスにしようと思うかもしれませんが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を組み合わせるたびに発生してしまうため現実的ではありません :fearful:

もしかしたらmtlの型クラスMonadReaderを使って以下のように定義するとうまくいくかもしれません :bulb:

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 :disappointed:

せっかくDSLを綺麗に合成することができても実装側の副作用をうまく合成することができなければ使い勝手はあまりよくありません。Tagless Finalを使いこなすにはまだ準備が少し足りなかったようです。

:waxing_gibbous_moon: 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に近づいてきた気がしますね :muscle:

しかしモナドのスタック順に応じてliftをつけたり付けなかったりするのはやっぱり手間ですよね。

:full_moon: 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みたいに順番を意識させる関数なども特に使うことなくそのまま合成できています :clap:

> ref     <- newIORef ([] :: [(Key, Value)])
> manager <- newManager tlsManagerSettings
> runM . runBitFlyer manager . runIORefDS ref $ saveBTCPrice
> readIORef ref
[("BTC Price","1234662.0")]

動作も期待通りですね :muscle:

これまでの議論からExtensible Effectsを使えば

  • 実装によって返り値の型を変えられる
  • 余計なコストを払うことなく2つのDSLが合成できる

というDIに求められる機能が実現できることが分かりました。どうやら実用的なアプリケーションを書いていてDIが必要になった時はExtensible Effectsを使うのが一番良さそうです。

:waning_gibbous_moon: 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")]

期待通りの動作をしていますね :clap:

Tagless Finalで実装することのメリットはHigher-order abstract syntax(HOAS)が利用できることだと思います9。例えばTagless Finalを使った線形ラムダ計算の実装10と組み合わせて、リソース管理の方法も提供するプログラムのDIを実現したりできるかもしれません。

:books: 参考文献