モナドはMonad以外にもある

モナドは`Monad`以外にもある

この記事では、「モナド」と「Monad」とを違う意味の言葉として使いわけます。モナド (圏論)のうち、ある特殊な場合がMonadである、とします。

詳しい説明はここではしませんが、次のFMonadは、「モナドだけどMonadじゃない」性質を表す型クラスです。

-- | Natural
type (~>) f g = forall x. f x -> g x

-- | Functor on Functors
class (forall g. Functor g => Functor (ff g)) => FFunctor ff where
    ffmap :: (Functor g, Functor h) => (g ~> h) -> (ff g ~> ff h)

-- | Monad on Functors
class FFunctor ff => FMonad ff where
    fpure :: (Functor g) => g ~> ff g
    fjoin :: (Functor g) => ff (ff g) ~> ff g

FFunctorとFMonadは、 FunctorとMonadによく似ていることがわかります。さらに、FFunctor則とFMonad則もFunctor、Monadのものにそっくりです。これらをまとめて抽象化できるのが、一般的なほうの「モナド」です。

FFunctor laws:
    ffmap id = id
    ffmap f . ffmap g = ffmap (f . g)

FMonad laws:
[fpure is natural in g]
    ∀(n :: g ~> h). ffmap n . fpure = fpure . n

[fjoin is natural in g]
    ∀(n :: g ~> h). ffmap n . fjoin = fjoin . ffmap (ffmap n)

[Left unit]
    fjoin . fpure = id

[Right unit]
    fjoin . fmap fpure = id

[Associativity]
    fjoin . fjoin = fjoin . ffmap fjoin

具体例1:`ReaderT e`

ReaderT eはFFunctorかつFMonadになります。

newtype ReadeT e m a = ReaderT { runReaderT :: e -> m a }

instance Functor m     => Functor (ReaderT e m)
instance Applicative m => Applicative (ReaderT e m)
instance Monad m       => Monad (ReaderT e m)

これが、次のようにFFunctor, FMonadになります。

instance FFunctor (ReaderT e) where
    ffmap :: (Functor f, Functor g) => (f ~> g) -> (ReaderT e f ~> ReaderT e g)
{-  ffmap :: (Functor f, Functor g)
          => (forall x. f x -> g x) -> (forall y. ReaderT e f y -> ReaderT e g y)  -}
    ffmap fg my = ReaderT . fmap fg . runReaderT

instance FMonad (ReaderT e) where
    fpure :: (Functor f) => f ~> ReaderT e f
{-  fpure :: f x -> ReaderT e f x  -}
    fpure = ReaderT . (return :: f x -> (e -> f x))

    fjoin :: (Functor f) => ReaderT e (ReaderT e f) ~> ReaderT e f
    fjoin = ReaderT . (join :: (e -> e -> f x) -> e -> f x) . fmap runReaderT . runReaderT

ReaderT e f x は、newtypeを外せば e -> f x で、これは Monadである(e -> _) と、Monadとは限らない f の合成Functorと見ることができます。 m ~ ((->) e)とおけば、fpureはreturnでf xを包んでm (f x)にして、 fjoinはjoinでm (m (f x))を潰してm (f x)にしているだけです。

一般化すれば、Functorの合成（Data.Functor.Compose）に対して、次のインスタンスが作れます。

instance Functor m => FFunctor (Compose m)
instance Monad m   => FMonad (Compose m)

具体例2:`WriterT w`

WriterT wもFFunctorかつFMonadになります。

newtype WriterT w m a = WriterT { runWriterT :: m (a, w) }

instance Functor m     => Functor (WriterT e m)
instance Applicative m => Applicative (WriterT e m)
instance Monad m       => Monad (WriterT e m)

instance FFunctor (WriterT w) where
    ffmap fg = WriterT . fg . runWriterT

instance (Monoid w) => FMonad (WriterT w) where
    fpure :: (Functor f) => f ~> WriterT w f
    fpure = WriterT . fmap returnWriter
      where
        returnWriter x = (x, mempty)
        -- return x = Writer (x, mempty) :: Writer w x
    
    fjoin :: (Functor f) => WriterT w (WriterT w f) ~> WriterT w f
    fjoin = WriterT . fmap joinWriter . runWriterT . runWriterT
      where
        joinWriter ((x,w2),w1) = (x, w1 <> w2)
        -- join (Writer (Writer (x, w2), w1)) = Writer (x, w1 <> w2)

