Haskell 是否存在渐进优化MonadPlus操作序列的Codensity MonadPlus？

最近有一个关于

DList

[]

与

Codensity

免费

之间关系的讨论

这让我想到了

MonadPlus

是否有这样的东西。

Codensity

monad只改善了一元运算的渐近性能，而不是

mplu

此外，虽然过去有

Control.MonadPlus.Free

，但它一直支持

FreeT f[]

。由于没有显式的免费MonadPlus，我不确定如何表达相应的变体。也许像

improvePlus :: Functor f => (forall m. (MonadFree f m, MonadPlus m) => m a) -> FreeT f [] a

?

---

更新：我试图使用回溯单子创建这样一个单子，它的定义方式类似于

Codensity

：

并且适用于回溯计算，即，

MonadPlus

然后我定义了

lowerLogic

，类似于如下所示：

{-# LANGUAGE RankNTypes, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses,
             UndecidableInstances, DeriveFunctor #-}
import Control.Monad
import Control.Monad.Trans.Free
import Control.Monad.Logic

lowerLogic :: (MonadPlus m) => LogicT m a -> m a
lowerLogic k = runLogicT k (\x k -> mplus (return x) k) mzero

然后，在补充相应的

MonadFree

实例之后

instance (Functor f, MonadFree f m) => MonadFree f (LogicT m) where
    wrap t = LogicT (\h z -> wrap (fmap (\p -> runLogicT p h z) t))

可以定义

improvePlus :: (Functor f, MonadPlus mr)
            => (forall m. (MonadFree f m, MonadPlus m) => m a)
            -> FreeT f mr a
improvePlus k = lowerLogic k

---

然而，它有点不对劲，因为从我最初的实验中可以看出，对于一些例子来说，

k

与

improvePlus k

是不同的。我不确定这是否是

LogicT

的一个基本限制，是否需要一个不同的、更复杂的monad，或者仅仅是我错误地定义了

lowerLogic

（或其他东西）。

下面的内容都是基于我对这一点的（错误）理解 Matthew Pickering在他的 评论：。所有结果都是他们的；所有的错误都是我的

从自由幺半群到

DList

建立直觉，首先考虑自由幺半群<代码> []/COD> Haskell类型的类别

Hask

。

[]

的一个问题是 你有

然后计算需要遍历和重新遍历的

mappend

的每个左嵌套应用程序

解决方案是以以下形式使用CPS：

这篇论文考虑了这一问题的一般形式（称为Cayley） 表示）在我们不受自由幺半群约束的情况下：

newtype Cayley m = Cayley{ unCayley :: Endo m }

转换

toCayley :: (Monoid m) => m -> Cayley m
toCayley m = Cayley $ Endo $ \m' -> m `mappend` m'

fromCayley :: (Monoid m) => Cayley m -> m
fromCayley (Cayley k) = appEndo k mempty

推广的两个方向 我们可以用两种方式概括上述结构：首先，通过 考虑幺半群不是在

Hask

上，而是在

Hask

的内函子上； 单子；第二，通过将代数结构丰富到 近半环

Free

monads to

Codensity

对于任何Haskell（endo）函子

f

，我们都可以构造

自由f

，并且 它将有类似于左嵌套绑定的性能问题， 使用Cayley表示的类似解决方案

近半环而不仅仅是幺半群 这就是论文不再回顾众所周知的概念的地方 由正在工作的Haskell程序员创建，并开始着手实现其目标。A. 近半环类似于环，只是更简单，因为加法和 乘法只需要是幺半群。两者之间的联系 这两个操作是您所期望的：

zero |*| a = zero
(a |+| b) |*| c = (a |*| c) |+| (b |*| c)

其中，

（零，|+|）

和

（一，|*|）

是某些平面上的两个幺半群 共享基础：

class NearSemiring a where
    zero :: a
    (|+|) :: a -> a -> a
    one :: a
    (|*|) :: a -> a -> a

自由近半环（在Hask上）结果如下

林

类型：

newtype Forest a = Forest [Tree a]
data Tree a = Leaf | Node a (Forest a)

instance NearSemiring (Forest a) where
    zero = Forest []
    one = Forest [Leaf]
    (Forest xs) |+| (Forest ys) = Forest (xs ++ ys)
    (Forest xs) |*| (Forest ys) = Forest (concatMap g xs)
      where
        g Leaf = ys
        g (Node a n) = [Node a (n |*| (Forest ys))]

（幸好我们没有交换性或逆性， …）

然后，本文两次应用Cayley表示，对两个 单倍体结构

然而，如果我们天真地这样做，我们就会这样做 没有得到一个好的表示：我们想要表示一个近半环， 因此必须考虑整个近半环结构 帐户，而不仅仅是一个选定的幺半群结构。[…]我们获得 自同态上自同态的半环

（我将这里的实现从文件稍微更改为 强调我们正在使用

Endo

结构两次）。我们什么时候出发 一般来说，这两个层将不相同。那报纸呢 接着说：

注意，

rep

不是从

N

到

DC（N）

由于它不保留单元[…]但是，[…] 近半环上的计算语义将被保留，如果 我们将值提升到表示，进行近半环计算 在那里，然后回到原始的近半环

MonadPlus

几乎是一个近半环 然后，论文继续重新格式化

MonadPlus

typeclass 它对应于近半环规则：

（mzero，mplus）

是幺半环：

m `mplus` mzero = m
mzero `mplus` m = m
m1 `mplus` (m2 `mplus` m3) = (m1 `mplus` m2) `mplus` m3

它与单子幺半群按预期相互作用：

join mzero = mzero
join (m1 `mplus` m2) = join m1 `mplus` join m2

或者，使用绑定：

mzero >>= _ = mzero
(m1 `mplus` m2) >>= k = (m1 >>= k) `mplus` (m2 >>= k)

但是，这些都是而不是规则， 其中包括：

mzero >>= _  =  mzero
_ >> mzero   =  mzero

本文调用满足以下条件的

MonadPlus

实例： 近半环类定律“不确定性单子”，以及 引用

可能

作为一个例子，它是一个

MonadPlus

，但不是一个 非确定性单变量，因为设置

m1=Just Nothing

和

m2=Just Nothing
（仅为False）

是join（m1`mplus`m2）=join m1的反例 `mplus`join m2

不确定性单子的自由和Cayley表示 把所有的东西放在一起，一方面我们有了森林 自由不确定性单子：

newtype FreeP f x = FreeP { unFreeP :: [FFreeP f x] }
data FFreeP f x = PureP x | ConP (f (FreeP f x))

instance (Functor f) => Functor (FreeP f) where
    fmap f x = x >>= return . f

instance (Functor f) => Monad (FreeP f) where
    return x = FreeP $ return $ PureP x
    (FreeP xs) >>= f = FreeP (xs >>= g)
      where
        g (PureP x) = unFreeP (f x)
        g (ConP x) = return $ ConP (fmap (>>= f) x)

instance (Functor f) => MonadPlus (FreeP f) where
    mzero = FreeP mzero
    FreeP xs `mplus` FreeP ys = FreeP (xs `mplus` ys)

另一方面，两个单倍体的双Cayley表示 图层：

本文给出了一个在计算机中运行的计算示例 对于

FreeP

，不确定的单子将表现不佳：

anyOf :: (MonadPlus m) => [a] -> m a
anyOf [] = mzero
anyOf (x:xs) = anyOf xs `mplus` return x

的确，虽然

length $ unFreeP (anyOf [1..100000] :: FreeP Identity Int)

需要时间，Cayley转化的版本

length $ unFreeP (runDCM $ anyOf [1..100000] :: FreeP Identity Int)

立即返回。

这与您的问题非常相关。“本文为MonadPlus类型类的操作提供了一种新的代数理解，使我们能够推导出这两种类型

newtype FreeP f x = FreeP { unFreeP :: [FFreeP f x] }
data FFreeP f x = PureP x | ConP (f (FreeP f x))

instance (Functor f) => Functor (FreeP f) where
    fmap f x = x >>= return . f

instance (Functor f) => Monad (FreeP f) where
    return x = FreeP $ return $ PureP x
    (FreeP xs) >>= f = FreeP (xs >>= g)
      where
        g (PureP x) = unFreeP (f x)
        g (ConP x) = return $ ConP (fmap (>>= f) x)

instance (Functor f) => MonadPlus (FreeP f) where
    mzero = FreeP mzero
    FreeP xs `mplus` FreeP ys = FreeP (xs `mplus` ys)

newtype (:^=>) f g x = Ran{ unRan :: forall y. (x -> f y) -> g y }
newtype (:*=>) f g x = Exp{ unExp :: forall y. (x -> y) -> (f y -> g y) }

instance Functor (g :^=> h) where
    fmap f m = Ran $ \k -> unRan m (k . f)

instance Functor (f :*=> g) where
    fmap f m = Exp $ \k -> unExp m (k . f)

newtype DCM f x = DCM {unDCM :: ((f :*=> f) :^=> (f :*=> f)) x}

instance Monad (DCM f) where
    return x = DCM $ Ran ($x)
    DCM (Ran m) >>= f = DCM $ Ran $ \g -> m $ \a -> unRan (unDCM (f a)) g

instance MonadPlus (DCM f) where
    mzero = DCM $ Ran $ \k -> Exp (const id)
    mplus m n = DCM $ Ran $ \sk -> Exp $ \f fk -> unExp (a sk) f (unExp (b sk) f fk)
      where
        DCM (Ran a) = m
        DCM (Ran b) = n

caylize :: (Monad m) => m a -> DCM m a
caylize x = DCM $ Ran $ \g -> Exp $ \h m -> x >>= \a -> unExp (g a) h m

-- I wish I called it DMC earlier...
runDCM :: (MonadPlus m) => DCM m a -> m a
runDCM m = unExp (f $ \x -> Exp $ \h m -> return (h x) `mplus` m) id mzero
  where
    DCM (Ran f) = m

anyOf :: (MonadPlus m) => [a] -> m a
anyOf [] = mzero
anyOf (x:xs) = anyOf xs `mplus` return x

length $ unFreeP (anyOf [1..100000] :: FreeP Identity Int)

length $ unFreeP (runDCM $ anyOf [1..100000] :: FreeP Identity Int)