Freer Effectsが、だいたいわかった: 9. モナドを混ぜ合わせる(閉じた型で)

目次

(0). 導入

Freeモナドの概要
- Freeモナドとは
- FreeモナドでReaderモナド、Writerモナドを構成する
存在型(ExistentialQuantification拡張)の解説
型シノニム族(TypeFamilies拡張)の解説
データ族(TypeFamilies拡張)の解説
一般化代数データ型(GADTs拡張)の解説
ランクN多相(RankNTypes拡張)の解説
FreeモナドとCoyoneda
- Coyonedaを使ってみる
- FreeモナドとCoyonedaを組み合わせる
  - いろいろなモナドを構成する
Freerモナド(Operationalモナド)でいろいろなモナドを構成する
- FreeモナドとCoyonedaをまとめて、Freerモナドとする
- Readerモナド
- Writerモナド
- 状態モナド
- エラーモナド
モナドを混ぜ合わせる(閉じた型で)
- Freerモナドで、状態モナドとエラーモナドを混ぜ合わせる
  - 両方のモナドを一度に処理する
  - それぞれのモナドを、それぞれに処理する
存在型による拡張可能なデータ構造(Open Union)
追加の言語拡張
モナドを混ぜ合わせる(開いた型で)
- FreeモナドとOpen Unionを組み合わせる
- 状態モナドにエラーモナドを追加する
Open Unionを型によって安全にする
Freer Effectsで、IOモナドなどの、既存のモナドを使用する
関数を保管しておくデータ構造による効率化
いろいろなEffect
- 関数handleRelayなどを作成する
- NonDetについて、など

状態モナドとエラーモナドとを混ぜ合わせる

Freerモナドを使って、状態モナドとエラーモナドとを混ぜ合わせてみる。
ファイルstateError.hsを作成する。

stateError.hs

