拡張可能作用 ― モナド変換子に取って代わるもの付録

付録A. Eff.hs

拡張可能作用に対する API を定義・実装している。例外、状態、非決定論などの標準的なモナディックな作用も実装している。多くの例とテストコードを含んでいる。
付録B. OpenUnion1.hs

論文で使われているオープンな和のコード。HList の論文の実装に近い。このコードは、Typeable に頼っていて、モジュール内に限定されている重複インスタンス拡張 (overlapping instances extension) を使って閉じた型族をエミュレートしている。
付録C. OpenUnion2.hs

重複インスタンスのないバージョンの、閉じた型族を直接使うオープンな和。
付録D. OpenUnion3.hs

存在型ではなく全称量化型に頼っている、もう一つの、OpenUnion2.hs といくぶんか双対な実装。
付録E. ExtMTL.hs

MTL のモナド変換子クラスをエミュレートするEff.fs の変種。拡張可能作用フレームワークは実は MonadError, MonadReader, MonadState などのインスタンスを定義できる。これらのインスタンスを使うならば、ユーザーのコードにおける型注釈が少なくて済む。一方で、より一般性が小さく、特定の種の単一の作用の層を強制する。
付録F. Crossover.hs

交差のライブラリの、交差の例がたくさん付いているソースコード。
付録G. Benchmarks.hs

いくつかのマイクロベンチマーク。
付録H. transf.hs

モナド変換子の表現性の限界についての2つの例。論文の §5 の完全なコード。
論文に戻る

付録A. Eff.hs

拡張可能作用に対する API を定義・実装している。例外、状態、非決定論などの標準的なモナディックな作用も実装している。多くの例とテストコードを含んでいる。

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

-- 拡張可能作用のフレームワーク

module Eff where

import Control.Monad
import Data.Typeable
import OpenUnion2
-- import OpenUnion3

import Data.IORef                       -- 持ち上げの実演のため

-- ハンドラとクライアント（権威のある計算）の間の通信のための
-- モナディックなライブラリ

-- コルーチン（クライアント）のステータス：
-- 型 w の値で終了しているか、型 Union r のリクエストを送っている
data VE w r = Val w | E !(Union r (VE w r))

-- Eff モナド（変換子でない）
-- これは実は
--     type Eff r = forall w. Cont (VE w r)
-- である。
-- 私たちは forall を newtype の下にやるために、
-- Cont へとインライン化している。
-- Haskell ではこうしないと変なのである。
-- また MTL では Cont は変換子を通して定義されている。
-- 私たちは変換子を避けたいのだ！
newtype Eff r a = Eff{runEff :: forall w. (a -> VE w r) -> VE w r}

-- 継続モナドのための標準的なインスタンス
instance Functor (Eff r) where
    fmap f m = Eff $ \k -> runEff m (k . f)