1つめの例と同じように、これは任意のMonad mに拡張できて、内側にMonad mを合成する(`Compose` m)は、 FMonadになります。

ただし、Haskellは(`Compose` m)のような型を作れないので、それ用の新しい型を定義する必要があります。

newtype FlipCompose m f a = FlipCompose { getFlipCompose :: f (m a) }

instance (Functor m, Functor f) => Functor (FlipCompose m f)
instance (Functor m) => FFunctor (FlipCompose m)
instance (Monad m)   => FMonad (FlipCompose m)

具体例3:`Sum f`

これまでMonad Transformerばかりでしたが、FMonadがそうしたものに限られるわけではありません。 Sum f（Data.Functor.Sum）はFMonadです。これは、Monad Transformerでないどころか、Monadとは何の関係もありません。

data Sum f g a = InL (f a) | InR (g a)

instance (Functor f, Functor g) => Functor (Sum f g)

そのFMonadのインスタンスは、EitherのMonadインスタンスとほぼ同じです。

instance (Functor f) => FFunctor (Sum f) where
    ffmap :: (Functor g, Functor h) => (g ~> h) -> (Sum f g ~> Sum f h)
    ffmap _  (InL fx) = InL fx
    ffmap gh (InR gx) = InR (gh gx)

instance (Functor f) => FMonad (Sum f) where
    fpure :: (Functor g) => g ~> Sum f g
    fpure = InR
    
    fjoin :: (Functor g) => Sum f (Sum f g) ~> Sum f g
    fjoin (InL fx)       = InL fx
    fjoin (InR (InL fx)) = InL fx
    fjoin (InR (InR gx)) = InR gx

具体例4:`Free f`

Free Monad（Free）はFMonadです。

data Free f a = Pure a | Free (f (Free f a))

instance (Functor f) => Functor (Free f)
instance (Functor f) => Applicative (Free f)
instance (Functor f) => Monad (Free f) where
  return = Pure
  Pure a   >>= k = k a
  Free fma >>= k = Free (fmap (>>= k) fma)

instance FFunctor Free where
    ffmap = hoistFree

instance FMonad Free where
    fpure = liftF
    fjoin = foldFree id

-- これらはControl.Monad.Freeにある関数ですが、
-- 参照しやすさのためにここにコピペします

-- | The very definition of a free monad is that given a natural transformation you get a monad homomorphism.
foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a
foldFree _ (Pure a)  = return a
foldFree f (Free as) = f as >>= foldFree f

hoistFree :: (Functor g) => (f ~> g) -> (Free f ~> Free g)
hoistFree fg = go
  where
    go (Pure x)   = Pure x
    go (Free fmx) = Free (fmap go (fg fmx))

liftF :: (Functor f) => f ~> Free f
liftF fx = Free (fmap Pure fx)

ここまでの例では省略してきましたが、FFunctor則・FMonad則も証明していきたいと思います。その前に、次の有用な事実を確認しておきます: 任意のFunctor f, Monad nおよびt :: f ~> nに対して、

foldFree t . liftF = t
foldFree tはMonad準同型
条件1.と2.を満たすようなMonad準同型はfoldFree tただ一つだけ存在する

ここで、ftがMonad準同型であるとは、次の条件を満たすことをいいます。

ft . return = ft

ft . join = join . fmap ft . ft

あるいは、これと同値な

  ft $ do x <- mx
         k x
=
  do x <- ft mx
     ft (k x)

foldFree t . liftF = t

これは定義を展開していけばすぐです。

foldFree t . liftF
 = foldFree t . Free . fmap Pure
 = (>>= foldFree t) . t . fmap Pure
 = (>>= foldFree t) . fmap Pure . t
 = (>>= foldFree t . Pure) . t
 = (>>= return) . t
 = t

foldFree tはMonad準同型

foldFree t . return
 = foldFree t . Pure
 = return

-- 次式を示したい
foldFree t . join = join . fmap (foldFree t) . foldFree t