{-# LANGUAGE LambdaCase, TupleSections #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

import Freer

data SE s e a where
        Get :: SE s e s
        Put :: s -> SE s e ()
        Exc :: e -> SE s e a

状態モナドでのデータ型の値構築子と、エラーモナドでのデータ型の値構築子との両方をもつデータ型を定義した。それぞれに対して、モナドを構成する基本的な要素を定義する。

stateError.hs

get :: Freer (SE s e) s
get = freer Get

put :: s -> Freer (SE s e) ()
put = freer . Put

modify :: (s -> s) -> Freer (SE s e) ()
modify f = put . f =<< get

throwError :: e -> Freer (SE s e) a
throwError = freer . Exc

状態モナドとエラーモナドを、一度に処理する

状態+エラーモナドを処理する関数を書く。状態モナドとエラーモナドを混ぜ合わせるとき、エラーのときに状態を捨てるかどうかで、2通りの関数が考えられる。

エラーのとき状態を捨てる

エラーのとき状態を捨てる処理をする、関数を書く。

stateError.hs

runSE :: Freer (SE s e) a -> s -> Either e (a, s)
runSE m s = case m of
        Pure x -> Right (x, s)
        Get `Bind` k -> runSE (k s) s
        Put s' `Bind` k -> runSE (k ()) s'
        Exc e `Bind` _k -> Left e

まえにみた関数runState、runErrorとを混ぜ合わせたような関数となっている。

サンプル

とくに意味はないが、計算の例を示す。まずは安全な除算を定義する。

stateError.hs

safeDiv :: Integer -> Integer -> Freer (SE s String) Integer
n `safeDiv` 0 = throwError $ show n ++ " is divided by 0"
n `safeDiv` m = return $ n `div` m

これを使って計算の流れを定義する。

stateError.hs

sample1 :: Freer (SE Integer String) Integer
sample1 = do
        a <- get
        modify (subtract 5)
        modify (* 2)
        b <- get
        c <- 60 `safeDiv` b
        put a
        modify (subtract 3)
        d <- get
        e <- 250 `safeDiv` d
        return $ c + e

とくに意味はないが、つぎのような計算をしている。状態として受け渡されていく値を「メモリの値」と呼ぶことにする。

はじめのメモリの値を変数aに読み込む
メモリの値から5をひく
メモリの値に2をかける
メモリの値を変数bに読み込む
60を値bでわり(値bが0ならばエラーとなる)、結果を変数cに代入する
値aをメモリの値に代入する
メモリの値から3をひく
メモリの値を変数dに読み込む
250を値dでわり(値dが0ならばエラーとなる)、結果を変数eに代入する
値cと値eの和をかえす

対話環境で試してみよう。

> :load stateError.hs
> sample1 `runSE` 8
Right (60,5)
> sample1 `runSE` 5
Left "60 is divided by 0"
> sample1 `runSE` 3
Left "250 is divided by 0"

エラーでも状態を保持する

状態モナドとエラーモナドを混ぜ合わせたものを処理する、もうひとつのやりかたがある。こちらのやりかただと、エラーであっても状態が保持できる。ファイルstateError.hsに関数runSE'を定義する。

stateError.hs

runSE' :: Freer (SE s e) a -> s -> (Either e a, s)
runSE' m s = case m of
        Pure x -> (Right x, s)
        Get s' `Bind` k -> runSE' (k ()) s'
        Exc e `Bind` _k -> (Left e, s)

試してみよう。

> :load stateError.hs
> sample1 `runSE'` 8
(Right 60,5)
> sample1 `runSE'` 5
(Left "60 is divided by 0",0)
> sample1 `runSE'` 3
(Left "250 is divided by 0",0)

エラーからの復帰

エラーから復帰するための仕組みも作る。

stateError.hs

catchError :: Freer (SE s e) a -> (e -> Freer (SE s e) a) -> Freer (SE s e) a
m `catchError` h = case m of
        Pure x -> return x
        Exc e `Bind` _k -> h e
        mx `Bind` k -> mx `Bind` ((`catchError` h) . k)

単純な値である(Pure x)では、その値をそのままかえす。エラーが発生した(Exc e)ときには、エラーハンドラーhにエラーをわたす。それ以外のとき(Get, Put)には、それぞれの処理をおこなったあとに、再帰的にエラーからの復帰をするために、(`catchError` h)とkを関数合成しておく。

エラーからの復帰を含むサンプル

エラーからの復帰を含むサンプルを定義する。

stateError.hs

divMemory :: Integer -> Freer (SE Integer String) ()
divMemory n = do
        a <- get
        b <- a `safeDiv` n
        put b

sample2 :: Integer -> Freer (SE Integer String) Integer
sample2 n = do
        divMemory n
        a <- get
        return $ a * 10

メモリーの値を引数nでわり、その結果を取り出して、10倍してかえす。nが0ならばエラーになる。エラーからの復帰を試してみよう。

> :reload
> sample2 2 `runSE` 8
Right (40,4)
> sample2 0 `runSE` 8
Left "8 is divided by 0"
> sample2 0 `catchError` const (return 100) `runSE` 8
Right (100,8)

状態モナドとエラーモナドとを、それぞれに処理する

状態モナドとエラーモナドとの、それぞれの処理をわけることを考える。うえで定義した関数catchErrorをみてほしい。この処理は、見かたをかえれば、エラーモナドだけを処理していると考えることができる。これとおなじように考えれば、状態モナドだけ、エラーモナドだけを処理する関数を書くことができる。まずは、状態モナドの部分だけを処理する関数を書く。ファイルstateError.hsに関数runStateを定義する。

stateError.hs

runState :: Freer (SE s e) a -> a -> Freer (SE s e) (a, s)
runState m s = case m of
        Pure x -> return (x, s)
        Get `Bind` k -> runState (k s) s
        Put s' `Bind` k -> runState (k ()) s'
        mx `Bind` k -> mx `Bind` ((`runState` s) . k)

状態モナドの機能(Get, Put)に対しては、その機能を展開する。それ以外の機能(Exc)に対しては、関数catchErrorのときとおなじように、その機能を展開したあとに状態モナドの機能が展開されるように、(`runState` s)を再帰的に適用する。つぎに、関数runErrorを定義する。

stateError.hs

runError :: Freer (SE s e) a -> Freer (SE s e) (Either e a)
runError = \case
        Pure x -> return $ Right x
        Exc e `Bind` _k -> return $ Left e
    mx `Bind` k -> mx `Bind` (runError . k)

おなじく、エラーモナドの機能(Exc)に対しては、その機能を展開する。それ以外の機能(Get, Put)に対しては、その機能を展開したあとにエラーモナドの機能が展開されるように、runErrorを再帰的に適用する。関数runStateとrunErrorとを適用したあと、型としてはFreer ...となるが、Get、Put、Excはすべて処理されてなくなるのでPureだけが残る。
そのPureから値を取り出す関数を作っておこう。

stateError.hs

runPure :: Freer (SE s e) a -> a
runPure = \case
        Pure x -> x
        _ -> error "remain State or Error"

対話環境で試してみよう。

> :reload
> runPure . runError $ sample1 `runState` 8
Right (60,5)
> runPure . runError $ sample1 `runState` 3
Left "250 is divided by 0"
> runPure $ runError sample1 `runState` 8
(Right 60,5)
> runPure $ runError sample1 `runState` 3
(Left "250 is divided by 0",0)

Writerモナドを追加する

状態モナドとエラーモナド

状態モナドとエラーモナドの混ぜ合わせのコードを、もういちど、みてみよう。復習という意味もあるが、それだけでなく、Writerモナドを追加するための下準備として、うえで紹介した内容をくりかえす。つぎの内容のファイルstateErrorWriter.hsを作成する。

stateErrorWriter.hs

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_GHC -Wall -fno-warn-tabs #-}

import Freer

data SE s e a where
        Get :: SE s e s
        Put :: s -> SE s e ()
        Exc :: e -> SE s e a

get :: Freer (SE s e) s
get = freer Get

put :: s -> Freer (SE s e) ()
put = freer . Put

modify :: (s -> s) -> Freer (SE s e) ()
modify f = put . f =<< get

throwError :: e -> Freer (SE s e) a
throwError = freer . Exc

catchError :: Freer (SE s e) a -> (e -> Freer (SE s e) a) -> Freer (SE s e) a
m `catchError` h = case m of
        Pure x -> return x
        Exc e `Bind` _k -> h e

runState :: Freer (SE s e) a -> s -> Freer (SE s e) (a, s)
runState m s = case m of
        Pure x -> Pure (x, s)
        Get `Bind` k -> runState (k s) s
        Put s' `Bind` k -> runState (k ()) s'
        mx `Bind` k -> mx `Bind` ((`runState` s) . k)

runError :: Freer (SE s e) a -> Freer (SE s e) (Either e a)
runError = \case
        Pure x -> Pure $ Right x
        Exc e `Bind` _k -> return $ Left e
        mx `Bind` k -> mx `Bind` (runError . k)

runPure :: Freer (SE s e) a -> a
runPure = `case
        Pure x -> x
        _ -> error "remain State or Error"

サンプルも定義しておく。

stateErrorWriter.hs

safeDiv :: Integer -> Integer -> Freer (SE s String) Integer
safeDiv n 0 = throwError $ show n ++ " is divided by 0"
safeDiv n m = return $ n `div` m

sample :: Freer (SE Integer String) Integer
sample = do
        a <- get
        modify (subtract 5)
        b <- get
        c <- 60 `safeDiv` b
        put a
        modify (subtract 3)
        d <- get
        e <- 250 `safeDiv` d
        return $ c + e

対話環境で試しておく。

> :load stateErrorWriter.hs
> runPure . runError $ sample `runState` 8
Right (70,5)
> runPure . runError $ sample `runState` 3
Left "250 is divided by 0"

Writerモナドを追加する

さて、状態モナドとエラーモナドにWriterモナドをつけ加える。まずは、データ型に値構築子Writerを追加で定義する。

stateErrorWriter.hs

data SE s e w a where
        Get :: SE s e w s
        Put :: s -> SE s e w ()
        Exc :: e -> SE s e w a
        Writer :: w -> SE s e w ()

対話環境に再読み込みしてみる。

> :reload
(型エラーが発生する)

型エラーがなくなるまで型構築子SEの引数にwを追加していく。以下の10ヶ所を変更することになる。

stateErrorWriter.hs

.
.
.
get :: Freer (SE s e w) s
.
.
.
put :: s -> Freer (SE s e w) ()
.
.
.
modify :: (s -> s) -> Freer (SE s e w) ()
.
.
.
throwError :: e -> Freer (SE s e w) a
.
.
.
catchError :: Freer (SE s e w) a -> (e -> Freer (SE s e w) a -> Freer (SE s e w) a
.
.
.
runState :: Free (SE s e w) a -> s -> Freer (SE s e w) (a, s)
.
.
.
runError :: Free (SE s e w) a -> Freer (SE s e w) (Either e a)
.
.
.
runPure :: Freer (SE s e w) a -> a
.
.
.
safeDif :: Integer -> Integer -> Freer (SE s String String) Integer
.
.
.
sample :: Freer (SE Integer String String) Integer
.
.
.

Writerモナドの機能として関数tellを定義する。

stateErrorWriter.hs

tell :: w -> Freer (SE s e w) ()
tell = freer . Writer

関数runWriterを定義する。まずは、導入するモジュールを指定する。ファイルstateErrorWriter.hsの言語拡張のつぎの行に、つぎのように追加する。

stateErrorWriter.hs

import Control.Arrow
import Data.Monoid

関数runWriterを定義する。

stateErrorWriter.hs

runWriter :: Monoid w => Freer (SE s e w) a -> Freer (SE s e w) (a, w)
runWriter = \case
        Pure x -> return (x, mempty)
        Writer w `Bind` k -> second (w <>) <$> runWriter (k ())
        mx `Bind` k -> mx `Bind` (runWriter . k)

関数safeDivが、わり算のログを保存するようにする。

stateErrorWriter.hs

safeDiv :: Integer -> Integer -> Freer (SE s String String) Integer
safeDiv n 0 = throwError $ show n ++ " is divided by 0"
safeDiv n m = do
        tell $ show n ++ " `div` " ++ show m ++ "\n"
        return $ n `div` m

対話環境で試してみる。

> :reload
> runPure . runError . runWriter $ sample `runState` 8
Right ((70,5),"60 `div` 3\n250 `div` 5\n")

Writerモナドを追加するのに必要だったこと

Writerモナドを追加するのに必要だったことは、

値構築子Writerの追加
型宣言の修正
関数tellの定義
関数runWriterの定義

だった。

拡張性がない

データ型に新しい値構築子を追加して、それに対するrun...を定義すれば、新しい機能が追加できる。run...は別モジュールで追加することもできるけれど、Haskellのデータ型は閉じているので、別モジュールで値構築子を追加することはできない。はじめに定義したデータ型に含まれた機能以上のことはできない。それなら、値構築子を追加できるデータ型を作ればいいのでは。

まとめ

まずは、状態モナドとエラーモナドを混ぜ合わせたモナドを作り、さらにそれにWriterモナドも追加した。いまの実装では、モナドの機能の追加のためには、データ型に値構築子を追加する必要があり、たとえば、別モジュールで機能を追加することはできない。