instance Monad (Eff r) where
    {-# INLINE return #-}
    {-# INLINE (>>=) #-}
    return x = Eff $ \k -> k x
    m >>= f  = Eff $ \k -> runEff m (\v -> runEff (f v) k)

-- リクエストを送って返事を待つ
send :: (forall w. (a -> VE w r) -> Union r (VE w r)) -> Eff r a
send f = Eff (E . f)

-- send を説明上便利なように特殊化したもの
send_req :: (Functor req, Typeable1 req, Member req r) =>
            (forall w. (a -> VE w r) -> req (VE w r)) -> Eff r a
send_req req = send (inj . req)

-- クライアントを管理する：
-- コルーチンを開始し、コルーチンがリクエストを送るか、値とともに終わるのを待つ。
admin :: Eff r w -> VE w r
admin (Eff m) = m Val

-- admin の反対で、時々便利である。
-- 例についてはソフトカットを参照せよ。
-- 今のところ割と非効率であり、よりよい書き方がある。
reflect :: VE a r -> Eff r a
reflect (Val x) = return x
reflect (E u) = Eff (\k -> E $ fmap (loop k) u)
 where
 loop :: (a -> VE w r) -> VE a r -> VE w r
 loop k (Val x) = k x
 loop k (E u)   = E $ fmap (loop k) u


-- ------------------------------------------------------------------------
-- 最初の事例、作用無し

data Void -- 構成子無し

-- run の型は、すべての作用がハンドルされているということを保証している：
-- 純粋な計算だけが run される（実行される）
run :: Eff Void w -> w
run m = case admin m of Val x -> x
-- Void は構成子を持たないので他の場合 (case) は到達不可能である。
-- ゆえに m Val が終了するならば run は全域関数である。

-- 便利なパターン：
-- リクエスト（オープンな和）が与えられれば、ハンドルするか、リレーする
handle_relay :: Typeable1 t =>
     Union (t :> r) v -> (v -> Eff r a) -> (t v -> Eff r a) -> Eff r a
handle_relay u loop h = case decomp u of
  Right x -> h x
  Left u  -> send (\k -> fmap k u) >>= loop
  -- おそらくもっと効率的なのは：
  -- Left u  -> send (\k -> fmap (\w -> runEff (loop w) k) u)

-- Control.Exception.catches みたいなものを追加しようか？
-- カットのある制御に有用かもしれない

interpose :: (Typeable1 t, Functor t, Member t r) =>
     Union r v -> (v -> Eff r a) -> (t v -> Eff r a) -> Eff r a
interpose u loop h = case prj u of
  Just x -> h x
  _       -> send (\k -> fmap k u) >>= loop

-- ------------------------------------------------------------------------
-- 読み取りモナド

-- 現在の環境から型 e の値を要求するリクエスト
newtype Reader e v = Reader (e -> v)
    deriving (Typeable, Functor)

{--
instance Functor ((->) e) where
    fmap = (.)
--}

-- 型注釈は推論される
ask :: (Typeable e, Member (Reader e) r) => Eff r e
ask = send (inj . Reader)

-- Reader リクエストのハンドラ
-- 返り値の型は、すべての Reader リクエストが
-- 完全にハンドルされているということを示している。
runReader :: Typeable e => Eff (Reader e :> r) w -> e -> Eff r w
runReader m e = loop (admin m) where
 loop (Val x) = return x
 loop (E u) = handle_relay u loop (\(Reader k) -> loop (k e))

-- 動的環境において値を局所的に再束縛する。
-- この関数は リレーに似ている：
-- Reader リクエストを管理し、かつリクエストを投げるのである。
local :: (Typeable e, Member (Reader e) r) =>
     (e -> e) -> Eff r a -> Eff r a
local f m = do
  e0 <- ask
  let e = f e0
  let loop (Val x) = return x
      loop (E u) = interpose u loop (\(Reader k) -> loop (k e))
  loop (admin m)

-- 例
add :: Monad m => m Int -> m Int -> m Int
add = liftM2 (+)

-- 型は推論される
t1 :: Member (Reader Int) r => Eff r Int
t1 = ask `add` return (1::Int)

t1' :: Member (Reader Int) r => Eff r Int
t1' = do v <- ask; return (v + 1 :: Int)

-- t1r :: Eff r Int
t1r = runReader t1 (10::Int)

t1rr = run t1r
-- 11

{-
t1rr' = run t1
    No instance for (Member (Reader Int) Void)
      arising from a use of `t1'
-}

-- Inferred type
-- t2 :: (Member (Reader Int) r, Member (Reader Float) r) => Eff r Float
t2 = do
  v1 <- ask
  v2 <- ask
  return $ fromIntegral (v1 + (1::Int)) + (v2 + (2::Float))

-- t2r :: Member (Reader Float) r => Eff r Float
t2r = runReader t2 (10::Int)
-- t2rr :: Eff r Float
t2rr = flip runReader (20::Float) . flip runReader (10::Int) $ t2

t2rrr = run t2rr
-- 33.0

-- 層を逆の順番にする
{- しくじるとエラーを得る
t2rrr' = run $ runReader (runReader (t2 ()) (20::Float)) (10::Float)
    No instance for (Member (Reader Int) Void)
      arising from a use of `t2'
-}
t2rrr' = run $ runReader (runReader t2 (20::Float)) (10::Int)
-- 33.0

-- 型は推論される
t3 :: Member (Reader Int) r => Eff r Int
t3 = t1 `add` local (+ (10::Int)) t1
t3r = run $ runReader t3 (100::Int)
-- 212

-- 以下の例は、Reader Int と Reader Float の層の真の交替を実演している
{-
t4
  :: (Member (Reader Int) r, Member (Reader Float) r) =>
     () -> Eff r Float
-}
t4 = liftM2 (+) (local (+ (10::Int)) t2)
                (local (+ (30::Float)) t2)

t4rr = run $ runReader (runReader t4 (10::Int)) (20::Float)
-- 106.0
-- 層の順番を逆にしても同じ結果が得られる
t4rr' = run $ runReader (runReader t4 (20::Float)) (10::Int)
-- 106.0

-- 作用のある関数に対するマッピング
-- 型は推論される
tmap :: Member (Reader Int) r => Eff r [Int]
tmap = mapM f [1..5]
 where f x = ask `add` return x

tmapr = run $ runReader tmap (10::Int)
-- [11,12,13,14,15]


-- ------------------------------------------------------------------------
-- 例外

-- 型 e の例外、再開は無い
newtype Exc e v = Exc e
    deriving (Functor, Typeable)

-- 型は推論される
throwError :: (Typeable e, Member (Exc e) r) => e -> Eff r a
throwError e = send (\_ -> inj $ Exc e)

runError :: Typeable e => Eff (Exc e :> r) a -> Eff r (Either e a)
runError m = loop (admin m)
 where
 loop (Val x)  = return (Right x)
 loop (E u)    = handle_relay u loop (\(Exc e) -> return (Left e))

-- 例外を再び投げることを許されたハンドラ
catchError :: (Typeable e, Member (Exc e) r) =>
        Eff r a -> (e -> Eff r a) -> Eff r a
catchError m handle = loop (admin m)
 where
 loop (Val x)  = return x
 loop (E u)    = interpose u loop (\(Exc e) -> handle e)

-- 型は推論される
et1 :: Eff r Int
et1 = return 1 `add` return 2

et1r = run et1
-- 3

-- 型は推論される
et2 :: Member (Exc Int) r => Eff r Int
et2 = return 1 `add` throwError (2::Int)

-- 以下のものは型付けが上手くいかない：例外がハンドルされていないのだ！
-- ex2r = run et2
{-
    No instance for (Member (Exc Int) Void)
      arising from a use of `et2'
-}

-- 推論された型は ex21 が今や純粋であることを示している
et21 :: Eff r (Either Int Int)
et21 = runError et2

et21r = run et21
-- Left 2

-- 論文からの例
newtype TooBig = TooBig Int deriving (Show, Typeable)
-- 型は推論される
ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int
ex2 m = do
  v <- m
  if v > 5 then throwError (TooBig v)
     else return v

-- 例外の型を伝えるために特殊化している
runErrBig :: Eff (Exc TooBig :> r) a -> Eff r (Either TooBig a)
runErrBig m = runError m

ex2r = runReader (runErrBig (ex2 ask)) (5::Int)

ex2rr = run ex2r
-- Right 5

ex2rr1 = run $ runReader (runErrBig (ex2 ask)) (7::Int)
-- Left (TooBig 7)

-- 異なる順序のハンドラ（層）
-- Different order of handlers (layers)
ex2rr2 = run $ runErrBig (runReader (ex2 ask) (7::Int))
-- Left (TooBig 7)

-- ------------------------------------------------------------------------
-- 非決定論（選択）

-- choose lst は lst から一つの値を非決定論的に選ぶ。
-- choose [] はゆえに失敗と対応している。
data Choose v = forall a. Choose [a] (a -> v)
              deriving (Typeable)

instance Functor Choose where
    fmap f (Choose lst k) = Choose lst (f . k)

choose :: Member Choose r => [a] -> Eff r a
choose lst = send (\k -> inj $ Choose lst k)

-- モナドプラスに似た演算子は choose を通して表現できる

mzero' :: Member Choose r => Eff r a
mzero' = choose []
mplus' m1 m2 = choose [m1,m2] >>= id


-- 解釈器
makeChoice :: forall a r. Eff (Choose :> r) a -> Eff r [a]
makeChoice m = loop (admin m)
 where
 loop (Val x)  = return [x]
 loop (E u)    = handle_relay u loop (\(Choose lst k) -> handle lst k)
 -- 局所的な束縛はもはや多相的でないので、型注釈が必要である
 handle :: [t] -> (t -> VE a (Choose :> r)) -> Eff r [a]
 handle [] _  = return []
 handle [x] k = loop (k x)
 handle lst k = fmap concat $ mapM (loop . k) lst

exc1 :: Member Choose r => Eff r Int
exc1 = return 1 `add` choose [1,2]

exc11 = makeChoice exc1

exc11r = run exc11
-- [2,3]

-- ------------------------------------------------------------------------
-- ソフトカット：非決定論的 if-then-elseで、Prolog の *-> としても知られる。
-- 宣言的には、
--    ifte t th el = (t >>= th) `mplus` ((not t) >> el)
-- であるが、t は一度だけ評価される。
-- つまり、ifte t th el は、t が1個以上の答えを持つ場合 t >>= th と等価である。
-- t が失敗したら、ifte t th el は el と同じである。

ifte :: forall r a b.
        Member Choose r => Eff r a -> (a -> Eff r b) -> Eff r b -> Eff r b
ifte t th el = loop [] (admin t)
 where
 loop [] (Val x)  = th x
 -- th x に対する t の他の全ての潜在的な選択肢を付け足す
 -- t のリフレクションに似ている
 loop jq (Val x)  = choose ((th x) : map (\t -> reflect t >>= th) jq)
                              >>= id
 loop jq (E u)    = interpose u (loop jq)
                              (\(Choose lst k) -> handle jq lst k)
 -- 局所的な束縛はもはや多相的でないので、型注釈が必要である
 handle :: [VE a r] -> [t] -> (t -> VE a r) -> Eff r b
 handle [] [] _     = el                    -- no more choices left
 handle (j:jq) [] _ = loop jq j
 handle jq [x] k    = loop jq (k x)
 handle jq (x:rest) k = loop (map k rest ++ jq) (k x) -- DFS

guard' :: Member Choose r => Bool -> Eff r ()
guard' True  = return ()
guard' False = mzero'

-- 素数列（すごく非効率だが ifte の良い例である）
test_ifte = do
  n <- gen
  guard' $ n > 1
  ifte (do
     d <- gen
     guard' $ d < n && d > 1 && n `mod` d == 0
     -- _ <- trace ("d: " ++ show d) (return ())
     return d)
    (\_->mzero')
    (return n)
 where gen = choose [1..30]

test_ifte_run = run . makeChoice $ test_ifte
-- [2,3,5,7,11,13,17,19,23,29]

-- ------------------------------------------------------------------------
-- 例外と非決定論の組み合わせ

-- 論文からの例


ex2_2 = run . makeChoice . runErrBig $ ex2 (choose [5,7,1])
-- [Right 5,Left (TooBig 7),Right 1]

-- transf.hs の ex1_1 に似ているが、transf.hs の ex2_1 にはまったく似ていない。

-- ハンドラの順序を逆にして、高い優先度の例外の望まれた結果を取得する。
ex2_1 = run . runErrBig . makeChoice $ ex2 (choose [5,7,1])
-- Left (TooBig 7)

-- エラーの復帰部分
-- コードは transf1.hs と同じである。
-- 推論された型注釈で違うのは
--     exRec :: MonadError TooBig m => m Int -> m Int
--     exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int
exRec m = catchError m handler
 where handler (TooBig n) | n <= 7 = return n
       handler e = throwError e

ex2r_2 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,1]))
-- Right [5,7,1]
-- transf1.hs の ex2r_1 と比較せよ。

ex2r_2' = run . makeChoice . runErrBig $ exRec (ex2 (choose [5,7,1]))
-- [Right 5,Right 7,Right 1]
-- またしても、3つの選択肢すべてが説明されている。

ex2r_1 = run . runErrBig . makeChoice $ exRec (ex2 (choose [5,7,11,1]))
-- Left (TooBig 11)
-- transf1.hs の ex2r_2 と比較せよ。

-- ------------------------------------------------------------------------
-- 状態（正格）

data State s w = State (s->s) (s -> w)
  deriving (Typeable, Functor)

-- 型注釈は推論される。
put :: (Typeable s, Member (State s) r) => s -> Eff r ()
put s = send (\k -> inj (State (const s) (\_ -> k ())))

modify :: (Typeable s, Member (State s) r) => (s -> s) -> Eff r s
modify f = send (\k -> inj (State f k))

-- 型注釈は推論される。
get :: (Typeable s, Member (State s) r) => Eff r s
get = send (\k -> inj (State id k))

runState :: Typeable s => Eff (State s :> r) w -> s -> Eff r (w,s)
runState m s = loop s (admin m) where
 loop s (Val x) = return (x,s)
 loop s (E u)   = handle_relay u (loop s) $
                    \(State t k) -> let s' = t s in s' `seq` loop s' (k s')

-- 例

ts1 :: Member (State Int) r => Eff r Int
ts1 = do
  put (10 ::Int)
  x <- get
  return (x::Int)

ts1r = run (runState ts1 (0::Int))
-- (10,10)

ts2 :: Member (State Int) r => Eff r Int
ts2 = do
  put (10::Int)
  x <- get
  put (20::Int)
  y <- get
  return (x+y)

ts2r = run (runState ts2 (0::Int))
-- (30,20)

-- 例外と状態
incr :: Member (State Int) r => Eff r ()
incr = get >>= put . (+ (1::Int))

tes1 :: (Member (State Int) r, Member (Exc [Char]) r) => Eff r b
tes1 = do
 incr
 throwError "exc"

ter1 :: (Either String String, Int)
ter1 = run $ runState (runError tes1) (1::Int)
-- (Left "exc",2)

ter2 :: Either String (String, Int)
ter2 = run $ runError (runState tes1 (1::Int))
-- Left "exc"


teCatch :: Member (Exc String) r => Eff r a -> Eff r [Char]
teCatch m = catchError (m >> return "done") (\e -> return (e::String))

ter3 :: (Either String String, Int)
ter3 = run $ runState (runError (teCatch tes1)) (1::Int)
-- (Right "exc",2)

ter4 :: Either String (String, Int)
ter4 = run $ runError (runState (teCatch tes1) (1::Int))
-- Right ("exc",2)


-- 作用のカプセル化
-- この例はレビュワーによって提案された

{- レビュワーは以下の MTL の実装の概要についてこう言った。
  「これは状態作用を隠すので、
    私は型クラスシステムと衝突せずに、
    別の状態作用の層を重ねられる。」

class Monad m => MonadFresh m where
    fresh :: m Int

newtype FreshT m a = FreshT { unFreshT :: State Int m a }
      deriving (Functor, Monad, MonadTrans)

    instance Monad m => MonadFresh (FreshT m) where
      fresh = FreshT $ do n <- get; put (n+1); return n

完全なコードについては ExtMTL.hs を参照せよ。
-}

-- 3つの可能な実装がある。
-- 1番目は State Fresh を使う。ただし
--    newtype Fresh = Fresh Int
-- である。
-- 私たちは他の層に干渉しない
-- 「プライベート」な作用の層（State Fresh）を得る。
-- これが最も簡単な実装である。

-- 2番目の実装は新しい作用 Fresh を定義するものである。

newtype Fresh v = Fresh (Int -> v)
    deriving (Functor, Typeable)

fresh :: Member Fresh r => Eff r Int
fresh = send (inj . Fresh)

-- そしてそのハンドラ
runFresh' :: Eff (Fresh :> r) w -> Int -> Eff r w
runFresh' m s = loop s (admin m) where
 loop s (Val x) = return x
 loop s (E u)   = handle_relay u (loop s) $
                       \(Fresh k) -> (loop $! (s+1)) (k s)

-- テスト
tfresh' = runTrace $ flip runFresh' 0 $ do
  n <- fresh
  trace $ "Fresh " ++ show n
  n <- fresh
  trace $ "Fresh " ++ show n

-- 最後に、最悪の実装だがレビュワーの質問に答えるものである：
-- Fresh を、実情を明かさずに State を使って実装するのである。

runFresh :: Eff (Fresh :> r) w -> Int -> Eff r w
runFresh m s = runState m' s >>= return . fst
 where
 m' = loop (admin m)
 loop (Val x) = return x
 loop (E u)   = case decomp u of
  Right (Fresh k) -> do
                     n <- get
                     put (n+1::Int)
                     loop (k n)
  Left u  -> send (\k -> weaken $ fmap k u) >>= loop

tfresh = runTrace $ flip runFresh 0 $ do
  n <- fresh
  -- (x::Int) <- get
  trace $ "Fresh " ++ show n
  n <- fresh
  trace $ "Fresh " ++ show n

{-
カプセル化された状態に対し、
上の get ステートメントのコメントを外すことで
干渉しようとすると、次を得る：
    No instance for (Member (State Int) Void)
      arising from a use of `get'
-}


-- ------------------------------------------------------------------------
-- トレース（デバッグ表示）

data Trace v = Trace String (() -> v)
    deriving (Typeable, Functor)

-- トレースに文字列を表示する
trace :: Member Trace r => String -> Eff r ()
trace x = send (inj . Trace x)

-- IO リクエストに対するハンドラ：終了ハンドラ
runTrace :: Eff (Trace :> Void) w -> IO w
runTrace m = loop (admin m) where
 loop (Val x) = return x
 loop (E u)   = case prj u of
                  Just (Trace s k) -> putStrLn s >> loop (k ())
                  -- Nothing は起こりえない

-- 高階の作用のある関数
-- 推論された型は Trace 作用が
-- r の作用の集合に足されたことを示している。
mapMdebug:: (Show a, Member Trace r) =>
     (a -> Eff r b) -> [a] -> Eff r [b]
mapMdebug f [] = return []
mapMdebug f (h:t) = do
 trace $ "mapMdebug: " ++ show h
 h' <- f h
 t' <- mapMdebug f t
 return (h':t')

tMd = runTrace $ runReader (mapMdebug f [1..5]) (10::Int)
 where f x = ask `add` return x
{-
mapMdebug: 1
mapMdebug: 2
mapMdebug: 3
mapMdebug: 4
mapMdebug: 5
[11,12,13,14,15]
-}

-- 層を複製する
tdup = runTrace $ runReader m (10::Int)
 where
 m = do
     runReader tr (20::Int)
     tr
 tr = do
      v <- ask
      trace $ "Asked: " ++ show (v::Int)

-- ------------------------------------------------------------------------
-- 持ち上げ：モナド変換子を模倣する

data Lift m v = forall a. Lift (m a) (a -> v)

-- ST モナドについては、
-- (ST s) は Typeable になりえないので、
-- ListST を定義しなければならない：
-- s は何の制約もなしに多相的でなければならないのだ

{--
ghci 7.6.3 ==>
Eff.hs:465:29: Warning:
    In the use of `mkTyCon' (imported from Data.Typeable):
    Deprecated: "either derive Typeable, or use mkTyCon3 instead"
--}
{-
instance Typeable1 m => Typeable1 (Lift m) where
    typeOf1 _ =
     mkTyConApp (mkTyCon3 "" "Eff" "Lift") [typeOf1 (undefined:: m ())]
-}
deriving instance Typeable Lift

instance Functor (Lift m) where
    fmap f (Lift m k) = Lift m (f . k)

-- 私たちは MemberU2 を使って Lift の層を唯一のものにする
lift :: (Typeable1 m, MemberU2 Lift (Lift m) r) => m a -> Eff r a
lift m = send (inj . Lift m)

-- Lift リクエストのハンドラ。つまり終了するものなのである。
runLift :: (Monad m, Typeable1 m) => Eff (Lift m :> Void) w -> m w
runLift m = loop (admin m) where
 loop (Val x) = return x
 loop (E u)   = case prj u of
                  Just (Lift m k) -> m >>= loop . k
                  -- Nothing は起こりえない

tl1 = ask >>= \(x::Int) -> lift . print $ x

-- tl1r :: IO ()
tl1r = runLift (runReader tl1 (5::Int))
-- 5

-- mapMdebug の Lifting を使った再実装
-- 型注釈は推論される
mapMdebug'  :: (Show a, MemberU2 Lift (Lift IO) r) =>
             (a -> Eff r b) -> [a] -> Eff r [b]
mapMdebug' f [] = return []
mapMdebug' f (h:t) = do
 lift $ print h
 h' <- f h
 t' <- mapMdebug' f t
 return (h':t')

tMd' = runLift $ runReader (mapMdebug' f [1..5]) (10::Int)
 where f x = ask `add` return x
{-
1
2
3
4
5
[11,12,13,14,15]
-}


-- ------------------------------------------------------------------------
-- コルーチン
-- インターフェースは transf.hs と同じになるようにわざと選んでいる

-- yield リクエスト：
-- 型 a の値を報告し、コルーチンを保留する。
-- 型 b の値とともに再開する。
data Yield a b v = Yield a (b -> v)
    deriving (Typeable, Functor)

-- 型注釈は推論される
yield :: (Typeable a, Typeable b, Member (Yield a b) r) => a -> Eff r b
yield x = send (inj . Yield x)

-- スレッドのステータス：
-- 終了しているか、型 a の値を報告して型 b の値とともに再開しているか
data Y r a b = Done | Y a (b -> Eff r (Y r a b))

-- スレッドを開始し、そのステータスを報告する
runC :: (Typeable a, Typeable b) =>
        Eff (Yield a b :> r) w -> Eff r (Y r a b)
runC m = loop (admin m) where
 loop (Val x) = return Done
 loop (E u)   = handle_relay u loop $
                 \(Yield x k) -> return (Y x (loop . k))


-- コルーチンの1番目の例
yieldInt :: Member (Yield Int ()) r => Int -> Eff r ()
yieldInt = yield

th1 :: Member (Yield Int ()) r => Eff r ()
th1 = yieldInt 1 >> yieldInt 2


c1 = runTrace (loop =<< runC th1)
 where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
       loop Done    = trace "Done"
{-
1
2
Done
-}

-- 動的変数を付け足す
-- このコードは実質的に transf.hs のものと同じである
-- （yield に型を特殊化するものを足しているだけである）。
-- でも推論された型注釈は異なる。
-- 以前は
--    th2 :: MonadReader Int m => CoT Int m ()
-- であったが今はもっと一般的である：
th2 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r ()
th2 = ask >>= yieldInt >> (ask >>= yieldInt)


-- このコードは実質的に transf.hs のものと同じである。ただし liftIO は無い。
c2 = runTrace $ runReader (loop =<< runC th2) (10::Int)
 where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
       loop Done    = trace "Done"
{-
10
10
Done
-}

-- 保留された計算に対する動的環境をローカルに変更する
c21 = runTrace $ runReader (loop =<< runC th2) (10::Int)
 where loop (Y x k) = trace (show (x::Int))
                    >> local (+(1::Int)) (k ()) >>= loop
       loop Done    = trace "Done"
{-
10
11
Done
-}

-- ローカルな再束縛が2種類ある、実際の例
th3 :: (Member (Yield Int ()) r, Member (Reader Int) r) => Eff r ()
th3 = ay >> ay >> local (+(10::Int)) (ay >> ay)
 where ay = ask >>= yieldInt

c3 = runTrace $ runReader (loop =<< runC th3) (10::Int)
 where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
       loop Done    = trace "Done"
{-
10
10
20
20
Done
-}

-- 保留された計算に対する動的環境をローカルに変更する
c31 = runTrace $ runReader (loop =<< runC th3) (10::Int)
 where loop (Y x k) = trace (show (x::Int))
                              >> local (+(1::Int)) (k ()) >>= loop
       loop Done    = trace "Done"
{-
10
11
21
21
Done
-}
-- 結果はまさに期待し望んだとおりである：
-- コルーチンは親と動的環境を共有するが、環境がローカルに再束縛されると、
-- 環境はコルーチンに対しプライベートなものになる。

-- th4 によって実行されるクライアントの計算が抽象的であるということを明示する。
-- 私たちは th4 からこれを抽象化する。
c4 = runTrace $ runReader (loop =<< runC (th4 client)) (10::Int)
 where loop (Y x k) = trace (show (x::Int))
                                >> local (+(1::Int)) (k ()) >>= loop
       loop Done    = trace "Done"

       -- cl, client, ay は単相的な束縛である
       th4 cl = cl >> local (+(10::Int)) cl
       client = ay >> ay
       ay     = ask >>= yieldInt

{-
10
11
21
21
Done
-}

-- もっと動的な例
c5 = runTrace $ runReader (loop =<< runC (th client)) (10::Int)
 where loop (Y x k) = trace (show (x::Int))
                              >> local (\y->x+1) (k ()) >>= loop
       loop Done    = trace "Done"

       -- cl, client, ay は単相的な束縛である
       client = ay >> ay >> ay
       ay     = ask >>= yieldInt

       -- 多相的な再帰はここにはない
       th cl = do
         cl
         v <- ask
         (if v > (20::Int) then id else local (+(5::Int))) cl
         if v > (20::Int) then return () else local (+(10::Int)) (th cl)
{-
10
11
12
18
18
18
29
29
29
29
29
29
Done
-}

-- もっと動的な例
c7 = runTrace $
      runReader (runReader (loop =<< runC (th client))
      (10::Int)) (1000::Double)
 where loop (Y x k) = trace (show (x::Int))
                              >> local (\y->fromIntegral (x+1)::Double) (k ())
                              >>= loop
       loop Done    = trace "Done"

       -- cl, client, ay は単相的な束縛である
       client = ay >> ay >> ay
       ay     = ask >>= \x -> ask >>=
                 \y -> yieldInt (x + round (y::Double))

        -- 多相的な再帰はここにはない
       th cl = do
         cl
         v <- ask
         (if v > (20::Int) then id else local (+(5::Int))) cl
         if v > (20::Int) then return () else local (+(10::Int)) (th cl)

{-
1010
1021
1032
1048
1064
1080
1101
1122
1143
1169
1195
1221
1252
1283
1314
1345
1376
1407
Done
-}

c7' = runTrace $
      runReader (runReader (loop =<< runC (th client))
      (10::Int)) (1000::Double)
 where loop (Y x k) = trace (show (x::Int))
                              >> local (\y->fromIntegral (x+1)::Double) (k ())
                              >>= loop
       loop Done    = trace "Done"

       -- cl, client, ay は単相的な束縛である
       client = ay >> ay >> ay
       ay     = ask >>= \x -> ask >>=
                 \y -> yieldInt (x + round (y::Double))

       -- 多相的な再帰はここにはない
       th cl = do
         cl
         v <- ask
         (if v > (20::Int) then id else local (+(5::Double))) cl
         if v > (20::Int) then return () else local (+(10::Int)) (th cl)
{-
1010
1021
1032
1048
1048
1048
1069
1090
1111
1137
1137
1137
1168
1199
1230
1261
1292
1323
Done
-}

-- ------------------------------------------------------------------------
-- 2つの作用を共にハンドルする、作用の非自明なやりとりの例
-- 制御（カット）付きの非決定論
-- カットの説明については、ヒンツェの ICFP 2000 の論文の §5 を参照せよ。
-- ヒンツェは cut を cutfalse を使って表現することを提案している。
--  ! = return () `mplus` cutfalse
-- where
--  cutfalse :: m a
-- は以下の法則を満たす。
--   cutfalse >>= k  = cutfalse              (F1)
--   cutfalse | m    = cutfalse              (F2)
-- （補足：m `mplus` cutfalse は cutfalse `mplus` m と異なる）
-- つまり、cutfalse は bind と mplus の左零元なのである。
--
-- ヒンツェはカットの作用を限定する演算 call :: m a -> m a も導入している：
-- call m は m を実行するのである。
-- もし cut が m で呼び出されれば、
-- cut は m が呼ばれてからなされた選択肢のみを切り捨てる。
-- ヒンツェは call に対し以下の公理を要請している。
--
--   call false = false                          (C1)
--   call (return a | m) = return a | call m     (C2)
--   call (m | cutfalse) = call m                (C3)
--   call (lift m >>= k) = lift m >>= (call . k) (C4)
--
-- call m は、m の内部のカットが
-- ローカルな作用だけを持っているという点を除いて、
-- m のように振る舞う、と彼は言う。

-- ヒンツェはカットのあるモナド変換子のバックトラッキングを
-- 「機械的に」導出する際の問題について触れている：
-- call と bind のやりとりを特定する公理はなく、
-- call の入れ子なった呼び出しを単純化する方法も無いのである。

-- 私たちは cutfalse に対して例外を使う。
-- ゆえに ``cutfalse >>= k       = cutfalse'' 則は、
-- すべての例外が上述の性質を満たしているため、自動的に満たされるのである。

data CutFalse = CutFalse deriving Typeable

cutfalse = throwError CutFalse

-- 解釈器 -- 一捻りある reify . reflect に似ている。
-- この実装をヒンツェ 2000（図9）の巨大な call の実装と比較せよ。
-- それぞれの節は、call か cutfalse の公理に対応している。
-- すべての公理がカバーされている。
-- このコードは明らかに call が引数の計算の選択点を
-- 見張っているという直感を表現している。
-- cutfalse リクエストに出会ったら、残りの選択点を見捨てる。

-- これは CutFalse の作用を完全にハンドルするが、非決定論ではない。
call :: Member Choose r => Eff (Exc CutFalse :> r) a -> Eff r a
call m = loop [] (admin m) where
 loop jq (Val x) = return x `mplus'` next jq          -- (C2)
 loop jq (E u) = case decomp u of
    Right (Exc CutFalse) -> mzero'  -- drop jq (F2)
    Left u -> check jq u

 check jq u | Just (Choose [] _) <- prj u  = next jq  -- (C1)
 check jq u | Just (Choose [x] k) <- prj u = loop jq (k x)  -- (C3), optim
 check jq u | Just (Choose lst k) <- prj u = next $ map k lst ++ jq -- (C3)
 check jq u = send (\k -> fmap k u) >>= loop jq      -- (C4)

 next []    = mzero'
 next (h:t) = loop t h

-- 型注釈は推論される
tcut1 :: (Member Choose r, Member (Exc CutFalse) r) => Eff r Int
tcut1 = (return (1::Int) `mplus'` return 2) `mplus'`
         ((cutfalse `mplus'` return 4) `mplus'`
          return 5)

tcut1r = run . makeChoice $ call tcut1
-- [1,2]

tcut2 = return (1::Int) `mplus'`
         call (return 2 `mplus'` (cutfalse `mplus'` return 3) `mplus'`
               return 4)
       `mplus'` return 5

-- ここで私たちは入れ子になった call を見る。問題は全くない……
tcut2r = run . makeChoice $ call tcut2
-- [1,2,5]

-- もっと入れ子になった call
tcut3 = call tcut1 `mplus'` call (tcut2 `mplus'` cutfalse)
tcut3r = run . makeChoice $ call tcut3
-- [1,2,1,2,5]

tcut4 = call tcut1 `mplus'`  (tcut2 `mplus'` cutfalse)
tcut4r = run . makeChoice $ call tcut4
-- [1,2,1,2,5]

付録B. OpenUnion1.hs

論文で使われている開かれた和のコード。HList の論文の実装に近い。このコードは、Typeable に頼っていて、モジュール内に限定されている重複インスタンス拡張 (overlapping instances extension) を使って閉じた型族をエミュレートしている。

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE OverlappingInstances #-}
-- モナド変換子を模倣する際の、以下の MemberU に対してのみ
{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}

-- 拡張可能作用に対するオープンな和（型で指標付けされた余積）
-- この実装は「閉じた」重複するインスタンス
-- （あるいは GHC に直に追加される閉じた型関数の重複）に頼っている。

module OpenUnion1 (Union, inj, prj, decomp,
                   Member, MemberU, MemberU2, (:>), weaken
                  ) where

import Data.Typeable

-- 引数 r は幽霊である：和の中に何があるかを伝えているだけである。
-- この符号化は HList の論文のものとかなり似ている。
-- データ構成子 Union はエクスポートされていない。

data Union r v where                      -- r は種 [*->*] を持つ
  Union :: (Functor t, Typeable1 t) => Id (t v) -> Union r v

newtype Id x = Id x                     -- gcast1 のため

instance Functor (Union r) where
    {-# INLINE fmap #-}
    fmap f (Union (Id v)) = Union (Id (fmap f v))

{-# INLINE inj #-}
inj :: (Functor t, Typeable1 t, Member t r) => t v -> Union r v
inj x = Union (Id x)

{-# INLINE prj #-}
prj :: (Functor t, Typeable1 t, Member t r) => Union r v -> Maybe (t v)
prj (Union v) | Just (Id x) <- gcast1 v = Just x
prj _ = Nothing

{-# INLINE decomp #-}
decomp :: Typeable1 t => Union (t :> r) v -> Either (Union r v) (t v)
decomp (Union v) | Just (Id x) <- gcast1 v = Right x
decomp (Union v) = Left (Union v)

weaken :: (Typeable1 t, Functor t) => Union r w -> Union (t :> r) w
weaken (Union x) = Union x

class Member (t :: * -> *) r
instance Member t (t :> r)
instance Member t r => Member t (t' :> r)

-- 作用を合成するための和のデータ型
-- GHC 7.4 ではリストにしなければならない
-- (:>) :: (* -> *) -> (* -> List) -> List
infixr 1 :>
data ((a :: * -> *) :> b)

-- この型クラスはモナド変換子を模倣するために使われる
class Member t r =>
    MemberU (tag :: * -> * -> *) (t :: * -> *) r | tag r -> t
instance MemberU tag (tag e) (tag e :> r)
instance MemberU tag t r => MemberU tag t (t' :> r)

-- MemberU の異なる種の引数のための変種。
-- 最新の GHC はよく機能する PolyKind 拡張があるから、
-- MemberU2 は MemberU と合併しうる。
class Member t r =>
      MemberU2 (tag :: (* -> *) -> * -> *) (t :: * -> *) r | tag r -> t
instance MemberU2 tag (tag e) (tag e :> r)
instance MemberU2 tag t r => MemberU2 tag t (t' :> r)

付録C. OpenUnion2.hs

重複インスタンスのないバージョンの、閉じた型族を直接使うオープンな和。

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}

-- モナド変換子を模倣する際の、以下の MemberU に対してのみ
{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}

-- 拡張可能作用に対するオープンな和（型で指標付けされた余積）
-- この実装は GHC 7.8 に追加された「閉じた」型族に頼っている。
-- 重複するインスタンスは無い。

module OpenUnion2 (Union, inj, prj, decomp,
                   Member, MemberU2, (:>), weaken
                  ) where

import Data.Typeable

-- 引数 r は幽霊である：和の中に何があるかを伝えているだけである。
-- この符号化は HList の論文のものとかなり似ている。
-- データ構成子 Union はエクスポートされていない。

data Union r v where                      -- r は種 [*->*] を持つ
  Union :: (Functor t, Typeable t) => Id (t v) -> Union r v

newtype Id x = Id x                     -- gcast1 のため

instance Functor (Union r) where
    {-# INLINE fmap #-}
    fmap f (Union (Id v)) = Union (Id (fmap f v))

{-# INLINE inj #-}
inj :: (Functor t, Typeable t, Member t r) => t v -> Union r v
inj x = Union (Id x)

{-# INLINE prj #-}
prj :: (Functor t, Typeable t, Member t r) => Union r v -> Maybe (t v)
prj (Union v) | Just (Id x) <- gcast1 v = Just x
prj _ = Nothing

{-# INLINE decomp #-}
decomp :: Typeable t => Union (t :> r) v -> Either (Union r v) (t v)
decomp (Union v) | Just (Id x) <- gcast1 v = Right x
decomp (Union v) = Left (Union v)

weaken :: (Typeable t, Functor t) => Union r w -> Union (t :> r) w
weaken (Union x) = Union x

-- 型クラス Member はインターフェースの OpenUnion1 との
-- 互換性だけのために定義されている。
-- 一般に、下の閉じた型族 Member' を代わりに使うことができる。

class (Member' t r ~ True) => Member (t :: * -> *) r
instance (Member' t r ~ True) => Member t r

type family Member' (t :: * -> *) r :: Bool where
  Member' t (t :> r)  = True
  Member' t ()        = False
  Member' t (t' :> r) = Member' t r


-- 作用を合成するための和のデータ型
-- GHC 7.4 ではリストにしなければならない
-- (:>) :: (* -> *) -> (* -> List) -> List
infixr 1 :>
data ((a :: * -> *) :> b)

type family EQU (a :: k) (b :: k) :: Bool where
  EQU a a = True
  EQU a b = False

-- この型クラスはモナド変換子を模倣するために使われる
class Member t r =>
    MemberU2 (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t
instance (MemberU' (EQU t1 t2) tag t1 (t2 :> r)) =>
    MemberU2 tag t1 (t2 :> r)

class Member t r =>
      MemberU' (f::Bool) (tag :: k -> * -> *) (t :: * -> *) r | tag r -> t
instance MemberU' True tag (tag e) (tag e :> r)
instance (Member' t (t' :> r) ~ True, MemberU2 tag t r) =>
           MemberU' False tag t (t' :> r)

付録D. OpenUnion3.hs

存在型ではなく全称量化型に頼っている、もう一つの、OpenUnion2.hs といくぶんか双対な実装。

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE OverlappingInstances #-}
-- モナド変換子を模倣する際の、以下の MemberU に対してのみ
{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}

-- 拡張可能作用に対するオープンな和（型で指標付けされた余積）
-- この実装は「閉じた」重複するインスタンス
-- （あるいは GHC に直に追加される閉じた型関数の重複）に頼っている。

module OpenUnion3 (Union, inj, prj, decomp,
                   Member, MemberU, MemberU2, (:>)
                  ) where

import Data.Typeable

-- 引数 r は幽霊である：和の中に何があるかを伝えているだけである。
-- この符号化は HList の論文のものとかなり似ている。
-- データ構成子 Union はエクスポートされていない。

newtype Union r v =        -- r is of a kind [*->*] and phantom
  Union (forall t. (Functor t, Typeable1 t) => Maybe (t v))

newtype Id x = Id x                     -- gcast1 のため

instance Functor (Union r) where
    fmap f (Union p) = Union (maybe Nothing (Just . fmap f) p)

inj :: (Functor t, Typeable1 t, Member t r) => t v -> Union r v
inj x = Union (maybe Nothing (\(Id x) -> Just x) $ gcast1 (Id x))

prj :: (Functor t, Typeable1 t, Member t r) => Union r v -> Maybe (t v)
prj (Union p) = p

{-# INLINE decomp #-}
decomp :: (Functor t, Typeable1 t) =>
          Union (t :> r) v -> Either (Union r v) (t v)
decomp (Union p) | Just x <- p = Right x
decomp (Union p) = Left (Union p)

class Member (t :: * -> *) r
instance Member t (t :> r)
instance Member t r => Member t (t' :> r)

-- 作用を合成するための和のデータ型
-- GHC 7.4 ではリストにしなければならない
-- (:>) :: (* -> *) -> (* -> List) -> List
infixr 1 :>
data ((a :: * -> *) :> b)

-- この型クラスはモナド変換子を模倣するために使われる
class Member t r =>
    MemberU (tag :: * -> * -> *) (t :: * -> *) r | tag r -> t
instance MemberU tag (tag e) (tag e :> r)
instance MemberU tag t r => MemberU tag t (t' :> r)

-- MemberU の異なる種の引数のための変種。
-- 最新の GHC はよく機能する PolyKind 拡張があるから、
-- MemberU2 は MemberU と合併しうる。
class Member t r =>
      MemberU2 (tag :: (* -> *) -> * -> *) (t :: * -> *) r | tag r -> t
instance MemberU2 tag (tag e) (tag e :> r)
instance MemberU2 tag t r => MemberU2 tag t (t' :> r)

付録E. ExtMTL.hs

MTL のモナド変換子クラスをエミュレートするEff.fs の変種。拡張可能作用フレームワークは実は MonadError, MonadReader, MonadState などのインスタンスを定義できる。これらのインスタンスを使うならば、ユーザーのコードにおける型注釈が少なくて済む。一方で、より一般性が小さく、特定の種の単一の作用の層を強制する。

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

-- 格闘可能作用：
-- モナド変換子のクラスを模倣する Eff.hs の変種
-- MonadError, MonadReader, MonadState などの
-- インスタンスを定義することは可能である。
-- 良い面：型注釈が減る。
-- 悪い面：特定の種の層が一つだけになるように強制し、一般性を失っていること。

module ExtMTL where

import Control.Monad
import Data.Typeable
import OpenUnion1

import Control.Monad.Reader (MonadReader(..))
import Control.Monad.Error (MonadError(..))
import Control.Monad.State (MonadState(..))

import qualified Eff as E
import Eff (Eff, Void, run, Reader, runReader, Exc, runError,
            Choose, choose, makeChoice, Trace, trace, runTrace,
            State, runState,
            Yield, yield, runC, Y(..))


-- ------------------------------------------------------------------------
-- 読み取りモナド

instance (MemberU Reader (Reader e) r, Typeable e) =>
    MonadReader e (Eff r) where
    ask = E.ask
    local = E.local

-- 例
add :: Monad m => m Int -> m Int -> m Int
add = liftM2 (+)

-- 型は推論される
t1 :: MonadReader Int m => m Int
t1 = ask `add` return 1


-- 数値 10 に型注釈は必要ない
-- t1r :: Eff r Int
t1r = runReader t1 10

t1rr = run t1r
-- 11

-- 型は推論される
-- t3 :: Member (Reader Int) r => Eff r Int
-- t3 :: MonadReader Int m => m Int
t3 = t1 `add` local (+ (10::Int)) t1
t3r = run $ runReader t3 (100::Int)
-- 212

{-
t1rr' = run t1
    No instance for (MemberU Reader (Reader Int) Void)
      arising from a use of `t1'
-}

{- この例は定義できない：読み取りの層は一つだけなのだ。

-- Inferred type
-- t2 :: (Member (Reader Int) r, Member (Reader Float) r) => Eff r Float
t2 = do
  v1 <- ask
  v2 <- ask
  return $ fromIntegral (v1 + (1::Int)) + (v2 + (2::Float))

-- t2r :: Member (Reader Float) r => Eff r Float
t2r = runReader t2 (10::Int)
-- t2rr :: Eff r Float
t2rr = runReader (runReader t2 (10::Int)) (20::Float)

t2rrr = run t2rr
-- 33.0

-- 以下の例は、Reader Int と Reader Float の層の真の交替を実演している
{-
t4
  :: (Member (Reader Int) r, Member (Reader Float) r) =>
     () -> Eff r Float
-}
t4 = liftM2 (+) (local (+ (10::Int)) t2)
                (local (+ (30::Float)) t2)

t4rr = run $ runReader (runReader t4 (10::Int)) (20::Float)
-- 106.0
-- 層の順番を逆にしても同じ結果が得られる
t4rr' = run $ runReader (runReader t4 (20::Float)) (10::Int)
-- 106.0
-}

-- 作用のある関数に対するマッピング
-- 型は推論される
-- tmap :: Member (Reader Int) r => Eff r [Int]
tmap :: MonadReader Int m => m [Int]
tmap = mapM f [1..5]
 where f x = ask `add` return x

tmapr = run $ runReader tmap (10::Int)
-- [11,12,13,14,15]

-- ------------------------------------------------------------------------
-- 例外

instance (MemberU Exc (Exc e) r, Typeable e) => MonadError e (Eff r) where
    throwError = E.throwError
    catchError = E.catchError

-- 型は推論される
et1 :: Eff r Int
et1 = return 1 `add` return 2

et1r = run et1
-- 3

-- 型は推論される
-- et2 :: Member (Exc Int) r => Eff r Int
et2 :: MonadError Int m => m Int
et2 = return 1 `add` throwError (2::Int)

-- 以下のものは型付けが上手くいかない：例外がハンドルされていないのだ！
-- ex2r = run et2
{-
    No instance for (MemberU Exc (Exc Int) Void)
      arising from a use of `et2'
-}

-- 推論された型は ex21 が今や純粋であることを示している
et21 :: Eff r (Either Int Int)
et21 = runError et2

et21r = run et21
-- Left 2

-- 論文からの例
newtype TooBig = TooBig Int deriving (Show, Typeable)
-- 型は推論される
-- ex2 :: Member (Exc TooBig) r => Eff r Int -> Eff r Int
ex2 :: MonadError TooBig m => m Int -> m Int
ex2 m = do
  v <- m
  if v > 5 then throwError (TooBig v)
     else return v


{-  もはや必要ない
-- 例外の型を伝えるために特殊化している
runErrBig :: Eff (Exc TooBig :> r) a -> Eff r (Either TooBig a)
runErrBig m = runError m
-}

-- 型は推論される
-- 数値に型注釈をつける必要はない
-- ex2r :: Eff r (Either TooBig Int)
ex2r = runReader (runError (ex2 ask)) 5

ex2rr = run ex2r
-- Right 5

ex2rr1 = run $ runReader (runError (ex2 ask)) 7
-- Left (TooBig 7)

-- 異なる順序のハンドラ（層）
ex2rr2 = run $ runError (runReader (ex2 ask) 7)
-- Left (TooBig 7)

-- ------------------------------------------------------------------------
-- 例外と非決定論の組み合わせ

-- 論文からの例

ex2_2 = run . makeChoice . runError $ ex2 (choose [5,7,1])
-- [Right 5,Left (TooBig 7),Right 1]

-- transf.hs の ex1_1 に似ているが、transf.hs の ex2_1 にはまったく似ていない

-- ハンドラの順序を逆にして、高い優先度の例外の望まれた結果を取得する
ex2_1 = run . runError . makeChoice $ ex2 (choose [5,7,1])
-- Left (TooBig 7)

-- エラーの復帰部分
-- コードは transf1.hs と同じである
-- 推論された型注釈で違うのは
--     exRec :: MonadError TooBig m => m Int -> m Int
--     exRec :: Member (Exc TooBig) r => Eff r Int -> Eff r Int
exRec :: MonadError TooBig m => m Int -> m Int
exRec m = catchError m handler
 where handler (TooBig n) | n <= 7 = return n
       handler e = throwError e

ex2r_2 = run . runError . makeChoice $ exRec (ex2 (choose [5,7,1]))
-- Right [5,7,1]
-- transf1.hs の ex2r_1 と比較せよ

ex2r_1 = run . runError . makeChoice $ exRec (ex2 (choose [5,7,11,1]))
-- Left (TooBig 11)
-- transf1.hs の ex2r_2 と比較せよ


-- ------------------------------------------------------------------------
-- 状態

instance (Member (State s) r, Typeable s) => MonadState s (Eff r) where
    get = E.get
    put = E.put

-- 例

ts1 :: MonadState Int m => m Int
ts1 = do
  put 10
  x <- get
  return x

ts1r = run (runState ts1 (0::Int))
-- (10,10)

ts2 :: MonadState Int m => m Int
ts2 = do
  put 10
  x <- get
  put 20
  y <- get
  return (x+y)

ts2r = run (runState ts2 (0::Int))
-- (30,20)

-- 例外と状態
incr :: MonadState Int m => m ()
incr = get >>= put . (+ 1)

tes1 :: (MonadState Int m,MonadError [Char] m) => m b
tes1 = do
 incr
 throwError "exc"

ter1 :: (Either String String, Int)
ter1 = run $ runState (runError tes1) (1::Int)
-- (Left "exc",2)

ter2 :: Either String (String, Int)
ter2 = run $ runError (runState tes1 (1::Int))
-- Left "exc"


teCatch :: MonadError String m => m a -> m [Char]
teCatch m = catchError (m >> return "done") return

ter3 :: (Either String String, Int)
ter3 = run $ runState (runError (teCatch tes1)) (1::Int)
-- (Right "exc",2)

ter4 :: Either String (String, Int)
ter4 = run $ runError (runState (teCatch tes1) (1::Int))
-- Right ("exc",2)


-- ------------------------------------------------------------------------
-- コルーチン

-- 動的変数を付け足す
-- このコードは実質的に transf.hs のものと同じである
-- （yield に型を特殊化するものを足しているだけである）。
-- でも推論された型注釈は異なる。
-- 以前は
--    th2 :: MonadReader Int m => CoT Int m ()
-- であったが今はもっと一般的である：
th2 :: (Member (Yield Int) r, MonadReader Int (Eff r)) => Eff r ()
th2 = ask >>= yield >> (ask >>= yield)


-- このコードは実質的に transf.hs のものと同じである。ただし liftIO は無い。
-- 型注釈が少なくなっている。
c2 = runTrace $ runReader (loop =<< runC th2) 10
 where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
       loop Done    = trace "Done"
{-
10
10
Done
-}

-- 保留された計算に対する動的環境をローカルに変更する
c21 = runTrace $ runReader (loop =<< runC th2) 10
 where loop (Y x k) = trace (show (x::Int)) >> local (+1) (k ()) >>= loop
       loop Done    = trace "Done"
{-
10
11
Done
-}

-- ローカルな再束縛が2種類ある、実際の例
-- th3 :: (Member (Yield Int) r, Member (Reader Int) r) => Eff r ()
-- th3 :: (Member (Yield Int) r, MonadReader Int (Eff r)) => Eff r ()
th3 :: (MemberU Reader (Reader Int) r, Member (Yield Int) r) =>
     Eff r ()
th3 = ay >> ay >> local (+10) (ay >> ay)
 where ay = ask >>= yield


c3 = runTrace $ runReader (loop =<< runC th3) 10
 where loop (Y x k) = trace (show (x::Int)) >> k () >>= loop
       loop Done    = trace "Done"
{-
10
10
20
20
Done
-}

-- 保留された計算に対する動的環境をローカルに変更する
c31 = runTrace $ runReader (loop =<< runC th3) 10
 where loop (Y x k) = trace (show (x::Int)) >> local (+1) (k ()) >>= loop
       loop Done    = trace "Done"
{-
10
11
21
21
Done
-}
-- 結果はまさに期待し望んだとおりである：
-- コルーチンは親と動的環境を共有するが、環境がローカルに再束縛されると、
-- 環境はコルーチンに対しプライベートなものになる。

付録F. Crossover.hs

交差のライブラリの、交差の例がたくさん付いているソースコード。

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE LambdaCase, DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ExistentialQuantification #-}

-- 一般的交差：
-- 2つのデータ構造の間で適当な部分を、一般的な手法で交換する

-- このライブラリは、データ構造を一般的に手術するためのものである：
-- データ構造を任意の場所で斬って、新しい枝と接合するのだ。
-- このライブラリは、様々な種類の交差を実装するのに使える。
-- このライブラリは拡張可能作用の良さ――
-- 新しい作用を定義し、2つの標準的な作用、状態と非決定論と合成するのが
-- 簡単であるということ――を見せびらかしている。

module Crossover where

import Data.Data
import Data.Dynamic
import Control.Monad (liftM2)

-- 拡張可能作用フレームワークを使っている。
-- 私はこのディレクトリの Eff.hs を使う。
-- 他の ExtEff フレームワークを使うためにコードを修正することもできる。
import Eff
import OpenUnion2

-- まず、私たちはデータ構造を、
-- 枝を置き換える可能性を持ちつつ走査するための演算を書く。
-- 走査は木が初めて更新された時に停止する。

-- データ構造に対する変更の回数
-- 十分な枝が更新されたら、私たちは走査を抜け出す。
-- 私たちは、gfoldl によってなされる子供の操作と
-- 情報を交わすために、状態が必要なのである。
newtype Updates = Updates Int deriving Typeable

-- この関数は、更新の回数を数える、gfoldl のラッパーである。
traverse :: Member (State Updates) r =>
      (forall a. (Data a) => a -> Eff r a) ->
      (forall a. (Data a) => a -> Eff r a)
traverse f = check_done $ \x -> f x >>= check_done traverse_children
 where
 threshold = 1
 check_done go x = get >>= \case
   Updates n | n >= threshold -> return x
   _                          -> go x
 traverse_children = gfoldl traverse_child return
 traverse_child builda x = liftM2 ($) builda (traverse f x)

-- では traverse に違いを付けよう。

-- Nothing とともに再開したならば、古い値を使うということである。
data YieldD v = forall a. Data a => YieldD a (Maybe a -> v)
    deriving Typeable

instance Functor YieldD where
  fmap f (YieldD x k) = YieldD x (f . k)

yieldD :: (Data a, Member (State Updates) r, Member YieldD r) =>
          a -> Eff r a
yieldD x = send (inj . YieldD x) >>= \case
            Nothing -> return x
            Just x  -> modify (\ (Updates n) -> Updates (n+1)) >> return x

-- 切り捨てられた枝を持つデータ構造
data Cut r a = CDone a | Cut (YieldD (Eff r (Cut r a)))

-- スレッドを開始しステータスを報告する
-- runCut :: Eff (YieldD :> r) a -> Eff r (Cut r a)
runCut m = loop (admin m) where
 loop (Val x) = return $ CDone x
 loop (E u)   =
   handle_relay u loop $  \(YieldD x k) -> return . Cut $ YieldD x (loop . k)


-- 違いを付けられた traversal
traverse_diff :: Data a => a -> Eff r (Cut r (a,Updates))
traverse_diff x = runCut (runState (traverse yieldD x) (Updates 0))

-- traverse_diff のテスト：木を走査しすべての枝を表示する
printDyn x = trace . go $ toDyn x
 where
   go x | Just y <- fromDynamic x = show (y::Bool)
   go x | Just y <- fromDynamic x = show (y::Int)
   go x | Just y <- fromDynamic x = show (y::[Int])
   go x = show x

traverse_all :: (Member Trace r, Data a) => a -> Eff r a
traverse_all x = loop =<< traverse_diff x
 where
   loop (CDone (x,_))      = return x
   loop (Cut (YieldD x k)) = printDyn x >> k Nothing >>= loop

tt1 = runTrace $ traverse_all (Just True)
{-
<<Maybe Bool>>
True
Just True
-}

tt2 = runTrace $ traverse_all [1::Int,2,3]
{-
[1,2,3]
1
[2,3]
2
[3]
3
[]
[1,2,3]
-}

zip_up :: Cut r a -> Eff r a
zip_up (CDone x)           = return x
zip_up (Cut (YieldD x k))  = zip_up =<< k (Just x)

-- データ構造の中のランダムな枝へと歩く
random_walk :: (Member Choose r, Data a) => a -> Eff r (Cut r (a,Updates))
random_walk a = traverse_diff a >>= check
  where
    check y@CDone{}            = return y
    check y@(Cut (YieldD x k)) = return y `mplus'` (k Nothing >>= check)

-- 交差：木 x と木 y の枝へとランダムに歩き、型に互換性があったらそれらの枝を交換する。
-- 交換したら、更新された木を返す。
-- 私たちは1回の交換のみを許す。
crossover :: (Member Choose r, Data a, Data b) => a -> b -> Eff r (a,b)
crossover x y = do
  tx <- random_walk x
  ty <- random_walk y
  -- Cut はデータ構造全体が切られて、残っているのが頂点の穴である場合も含んでいる、
  -- ということを思い出そう。
  case (tx,ty) of
    (Cut (YieldD x kx), Cut (YieldD y ky))
      | Just x' <- cast x, Just y' <- cast y -> do
      (xnew,_) <- zip_up =<< kx (Just y')
      (ynew,_) <- zip_up =<< ky (Just x')
      return (xnew,ynew)
    _ -> mzero'



-- テストのデータ構造
tdata1 = [1::Int, 2, 3]
tdata2 = [10::Int, 20]
tdata3 = [[100::Int], [200, 300]]

-- 交差の結果を見るために以下を評価する

testc0 = run . makeChoice $ crossover (Just True) (Just False)
-- [(Just False,Just True),(Just False,Just True)]

testc01 = run . makeChoice $ crossover tdata1 (Just (10::Int))
-- [([10,2,3],Just 1),([1,10,3],Just 2),([1,2,10],Just 3)]

testc1 = run . makeChoice $ crossover tdata1 tdata2
{-
[([10,20],[1,2,3]),
 ([20],[10,1,2,3]),
 ([],[10,20,1,2,3]),
 ([10,2,3],[1,20]),
 ([20,2,3],[10,1]),
 ([1,10,20],[2,3]),
 ([1,20],[10,2,3]),
 ([1],[10,20,2,3]),
 ([1,10,3],[2,20]),
 ([1,20,3],[10,2]),
 ([1,2,10,20],[3]),
 ([1,2,20],[10,3]),
 ([1,2],[10,20,3]),
 ([1,2,10],[3,20]),
 ([1,2,20],[10,3]),
 ([1,2,3,10,20],[]),
 ([1,2,3,20],[10]),
 ([1,2,3],[10,20])]
-}

testc2 = run . makeChoice $ crossover [tdata1] tdata3

data Tree = Leaf Int | Node Tree Tree
                       deriving (Show, Data, Typeable)

tree1 = Node (Leaf 1) (Leaf 2)
tree2 = Node (Leaf 10) (Node (Leaf 20) (Leaf 30))

testc3 = run . makeChoice $ crossover tree1 tree2

付録G. Benchmarks.hs

いくつかのマイクロベンチマーク。

{-# LANGUAGE FlexibleContexts #-}

-- 拡張可能作用の Eff フレームワークのベンチマーク
--
-- ghc -O2 --make Benchmarks.hs
-- or
-- ghc -O2 -rtsopts -main-is Benchmarks.mainCnt_State Benchmarks.hs
-- このコードを実行するには
-- GHCRTS="-tstderr" ./Benchmarks

module Benchmarks where

import Eff as E
import OpenUnion1 (Member)
import Control.Monad

-- 比較のために、
-- 私たちは正格な State モナドを使う。
-- レイジーなモナドには巨大なスペースリークがあるからである。
-- （あるテストではなんとスタックがオーバーフローしてしまう）
import Control.Monad.State.Strict as S
import Control.Monad.Error  as Er
import Control.Monad.Reader as Rd

-- ------------------------------------------------------------------------
-- 作用のない、ごくわずかな計算のある、単独の State。
-- これはマイクロベンチマークであるので、特に現実的ではない。
-- 単純化するために、GHC はたくさんインライン化するかもしれない。
-- 以下の、状態にアクセスする以外の計算をかなりの分量している、
-- より現実的な大きいベンチマークも参照せよ。

-- カウントダウン
benchCnt_State :: Int -> ((),Int)
benchCnt_State n = S.runState m n
 where
 m = do
     x <- S.get
     if x > 0 then S.put (x-1) >> m else return ()


mainCnt_State = print $ benchCnt_State 10000000
-- バイトコードのベンチマーク：
-- ((),0)
-- (10.41 secs, 4322528400 bytes)
{-
-- コンパイルされたベンチマーク：
((),0)
<<ghc: 160051336 bytes, 306 GCs,
       28400/28400 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.01 MUT (0.02 elapsed),
       0.00 GC (0.00 elapsed) :ghc>>
((),0)
-}

benchCnt_Eff :: Int -> ((),Int)
benchCnt_Eff n = run $ E.runState m n
 where
 m = do
     x <- E.get
     if x > 0 then E.put (x-1::Int) >> m else return ()

mainCnt_Eff = print $ benchCnt_Eff 10000000
-- バイトコードのベンチマーク
-- ((),0)
-- (18.58 secs, 16560000576 bytes)
{-
-- コンパイルされたベンチマーク
((),0)
<<ghc: 2080052304 bytes, 4112 GCs,
       28488/28488 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.75 MUT (0.77 elapsed),
       0.02 GC (0.02 elapsed) :ghc>>
-}


-- ------------------------------------------------------------------------
-- 単独のエラー
-- 数のリストを掛け合わせ、0 に出くわしたら例外を投げる。
-- これはまたしてもマイクロベンチマークである。

-- n 個の 1 の後に 0 が来るリストを作る
be_make_list :: Int -> [Int]
be_make_list n = replicate n 1 ++ [0]

mainMul_pure = print . product $ be_make_list 1000000
-- 0
-- (0.36 secs, 201559304 bytes)
{-
0
<<ghc: 48050696 bytes, 92 GCs,
       28400/28400 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.01 MUT (0.01 elapsed),
       0.00 GC (0.00 elapsed) :ghc>>
0
-}

instance Error Int where

benchMul_Error :: Int -> Int
benchMul_Error n = either id id m
 where
 m = foldM f 1 (be_make_list n)
 f acc 0 = Er.throwError 0
 f acc x = return $! acc * x

mainMul_Error = print $ benchMul_Error 1000000
-- 0
-- (1.39 secs, 584028840 bytes)
{-
0
<<ghc: 160050776 bytes, 307 GCs,
       28432/28432 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.03 MUT (0.03 elapsed),
       0.00 GC (0.00 elapsed) :ghc>>
0
-}

benchMul_Eff :: Int -> Int
benchMul_Eff n = either id id . run . runError $ m
 where
 m = foldM f 1 (be_make_list n)
 f acc 0 = E.throwError (0::Int)
 f acc x = return $! acc * x

mainMul_Eff = print $ benchMul_Eff 1000000
-- 0
-- (1.09 secs, 519988392 bytes)
{-
0
<<ghc: 248052688 bytes, 474 GCs,
       28432/28432 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.07 MUT (0.06 elapsed),
       0.00 GC (0.00 elapsed) :ghc>>
-}


-- ------------------------------------------------------------------------
-- 作用の層を付け足した効果を調べる。
-- 私たちは基本的な State の計算から始めて、
-- ダミーの Reader 作用の層を付け足す。

-- より多くの層を付け足しうる、単独の State の計算。
-- 私たちは正格な State モナドを使い正格性注釈を付けなければならない。
-- そうしなければ、バイトコードは二倍遅く動き、
-- コンパイルされたコードはスタックをオーバーフローさせる。
benchS_MTL :: (MonadState Integer m) => Integer -> m Integer
benchS_MTL n = foldM f 1 [n, n-1 .. 0]
 where
 f acc x | x `mod` 5 == 0 = do
                            s <- S.get
                            S.put $! (s+1)
                            return $! max acc x
 f acc x = return $! max acc x
mainS_MTL = print $ S.runState (benchS_MTL 10000000) 0
-- バイトコード
-- (10000000,2000001)
-- (32.02 secs, 11649331752 bytes)
{-
コンパイルされたコード
(10000000,2000001)
<<ghc: 3008052064 bytes, 5757 GCs,
       28576/28576 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 1.17 MUT (1.18 elapsed),
       0.03 GC (0.03 elapsed) :ghc>>
-}


mainRS_MTL = print $
  flip Rd.runReader (0::Int) $
    S.runStateT (benchS_MTL 10000000) 0
-- (10000000,2000001)
-- (33.45 secs, 13665229776 bytes)
{-
(10000000,2000001)
<<ghc: 3728052136 bytes, 7134 GCs,
       28568/28568 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 1.28 MUT (1.30 elapsed),
       0.03 GC (0.03 elapsed) :ghc>>
-}

mainRRS_MTL = print $
  flip Rd.runReader (0::Int) $
  flip Rd.runReaderT (0::Integer) $
    S.runStateT (benchS_MTL 10000000) 0
-- (10000000,2000001)
-- (35.42 secs, 15681462456 bytes)
{-
(10000000,2000001)
<<ghc: 4768052240 bytes, 9140 GCs,
       28472/28472 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 1.52 MUT (1.55 elapsed),
       0.04 GC (0.04 elapsed) :ghc>>
-}

mainRRRS_MTL = print $
  flip Rd.runReader (0::Int) $
  flip Rd.runReaderT (0::Integer) $
  flip Rd.runReaderT True $
    S.runStateT (benchS_MTL 10000000) 0
-- (10000000,2000001)
-- (36.49 secs, 17695985712 bytes)
{-
(10000000,2000001)
<<ghc: 5968052360 bytes, 11459 GCs,
       28600/28600 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 1.76 MUT (1.79 elapsed),
       0.05 GC (0.05 elapsed) :ghc>>
-}

mainRRRRS_MTL = print $
  flip Rd.runReader (0::Int) $
  flip Rd.runReaderT (0::Integer) $
  flip Rd.runReaderT True $
  flip Rd.runReaderT "0" $
    S.runStateT (benchS_MTL 10000000) 0
-- (10000000,2000001)
-- (37.32 secs, 19711882088 bytes)
{-
(10000000,2000001)
<<ghc: 7328052496 bytes, 14063 GCs,
       28632/28632 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.07 MUT (2.17 elapsed),
       0.06 GC (0.07 elapsed) :ghc>>
-}



-- 今度は Reader の層を State の下に付け足している
mainSR_MTL = print $
    flip S.runState 0 $
     flip Rd.runReaderT (0::Int) $
      (benchS_MTL 10000000)
-- (10000000,2000001)
-- (33.70 secs, 13617816624 bytes)
{-
(10000000,2000001)
<<ghc: 3808052144 bytes, 7292 GCs,
       28568/28568 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 1.28 MUT (1.32 elapsed),
       0.03 GC (0.03 elapsed) :ghc>>
-}

mainSRR_MTL = print $
    flip S.runState 0 $
     flip Rd.runReaderT (0::Int) $
     flip Rd.runReaderT (0::Integer) $
      (benchS_MTL 10000000)
-- (10000000,2000001)
-- (35.36 secs, 15538349728 bytes)
{-
(10000000,2000001)
<<ghc: 4928052256 bytes, 9448 GCs,
       28472/28472 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 1.55 MUT (1.58 elapsed),
       0.04 GC (0.04 elapsed) :ghc>>
-}

mainSRRR_MTL = print $
    flip S.runState 0 $
     flip Rd.runReaderT (0::Int) $
     flip Rd.runReaderT (0::Integer) $
     flip Rd.runReaderT True $
      (benchS_MTL 10000000)
-- (10000000,2000001)
-- (36.01 secs, 17456368112 bytes)
{-
(10000000,2000001)
<<ghc: 6208052384 bytes, 11905 GCs,
       28552/28552 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 1.80 MUT (1.83 elapsed),
       0.05 GC (0.05 elapsed) :ghc>>
-}

mainSRRRR_MTL = print $
    flip S.runState 0 $
     flip Rd.runReaderT (0::Int) $
     flip Rd.runReaderT (0::Integer) $
     flip Rd.runReaderT True $
     flip Rd.runReaderT "0" $
      (benchS_MTL 10000000)
-- (10000000,2000001)
-- (37.25 secs, 19376003040 bytes)
{-
(10000000,2000001)
<<ghc: 7648052528 bytes, 14669 GCs,
       28720/28720 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.19 MUT (2.23 elapsed),
       0.07 GC (0.07 elapsed) :ghc>>
-}

-- 結論：新しい Reader の層を付け足すと、バイトコードの実行時間は1秒増え、
-- コンパイルされたｋ－どの実行時間も同じだけ着実に増加する。
-- Reader の層を State の上に付け足しても下に付け足しても、
-- 効果は観察される。


-- Eff モナドのために書き換えられた benchS_MTL
benchS_Eff :: (Member (E.State Integer) r) =>
                Integer -> Eff r Integer
benchS_Eff n = foldM f 1 [n, n-1 .. 0]
 where
 f acc x | x `mod` 5 == 0 = do
                            s <- E.get
                            E.put $! (s+1::Integer)
                            return $! max acc x
 f acc x = return $! max acc x

mainS_Eff = print $
 run $ E.runState (benchS_Eff 10000000) (0::Integer)
-- (10000000,2000001)
-- (34.38 secs, 15042586288 bytes)
{-
(10000000,2000001)
<<ghc: 5632055448 bytes, 10001 GCs,
       29040/29040 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.62 MUT (2.67 elapsed),
       0.06 GC (0.06 elapsed) :ghc>>
-}

mainRS_Eff = print $ run $
  flip E.runReader (0::Int) $
   E.runState (benchS_Eff 10000000) (0::Integer)
-- (10000000,2000001)
-- (34.07 secs, 15043052808 bytes)
{-
(10000000,2000001)
<<ghc: 5632055512 bytes, 10001 GCs,
       29072/29072 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.60 MUT (2.64 elapsed),
       0.06 GC (0.06 elapsed) :ghc>>
-}

mainRRS_Eff = print $ run $
  flip E.runReader (0::Int) $
  flip E.runReader (0::Integer) $
   E.runState (benchS_Eff 10000000) (0::Integer)
-- (10000000,2000001)
-- (34.27 secs, 15039869104 bytes)
{-
(10000000,2000001)
<<ghc: 5632055616 bytes, 10001 GCs,
       29112/29112 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.59 MUT (2.66 elapsed),
       0.06 GC (0.06 elapsed) :ghc>>
-}

mainRRRS_Eff = print $ run $
  flip E.runReader (0::Int) $
  flip E.runReader (0::Integer) $
  flip E.runReader True $
   E.runState (benchS_Eff 10000000) (0::Integer)
-- (10000000,2000001)
-- (33.93 secs, 15039870120 bytes)
{-
(10000000,2000001)
<<ghc: 5632055720 bytes, 10001 GCs,
       29152/29152 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.56 MUT (2.60 elapsed),
       0.06 GC (0.06 elapsed) :ghc>>
(10000000,2000001)
-}

mainRRRRS_Eff = print $ run $
  flip E.runReader (0::Int) $
  flip E.runReader (0::Integer) $
  flip E.runReader True $
  flip E.runReader "0" $
   E.runState (benchS_Eff 10000000) (0::Integer)
-- (10000000,2000001)
-- (33.89 secs, 15039869848 bytes)
{-
(10000000,2000001)
<<ghc: 5632055824 bytes, 10001 GCs,
       29192/29192 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.65 MUT (2.68 elapsed),
       0.06 GC (0.06 elapsed) :ghc>>
-}

mainSR_Eff = print $ run $
  flip E.runState (0::Integer) $
  flip E.runReader (0::Int) $
   benchS_Eff 10000000
-- (10000000,2000001)
-- (34.99 secs, 16003326472 bytes)
{-
(10000000,2000001)
<<ghc: 6592056888 bytes, 11905 GCs,
       29128/29128 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 2.94 MUT (3.02 elapsed),
       0.07 GC (0.07 elapsed) :ghc>>
-}

mainSRR_Eff = print $ run $
  flip E.runState (0::Integer) $
  flip E.runReader (0::Int) $
  flip E.runReader (0::Integer) $
   benchS_Eff 10000000
-- (10000000,2000001)
-- (35.81 secs, 16959985920 bytes)
{-
(10000000,2000001)
<<ghc: 7552058416 bytes, 13699 GCs,
       29176/29176 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 3.50 MUT (3.56 elapsed),
       0.08 GC (0.08 elapsed) :ghc>>
-}

mainSRRR_Eff = print $ run $
  flip E.runState (0::Integer) $
  flip E.runReader (0::Int) $
  flip E.runReader (0::Integer) $
  flip E.runReader True $
   benchS_Eff 10000000
-- (10000000,2000001)
-- (35.60 secs, 17920031600 bytes)
{-
(10000000,2000001)
<<ghc: 8512059944 bytes, 15626 GCs,
       29224/29224 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 3.67 MUT (3.70 elapsed),
       0.09 GC (0.09 elapsed) :ghc>>
-}

mainSRRRR_Eff = print $ run $
  flip E.runState (0::Integer) $
  flip E.runReader (0::Int) $
  flip E.runReader (0::Integer) $
  flip E.runReader True $
  flip E.runReader "0" $
   benchS_Eff 10000000
-- (10000000,2000001)
-- (36.18 secs, 18880009784 bytes)
{-
(10000000,2000001)
<<ghc: 9472095120 bytes, 17392 GCs,
       61128/61128 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 3.93 MUT (3.99 elapsed),
       0.10 GC (0.11 elapsed) :ghc>>
-}

-- 結論：Reader 作用を付け足すと、ハンドラの順序によっては時間に影響する。
-- 一方の順番では、ハンドラが増えてもパフォーマンスには影響がない。
-- 実行時間も割り当てられたメモリも一定である。
-- State ハンドラが最後である場合、私たちは例外をリレーする効果を見て取れる。
-- その効果は MTL（特にバイトコードで）よりも弱い。


-- ------------------------------------------------------------------------
-- State と Error と作用のない計算

benchMax_MTL :: (MonadState Int m, MonadError Int m) => Int -> m Int
benchMax_MTL n = foldM f 1 [n, n-1 .. 0]
 where
 f acc 0 = Er.throwError 0
 f acc x | x `mod` 5 == 0 = do
                            s <- S.get
                            S.put $! (s+1)
                            return $! max acc x
 f acc x = return $! max acc x

mainMax_MTL = print $ S.runState (Er.runErrorT (benchMax_MTL 1000000)) 0
-- バイトコード
-- (Left 0,200000)
-- (3.84 secs, 1419124008 bytes)
{-
(Left 0,200000)
<<ghc: 296052344 bytes, 569 GCs,
       28456/28456 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.08 MUT (0.08 elapsed),
       0.00 GC (0.00 elapsed) :ghc>>
-}

-- Different order of layers
mainMax1_MTL = print $
   (S.runStateT (benchMax_MTL 1000000) 0 :: Either Int (Int,Int))
-- Left 0
-- (3.72 secs, 1389335288 bytes)
{-
Left 0
<<ghc: 278451768 bytes, 533 GCs,
       28552/28552 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.07 MUT (0.07 elapsed),
       0.00 GC (0.00 elapsed) :ghc>>
-}


benchMax_Eff :: (Member (Exc Int) r, Member (E.State Int) r) =>
                Int -> Eff r Int
benchMax_Eff n = foldM f 1 [n, n-1 .. 0]
 where
 f acc 0 = E.throwError (0::Int)
 f acc x | x `mod` 5 == 0 = do
                            s <- E.get
                            E.put $! (s+1::Int)
                            return $! max acc x
 f acc x = return $! max acc x


mainMax_Eff = print $
 ((run $ E.runState (E.runError (benchMax_Eff 1000000)) 0) ::
     (Either Int Int,Int))
-- バイトコード
-- (Left 0,200000)
-- (3.87 secs, 1696071064 bytes)
{-
(Left 0,200000)
<<ghc: 625654800 bytes, 1124 GCs,
       29120/29120 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.26 MUT (0.26 elapsed),
       0.01 GC (0.01 elapsed) :ghc>>

with OpenUnion3.hs, lazy state
(Left 0,200000)
<<ghc: 663260008 bytes, 1183 GCs,
       10498030/37323448 avg/max bytes residency (7 samples), 88M in use,
       0.00 INIT (0.00 elapsed), 0.28 MUT (0.28 elapsed),
       0.20 GC (0.22 elapsed) :ghc>>

-}

mainMax1_Eff = print $
 ((run $ E.runError (E.runState (benchMax_Eff 1000000) 0)) ::
     Either Int (Int,Int))
-- バイトコード
-- Left 0
-- (3.80 secs, 1600051128 bytes)
{-
Left 0
<<ghc: 539254344 bytes, 957 GCs,
       29064/29064 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.22 MUT (0.23 elapsed),
       0.00 GC (0.01 elapsed) :ghc>>
-}

-- エラーの層が無い
-- (1000000,200001)
-- (3.37 secs, 1520278144 bytes)
{-
(1000000,200001)
<<ghc: 310453944 bytes, 596 GCs,
       28840/28840 avg/max bytes residency (1 samples), 1M in use,
       0.00 INIT (0.00 elapsed), 0.08 MUT (0.08 elapsed),
       0.00 GC (0.00 elapsed) :ghc>>
-}

付録H. transf.hs

モナド変換子の表現性の限界についての2つの例。論文の §5 の完全なコード。

{-# LANGUAGE FlexibleContexts #-}

-- MonadError のインスタンスの定義のためだけに必要
-- {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
-- {-# LANGUAGE UndecidableInstances #-}

-- 論文で扱われている、さまざまな変換子の例

module TranEx where

import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.List
import Control.Monad.Cont
import Control.Monad.Identity

-- ========================================================================
-- 例1：ErrorT と非決定論

-- この例は Reader モナドに対する mtl-2.1.2 の例にかなり似ている
-- （具体的な IO の代わりに抽象的な m が使われている）
newtype TooBig = TooBig Int deriving Show
ex1 :: Monad m => m Int -> ErrorT TooBig m Int
ex1 m = do
  v <- lift m
  if v > 5 then throwError (TooBig v)
     else return v

instance Error TooBig

-- 問題

ex1st = runState (runErrorT (ex1 (put 10 >> return 7))) 0
-- (Left (TooBig 7),10)

choose :: MonadPlus m => [a] -> m a
choose = msum . map return

ex1_1 = runIdentity . runListT . runErrorT  $ ex1 (choose [5,7,1])
-- [Right 5,Left (TooBig 7),Right 1]

-- 探索を終わらせたかったらどうすればいいだろう？

-- 一見より柔軟なアプローチ
ex2 :: MonadError TooBig m => m Int -> m Int
ex2 m = do
  v <- m
  if v > 5 then throwError (TooBig v)
     else return v

-- いま私たちは例外を得る
ex2_1 = runIdentity . runErrorT . runListT $ ex2 (choose [5,7,1])
-- Left (TooBig 7)

-- 異なる順序のモナド
ex2_2 = runIdentity . runListT . runErrorT $ ex2 (choose [5,7,1])
-- [Right 5]
-- この結果はどちらかというと予測されていなかったものである

exRec :: MonadError TooBig m => m Int -> m Int
exRec m = catchError m handler
 where handler (TooBig n) | n <= 7 = return n
       handler e = throwError e

ex2r_10 = runIdentity . runErrorT . runListT $
            exRec (ex2 (choose [5,7,1,11]))
-- Right [7]

ex2r_1 = runIdentity . runErrorT . runListT $
            exRec (ex2 (choose [5,7,1]))
-- Right [7]

-- ex2r1 で、選択肢を持ち上げたもの
ex2r_15 = runIdentity . runErrorT . runListT $
            exRec (ex2 (return 5))
-- Right [5]
ex2r_17 = runIdentity . runErrorT . runListT $
            exRec (ex2 (return 7))
-- Right [7]
ex2r_11 = runIdentity . runErrorT . runListT $
            exRec (ex2 (return 1))
-- Right [1]

ex2r_2 = runIdentity . runListT . runErrorT $
            exRec (ex2 (choose [5,7,1,11]))
-- [Right 5]


-- 推論された型
ex3 :: (Monad (t m), MonadTrans t, MonadError TooBig m) =>
     t m Int -> t m Int
ex3 m = do
  v <- m
  if v > 5 then lift $ throwError (TooBig v)
     else return v

ex3_1 = runIdentity . runErrorT . runListT $
         ex3 (choose [5,7,1])
-- Left (TooBig 7)


ex3_2 = runIdentity . runErrorT . runListT $
         exRec (ex3 (choose [5,7,1]))
-- Right [7]

-- 一般性をすべて捨てる
ex3_rec1 :: ListT (ErrorT TooBig Identity) Int ->
             ListT (ErrorT TooBig Identity) Int
ex3_rec1 m = ListT $ catchError (runListT m) handler
 where handler (TooBig n) | n <= 7 = return [n]
       handler e = throwError e

ex3_rec11 = runIdentity . runErrorT . runListT $
             ex3_rec1 (ex3 (choose [5,7,1]))
-- Right [7]

-- 例外の層を2つ使う
runErrorRelay :: MonadError e m => ErrorT e m a -> m a
runErrorRelay m = runErrorT m >>= check
 where check (Right x) = return x
       check (Left e)  = throwError e

ex4_1 = runIdentity . runErrorT . runListT . runErrorRelay $
        ex1 (choose [5,7,1])
-- Left (TooBig 7)

ex4_21 = runIdentity . runErrorT . runListT . runErrorRelay $
         exRec (ex1 (choose [5,7,1]))
-- Right [5,7,1]

ex4_22 = runIdentity . runErrorT . runListT . runErrorRelay $
         exRec (ex1 (choose [5,7,11,1]))
-- Left (TooBig 11)

-- 非決定論への別の道
-- 今度は正規のモナド変換子を使っている。
choose' :: Monad m => [a] -> ContT [a] m a
choose' lst = shift (\k -> liftM concat $ mapM k lst)

shift :: ((a -> m r) -> m r) -> ContT r m a
shift = ContT

runNDet :: Monad m => ContT [a] m a -> m [a]
runNDet m = runContT m (return . (:[]))

ex5_0 = runIdentity . runNDet $ (choose' [5,7,11,1])
-- [5,7,11,1]

{- 型検査が通らない……
ex5_01 = runIdentity . runNDet . runErrorT $
         (ex1 (choose' [5,7,11,1]))

    Couldn't match expected type `Int'
                with actual type `Either TooBig Int'
    Expected type: ContT [Either TooBig Int] Identity Int
      Actual type: ContT
                     [Either TooBig Int] Identity (Either TooBig Int)
    In the return type of a call of choose'
    In the first argument of `ex1', namely `(choose' [5, 7, 11, 1])'
-}

{-
-- 以下の関数は、下の MonadError インスタンスを定義した場合に限り型検査が通る。
ex5_1 = runIdentity . runErrorT . runNDet . runErrorRelay $
        (ex1 (choose' [5,7,11,1]))
-- Left (TooBig 7)

instance MonadError e m => MonadError e (ContT r m) where
    throwError e = ContT $ \k -> throwError e
    catchError m handler = ContT $ \k ->
                           catchError (runContT m k)
                                      (\e -> runContT (handler e) k)

-- catchError を書く方法は他にないが、これには欠陥がある

ce1 = runIdentity . runErrorT . (\m -> runContT m return) $
      throwError "err"
-- Left "err"

-- 表示された結果は、catchErrorの「後で」発生した例外を
-- ハンドラが渡したということを示している。
ce2 :: IO (Either String ())
ce2 = runErrorT . (\m -> runContT m return) $
      catchError (return ()) handler  >> throwError "err"
 where
 handler e = liftIO . putStrLn $ "Handler: " ++ e
{-
Handler: err
Left "err"
-}
-}

-- 対象の層を明示しなければならない。
-- m 自体が Cont モナドを持っていたらどうしようか？
-- その場合は MonadError の持ち上げは上手く働かない……
runErrorRelay' :: (Monad (t m), MonadTrans t, MonadError e m) =>
     ErrorT e (t m) b -> t m b
runErrorRelay' m = runErrorT m >>= check
 where check (Right x) = return x
       check (Left e)  = lift . throwError $ e

ex5_11 = runIdentity . runErrorT . runNDet . runErrorRelay' $
        (ex1 (choose' [5,7,11,1]))
-- Left (TooBig 7)

ex5_12 = runIdentity . runErrorT . runNDet . runErrorRelay' $
        (exRec (ex1 (choose' [5,7,1])))
-- Right [5,7,1]

ex5_13 = runIdentity . runErrorT . runNDet . runErrorRelay' $
        (exRec (ex1 (choose' [5,7,11,1])))
-- Left (TooBig 11)


ex5_14 :: IO (Either TooBig [Int])
ex5_14 = runErrorT . runNDet . runErrorRelay' $
        (exRec (lift (choose' [1,2]) >> ex1 (choose' [5,7,11]) >>= trace))
 where trace x = (liftIO . print) x >> return x

-- ========================================================================
-- 例2：単純なコルーチン（スレッド）

-- スレッドのステータス：
-- 終了するか、型 a の値を報告する
-- （単純さのために、コルーチンは値を報告するがユニットしか受け取らない）
data Y m a = Done | Y a (() -> m (Y m a))

type CoT a m = ContT (Y m a) m

-- 値を譲り、保留する
yield :: Monad m => a -> CoT a m ()
yield x = shift (\k -> return $ Y x k)

-- スレッドを開始し、ステータスを報告する
runC :: Monad m => CoT a m b -> m (Y m a)
runC m = runContT m (\_ -> return Done)

-- 1番目の例
th1 :: Monad m => CoT Int m ()
th1 = yield 1 >> yield 2

c1 = loop =<< runC th1
 where loop (Y x k) = print x >> k () >>= loop
       loop Done    = print "Done"

{-
1
2
"Done"
-}

-- 動的変数を付け足す
th2 :: MonadReader Int m => CoT Int m ()
th2 = ask >>= yield >> (ask >>= yield)

c2 :: IO ()
c2 = runReaderT (loop =<< runC th2) 10
 where loop (Y x k) = liftIO (print x) >> k () >>= loop
       loop Done    = liftIO (print "Done")
{-
10
10
"Done"
-}

c21 :: IO ()
c21 = runReaderT (loop =<< runC th2) 10
 where loop (Y x k) = liftIO (print x) >> local (+1) (k ()) >>= loop
       loop Done    = liftIO (print "Done")

{-
10
11
"Done"
-}

-- CoT の下に Reader がある、実際の例
th3 :: MonadReader Int m => CoT Int m ()
th3 = ay >> ay >> local (+10) (ay >> ay)
 where ay = ask >>= yield

-- th3 のローカルな環境で失敗する
c3 :: IO ()
c3 = runReaderT (loop =<< runC th3) 10
 where loop (Y x k) = liftIO (print x) >> (k ()) >>= loop
       loop Done    = liftIO (print "Done")
{-
10
10
20
10
"Done"
-}

-- 内部のローカルな環境と外部のローカルな環境の両方が作用を持っているが、
-- th3 のローカルな環境は yield を越えて残らない。
-- 結果全体は奇妙である。
c31 :: IO ()
c31 = runReaderT (loop =<< runC th3) 10
 where loop (Y x k) = liftIO (print x) >> local (+1) (k ()) >>= loop
       loop Done    = liftIO (print "Done")
{-
10
11
21
11
"Done"
-}

-- CoT の上に Reader がある
th4 :: Monad m => ReaderT Int (CoT Int m) ()
th4 = ay >> ay >> local (+10) (ay >> ay)
 where ay = ask >>= lift . yield

-- th4 のローカルな環境はスレッドローカルなように振る舞う
c4 :: IO ()
c4 = loop =<< runC (runReaderT th4 10)
 where loop (Y x k) = liftIO (print x) >> (k ()) >>= loop
       loop Done    = liftIO (print "Done")

{-
10
10
20
20
"Done"
-}

{- しかしスレッドをパラメトライズすることは出来ない。型は間違っている。
c41 :: IO ()
c41 = loop =<< runC (runReaderT th4 10)
 where loop (Y x k) = liftIO (print x) >> local (+1) (k ()) >>= loop
       loop Done    = liftIO (print "Done")
-}

exst :: Monad m => (Int -> m Int) -> ListT m Int
exst m = do
  i <- return 5 `mplus` return 7
  lift $ m i

-- 状態が保存される。望まない結果かもしれない。
exst1 = runState (runListT (exst (\x -> modify (+x) >> get))) 0
-- ([5,12],12)

exst2 = runState (runListT (put 0 >> exst (\x -> modify (+x) >> get))) 0
-- ([5,12],12)

exl :: (MonadPlus m) => (Int -> m Int) -> m Int
exl m = do
  i <- return 5 `mplus` return 7
  m i

exl1 = runState (runListT (exl (\x -> modify (+x) >> get))) 0
-- ([5,12],12)

exl2 = runIdentity $ runListT (runStateT (exl (\x -> modify (+x) >> get)) 0)
-- [(5,5),(7,7)]

-- トレース／ログを追加する

拡張可能作用 ― モナド変換子に取って代わるもの付録 - shiatsumat/fp-papers GitHub Wiki

拡張可能作用 ― モナド変換子に取って代わるもの付録

目次

付録A. Eff.hs

付録B. OpenUnion1.hs

付録C. OpenUnion2.hs

付録D. OpenUnion3.hs

付録E. ExtMTL.hs

付録F. Crossover.hs

付録G. Benchmarks.hs

付録H. transf.hs

⚠️ GitHub.com Fallback ⚠️

拡張可能作用 ― モナド変換子に取って代わるもの 付録 - shiatsumat/fp-papers GitHub Wiki

拡張可能作用 ― モナド変換子に取って代わるもの 付録

目次

⚠️ **GitHub.com Fallback** ⚠️

拡張可能作用 ― モナド変換子に取って代わるもの付録 - shiatsumat/fp-papers GitHub Wiki

拡張可能作用 ― モナド変換子に取って代わるもの付録

⚠️ GitHub.com Fallback ⚠️