lhs mma = foldFree t $ join mma
rhs mma = join . foldFree t . foldFree t $ mma

lhs mma
 = case mma of
     Pure ma   ->
       foldFree t $ join (Pure ma)
        = t ma
     Free fmma ->
       foldFree t $ join (Free fmma)
        = foldFree t $ Free (fmap join fmma)
        = t (fmap join fmma) >>= foldFree t
        = join . fmap (foldFree t) . t (fmap join fmma)
        = join . fmap (foldFree t) . fmap join $ t fmma
        = join . fmap (foldFree t . join) $ t fmma
        = join . fmap lhs $ t fmma
 = case mma of
     Pure ma   -> t ma
     Free fmma -> join . fmap lhs $ t fmma

rhs mma
 = case mma of
     Pure ma ->
       join . fmap (foldFree t) . foldFree t $ Pure ma
        = join . fmap (foldFree t) $ return ma
        = join $ return (t ma)
        = t ma
     Free fmma ->
       join . fmap (foldFree t) . foldFree t $ Free fmma
        = join . fmap (foldFree t) $ t fmma >>= foldFree t
        = join . fmap (foldFree t) . join . fmap (foldFree t) $ t fmma
        = join . join . fmap (fmap (foldFree t)) . fmap (foldFree t) $ t fmma
        = join . fmap join . fmap (fmap (foldFree t)) . fmap foldFree t $ t fmma
        = join . fmap (join . fmap (foldFree t) . foldFree t) $ t fmma
        = join . fmap rhs $ t fmma
 = case mma of
     Pure ma   -> t ma
     Free fmma -> join . fmap rhs $ t fmma

-- よって、再帰的に、lhs = rhsでなければならない

条件1.と2.を満たすようなMonad準同型はただ一つだけ存在する

言い換えれば、任意のMonad準同型ft :: Free f ~> nが ft . liftF = tを満たすなら、必ずft = foldFree t = foldFree (ft . liftF)となります。

これは2段階に分けて証明しましょう。まず、u :: n ~> n'をMonad準同型としたとき、任意のt :: f ~> nについてfoldFree (u . t) = u . foldFree tです。これは「foldFreeの自然性」と呼ぶことにします。

lhs = foldFree (u . t)
rhs = u . foldFree t

lhs (Pure a)
 = return a
rhs (Pure a)
 = u (return a :: n a) :: n' a
 = return a

lhs (Free fma)
 = foldFree (u . t) $ Free fma
 = (u . t) fma >>= foldFree (u . t)
 = u (t fma) >>= lhs
rhs (Free fma)
 = u . foldFree t $ Free fma
 = u $ t fma >>= foldFree t
 = u (t fma) >>= u . foldFree t
 = u (t fma) >>= rhs

また、foldFree liftF = idです。

foldFree liftF $ Pure a
 = return a
 = Pure a

foldFree liftF $ Free fma
 = liftF fma >>= foldFree liftF
 = Free (fmap Pure) fma >>= foldFree liftF
 = Free (fmap (>>= foldFree liftF) . fmap Pure $ fma)
 = Free (fmap ((>>= foldFree liftF) . Pure) $ fma)
 = Free (fmap (>>= return) fma)
 = Free fma

したがって

foldFree (ft . liftF)
   -- ft はMonad準同型 Free f ~> n より、foldFreeの自然性から
 = ft . foldFree liftF
   -- foldFree liftF = id
 = ft

これらの事実を組み合わせれば、FFunctor, FMonad則を導くことができます。

-- 以下は定義から容易に確認できる
fpure   = liftF
fjoin   = retract = foldFree id

-- 次の式は直接証明することもできるが、
ffmap f = foldFree (liftF . f)
-- より簡単に示せる以下の式
ffmap f . liftF
 = ffmap f . Free . fmap Pure
 = Free . f . fmap (ffmap f) . fmap Pure
 = Free . fmap (ffmap f . Pure) . f
 = Free . fmap Pure . f
 = liftF . f
-- およびffmapがMonad準同型であることから、`foldFree`の唯一性より
ffmap f = foldFree (ffmap f . liftF)
        = foldFree (liftF . f)

