Haskellの勉強 - 型安全なイベント

Type-safe events

このエントリを読んでわかったことのメモ。
以下のような感じで、異なる型のイベントを同じように扱いたい。

data Ping = Ping Int | Pong Int
data Log = Warn String | Info String

main = do
         fire $ Warn "Starting the engines!"
         fire $ Ping 100
         fire $ Info "Engines has been started."
         fire $ Ping 200

Type OperatorsとData.Generics
代数データ型はオープンではないので、Ping型とLog型を合わせた代数データ型を作るのはたいへん。
Haskell PlatformにあるData.Genericsには複数の型を足しあわせた型リスト(variant)を作る:+:型演算子がある。
型演算子は、TypeOperatorsというGHC拡張で実現できる。

{-# TypeOperators #-}

data a :+: b = Inl a | Inr b
             deriving (Show)
infixr 5 :+:

type Features = Log :+: Ping

:+:によって構築された型は、Extensible Sum Typeというらしい。このvariant型にどの型の値が入っているのかを判定して安全に値を取り出すには、型クラスの制約を使用する。

class Contains a s where
    wrap   :: a -> s
    unwrap :: s -> Maybe a

instance Contains a (a :+: b) where
    wrap           = Inl
    unwrap (Inl x) = Just x
    unwrap _       = Nothing

instance Contains b (a :+: b) where
    wrap           = Inr
    unwrap (Inr x) = Just x
    unwrap _       = Nothing

instance Contains a s => Contains a (b :+: s) where
    wrap           = Inr . wrap
    unwrap (Inr x) = unwrap x
    unwrap _       = Nothing

client :: (Monad m, Contains e s) => (e -> m ()) -> s -> m ()
client f = maybe (return ()) f . unwrap

汎用化されたvisitorみたいなものだと理解しました。

あとは、イベントの値とハンドラをつなげる部分を書いて、ハンドラ側ではvariantから元の型の値を取り出して使用します。

先ほどのブログのコードを、Data.Genericsにすでに用意されている型演算子を使用するように直してみた完全なコードが以下になります。

{-# LANGUAGE FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving,
    MultiParamTypeClasses, OverlappingInstances, TypeOperators #-}

import Data.Generics
import Control.Applicative (Applicative)
import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans (MonadIO, liftIO)

class Contains a s where
    wrap   :: a -> s
    unwrap :: s -> Maybe a

instance Contains a (a :+: b) where
    wrap           = Inl
    unwrap (Inl x) = Just x
    unwrap _       = Nothing

instance Contains b (a :+: b) where
    wrap           = Inr
    unwrap (Inr x) = Just x
    unwrap _       = Nothing

instance Contains a s => Contains a (b :+: s) where
    wrap           = Inr . wrap
    unwrap (Inr x) = unwrap x
    unwrap _       = Nothing

class (Functor m, Monad m) => MonadResponds e m where
    fire :: e -> m ()

newtype RespondsT e m a = RespondsT
    { unRespondsT :: ReaderT (e -> RespondsT e m ()) m a
    } deriving (Applicative, Functor, Monad, MonadIO)

runRespondsT :: RespondsT e m a -> (e -> RespondsT e m ()) -> m a
runRespondsT (RespondsT r) e = runReaderT r e

instance (Contains e s, Functor m, Monad m) =>
        MonadResponds e (RespondsT s m) where
    fire x = RespondsT $ ask >>= unRespondsT . ($ wrap x)

client :: (Monad m, Contains e s) => (e -> m ()) -> s -> m ()
client f = maybe (return ()) f . unwrap

data Ping = Ping Int | Pong Int
data Log = Warn String | Info String

logger :: (MonadIO m, Contains Log s) => s -> m ()
logger = client $ \event -> liftIO $ putStrLn $ case event of
    Warn s -> "[Warn]: " ++ s
    Info s -> "[Info]: " ++ s

ping :: (Contains Log s, Contains Ping s,
          MonadResponds Log m, MonadResponds Ping m)
     => s -> m ()
ping = client $ \event -> case event of
    Ping x -> fire (Pong x)
    Pong x -> fire (Info $ "Received pong with token " ++ show x)

combine :: Monad m => [e -> m ()] -> e -> m ()
combine handlers event = mapM_ ($ event) handlers

type Features = Log :+: Ping

testClient :: Features -> RespondsT Features IO ()
testClient = combine [logger, ping]

test :: RespondsT Features IO ()
test = do
    fire $ Warn "Starting the engines!"
    fire $ Ping 100
    fire $ Info "Engines has been started."
    fire $ Ping 200

main :: IO ()
main = runRespondsT test testClient

[Warn]: Starting the engines!
[Info]: Received pong with token 100
[Info]: Engines has been started.
[Info]: Received pong with token 200

半分くらいしか理解できてない気もしますが、使う分にはこれくらいわかっていればよさそうです。

Scalaで書かれた例(okomokさん)：
TypeSafeEvents.scala - ken

型演算子の入門記事：
A Kind Introduction

:+:が定義されているところ(Hoogleで演算子が検索できない)：
Data.Generics