[FFunctor則]
  ffmap id = foldFree (liftF . id) = id
  ffmap f . ffmap g
   = foldFree (liftF . f) . foldFree (liftF . g)
     -- foldFreeの自然性(foldFree _ 自身もMonad準同型であることに注意)
   = foldFree (foldFree (liftF . f) . liftF . g)
     -- foldFree t . liftF = t
   = foldFree (liftF . f . g)
   = foldFree (liftF . (f . g))
   = ffmap (f . g)

[FMonad則 自然性]
  -- fpure = liftFなので、これはすでに示している
  ffmap f . fpure = fpure . f
  
  ffmap f . fjoin
   = ffmap f . foldFree id
   = foldFree (ffmap f . id)
   = foldFree (ffmap f)
  fjoin . ffmap (ffmap f)
   = foldFree id . foldFree (liftF . ffmap f)
   = foldFree (foldFree id . liftF . ffmap f)
   = foldFree (ffmap f)

[FMonad則Left Unit]
  fjoin . fpure
   = foldFree id . liftF
     -- foldFree t . liftF = t
   = id

[FMonad則Right Unit]
  fjoin . ffmap fpure
   = foldFree id . foldFree (liftF . liftF)
     -- foldFreeの自然性
   = foldFree (foldFree id . liftF . liftF)
     --        ^^^^^^^^^^^^^^^^^^^
   = foldFree (id . liftF)
   = foldFree liftF
   = id

[FMonad則Associativity]
  fjoin . fjoin
   = foldFree id . foldFree id
   = foldFree (foldFree id . id)
   = foldFree (foldFree id)
  fjoin . ffmap fjoin
   = foldFree id . foldFree (liftF . foldFree id)
   = foldFree (foldFree id . liftF . foldFree id)
     --        ^^^^^^^^^^^^^^^^^^^
   = foldFree (id . foldFree id)
   = foldFree (foldFree id)

なんでこの記事を書いたのか？

このFFunctorやFMonadは、じつは私がついこの間書いたものです。Redditでのこの話題に対する反応なので、別に実用上の必要があったわけではありません。一応Hackageも漁りましたけど、category-extrasに存在したことがあるぐらいで、今もメンテナンスされているパッケージには見つかりませんでした。多分他の人も必要なかったのか、自分の検索が足りてないかです。

ただ、割とよく似ているものにindex-coreとmmorphとがあります。それぞれ、

index-core: カインドk -> Typeをもつ任意の型コンストラクタf :: k -> Type上の関手やモナド
- パッケージの元ネタ論文: Kleisli arrows of outrageous fortune(pdf)
- モナドはIMonadという名前
mmorph: Monad上の関手やモナド
- Monad準同型だけを考える
- モナドはMMonadという名前

です。FMonadはFunctor上のモナドなので、上のどちらとも一般/特殊の関係にありません。しかも、例に挙げたように、 FFunctor、FMonadのインスタンスは多様で、かつたびたび使う型が含まれています。ちょっと深堀りしてみる価値があるかな、と思ってやってみました。

次の表はIMonad、MMonad、FMonadの比較です。

	Instance	`IMonad`	`MMonad`	`FMonad`
	`ReaderT e`	✔	✔	✔
`Monoid w =>`	`WriterT w`		✔	✔
`Monad f =>`	`Compose f`	✔		✔
	`Sum f`	✔		✔
	`Free`			✔
`Functor f =>`	`FreeT f`		✔ ^[1]
	`IxState` ^[2]	✔

^[1] mmorphパッケージには無いけれど多分なれます。また、MMonad (FreeT f)とfを固定してmを引数と見るのでなく、mを固定してfを引数と見るなら、FreeT _ mはFMonadです。

^[2] IxState: 下記のもの。sが反変な位置にあるのでFMonadになれません。あと、xとして、GADTを使ったものを入れないと、計算後の状態の型がわからなくなるので、Functorなxだけを使うとかなり不便です。

data SomePair x where
  SomePair :: t -> x t -> SomePair x
data IxState x s where
  IxState :: (s -> SomePair x) -> IxState x s

Functor上のモナド、FMonadについて

モナドはMonad以外にもある

具体例1:ReaderT e

具体例2:WriterT w

具体例3:Sum f

具体例4:Free f