"DList"和"[]`与Codensity之间的关系

Question

我一直在尝试与Codensity最近这应该涉及DList与[]除其他事项外.无论如何,我从来没有找到说明这种关系的代码.经过一些实验,我最终得到了这个:

{-# LANGUAGE RankNTypes #-}
module Codensity where

newtype Codensity f a = Codensity
  { runCodensity :: forall b. (a -> f b) -> f b }

type DList a = Codensity [] [a]

nil :: DList a
nil = Codensity ($ [])

infixr 5 `cons`
cons :: a -> DList a -> DList a
cons x (Codensity xs) = Codensity ($ (xs (x:)))

append :: DList a -> DList a -> DList a
append (Codensity xs) ys = Codensity ($ (xs (++ toList ys)))

toList :: DList a -> [a]
toList xs = runCodensity xs id

fromList :: [a] -> DList a
fromList xs = Codensity (\k -> k xs)

但是,DList在我的例子中,感觉有点狡猾.是否有不同的方式陈述这种关系？这甚至是正确的方法吗？

Answer 1

TL;DR: DList for (++) serves the same purpose as Codensity for (>>=): reassociating the operators to the right.

This is beneficial, because for both, (++) and (>>=), left associated computations (can) exhibit quadratic runtime behaviour.

1. The full story

The plan is as follows:

• We go step by step through an example for (++) and (>>=), emonstrating the problem with associativity.
• We use CPS to avoid quadratic complexity with DList and Codensity
• Aftermath and Bonus (Generalize from (++) to (<>))

2. The problem: quadratic runtime behaviour

2a. List (++)

Keep in mind that while I am using (++) as an example, this is valid for other functions as well, if they work analogous to (++).

So let's first look at the problem with lists. The concat operation for lists is commonly defined as:

(++) []     ys = ys
(++) (x:xs) ys = x : xs ++ ys

which means that (++) will always walk the first argument from start to end. To see when this is a problem consider the following two computations:

as, bs, cs:: [Int]

rightAssoc :: [Int]
rightAssoc = (as ++ (bs ++ cs))

leftAssoc :: [Int]
leftAssoc = ((as ++ bs) ++ cs)

Let's start with rightAssoc and walk through the evaluation.

as = [1,2]
bs = [3,4]
cs = [5,6]
rightAssoc = ([1,2] ++ ([3,4] ++ [5,6]))
           -- pattern match gives (1:[2]) for first arg
           = 1 : ([2] ++ ([3,4] ++ [5,6]))
           -- pattern match gives (2:[]) for first arg
           = 1 : 2 : ([] ++ ([3,4] ++ [5,6]))
           -- first case of (++)
           = 1 : 2 : ([3,4] ++ [5,6])
           = 1 : 2 : 3 : ([4] ++ [5,6])
           = 1 : 2 : 3 : 4 : ([] ++ [5,6])
           = 1 : 2 : 3 : 4 : [5,6]
           = [1,2,3,4,5,6]

So we have to walk over as and bs.

Okay that was not too bad, let's continue to leftAssoc:

as = [1,2]
bs = [3,4]
cs = [5,6]
leftAssoc = (([1,2] ++ [3,4]) ++ [5,6])
          = ((1 : ([2] ++ [3,4])) ++ [5,6])
          = ((1 : 2 : ([] ++ [3,4])) ++ [5,6])
          = ((1 : 2 : [3,4]) ++ [5,6])
          = ([1,2,3,4] ++ [5,6])
          -- uh oh
          = 1 : ([2,3,4] ++ [5,6])
          = 1 : 2 : ([3,4] ++ [5,6])
          = 1 : 2 : 3 : ([4] ++ [5,6])
          = 1 : 2 : 3 : 4 : ([] ++ [5,6])
          = 1 : 2 : 3 : 4 : [5,6]
          = [1,2,3,4,5,6]

哦,你看到我们不得不走过as 两次了吗？一次 [1,2]又一次在里面as ++ bs = [1,2,3,4].与被错误地相关联的每个进一步操作,在列表左边 的(++)是我们必须每次都会在每一步成长不再完全穿越,导致二次运行行为.

因此,正如您在上面看到的左关联(++)将破坏性能.这导致我们:

2B.免费monad(>>=)

请记住,虽然我使用的Free是一个例子,但其他monad也是这种情况,例如Tree像这样的行为的实例

首先,我们使用天真Free类型:

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

而不是(++),我们看看(>>=)哪个定义为并使用 (>>=)前缀形式:

instance Functor f => Monad (Free f) where
  return = Pure
  (>>=) (Pure a) f = f a
  (>>=) (Free m) f = Free ((>>= f) <$> m)

如果你比较这与定义(++),从2a上面可以看到的定义(>>=)再次着眼于第一个 参数.这引起了第一个担忧,这种(++)情况会不会像错误关联时那样糟糕？好吧,让我们看一下,我Identity在这里使用的是 为了简单,但是算子的选择并不是重要的事实:

-- specialized to 'Free'
liftF :: Functor f => f a -> Free f a
liftF fa = Free (Pure <$> fa)

x :: Free Identity Int
x = liftF (Identity 20) = Free (Identity (Pure 20))

f :: Int -> Free Identity Int
f x = liftF (Identity (x+1)) = Free (Identity (Pure (x+1)))

g :: Int -> Free Identity Int
g x = liftF (Identity (x*2)) = Free (Identity (Pure (x*2)))

rightAssoc :: Free Identity Int
rightAssoc = (x >>= \x -> (f x >>= g))

leftAssoc :: Free Identity Int
leftAssoc = ((x >>= f) >>= g)

我们首先从rightAssoc变体开始:

rightAssoc = (x >>= \x -> (f x >>= g))
                    ~~~
           -- definition of x
           = ((Free (Identity (Pure 20))) >>= \x -> (f x >>= g))
              ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           -- second case of definition for 'Free's (>>=)
           = Free ((>>= \x -> (f x >>= g)) <$> Identity (Pure 20))
                   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           -- (<$>) for Identity
           = Free (Identity ((Pure 20) >>= \x -> (f x >>= g)))
                             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           -- first case of the definition for 'Free's (>>=)
           = Free (Identity (f 20 >>= g))
                             ~~~~
           = Free (Identity ((Free (Identity (Pure 21))) >>= g))
                             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           -- second case of definition for 'Free's (>>=)
           = Free (Identity (Free ((>>= g) <$> Identity (Pure 21))))
                                   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           = Free (Identity (Free (Identity ((Pure 21) >>= g))))
                                             ~~~~~~~~~~~~~~~
           = Free (Identity (Free (Identity (g 21))))
                                             ~~~~
           = Free (Identity (Free (Identity (Free (Identity (Pure 42))))))

Puh, okay I added ~~~~ under the expression that is reduced in the next step for clarity. If you squint hard enough, you may see some familiarity from 2a's' case for rightAssoc: we walk the two first arguments (now x and f instead of as and bs) arguments once. Without wasting further time, here is leftAssoc:

leftAssoc = ((x >>= f) >>= g)
             ~~~
          = ((Free (Identity (Pure 20)) >>= f) >>= g)
             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          = (Free ((>>= f) <$> Identity (Pure 20)) >>= g)
                   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          = (Free (Identity ((Pure 20) >>= f)) >>= g)
                             ~~~~~~~~~~~~~~~
          = (Free (Identity (f 20)) >>= g)
                             ~~~~
          = (Free (Identity (Free (Identity (Pure 21)))) >>= g)
            ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          = Free ((>>= g) <$> (Identity (Free (Identity (Pure 21)))))
                  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          -- uh oh
          = Free (Identity (Free (Identity (Pure 21)) >>= g))
                            ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          = Free (Identity (Free ((>>= g) <$> Identity (Pure 21))))
                                  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          = Free (Identity (Free (Identity ((Pure 21) >>= g))))
                                            ~~~~~~~~~~~~~~~~
          = Free (Identity (Free (Identity (g 21))))
                                            ~~~~
          = Free (Identity (Free (Identity (Free (Identity (Pure 42))))))

If you look close, after the uh oh we have to tear down the intermediate structure again, just like in the (++) case (also marked with uh oh).

2c. Result so far

In both cases, leftAssoc leads to quadratic runtime behaviour, because we rebuild the first argument several times and tear it down right again for the next operation. This means that at each step in the evaluation we have to build and tear down a growing intermediate structure --- bad.

3. The relation between DList and Codensity

This is where we will discover the relation between DList and Codensity. Each one solves the problem of wrongly associated computations seen above by using CPS to effectively reassociate to the right.

3a. DList

First we introduce the definition of DList and append:

newtype DList a = DL { unDL :: [a] -> [a] }

append :: DList a -> DList a -> DList a
append xs ys = DL (unDL xs . unDL ys)

fromList :: [a] -> DList a
fromList = DL . (++)

toList :: DList a -> [a]
toList = ($[]) . unDL

and now our old friends:

as,bs,cs :: DList Int
as = fromList [1,2] = DL ([1,2] ++)
bs = fromList [3,4] = DL ([3,4] ++)
cs = fromList [5,6] = DL ([5,6] ++)

rightAssoc :: [Int]
rightAssoc = toList $ as `append` (bs `append` cs)

leftAssoc :: [Int]
leftAssoc = toList $ ((as `append` bs) `append` cs)

Evaluation is roughly as follows:

rightAssoc = toList $ (DL ([1,2] ++)) `append` (bs `append` cs)
           = toList $ DL $ unDL (DL ([1,2] ++)) . unDL (bs `append` cs)
                           ~~~~~~~~~~~~~~~~~~~~
           = toList $ DL $ ([1,2] ++) . unDL (bs `append` cs)
                                              ~~
           = toList $ DL $ ([1,2] ++) . unDL ((DL ([3,4] ++)) `append` cs)
                                              ~~~~~~~~~~~~~~~~~~~~~~~~~~~
           = toList $ DL $ ([1,2] ++) . unDL (DL $ unDL (DL ([3,4] ++)) . unDL cs)
                                                   ~~~~~~~~~~~~~~~~~~~~
           = toList $ DL $ ([1,2] ++) . unDL (DL $ ([3,4] ++) . unDL cs)
                                                                     ~~
           = toList $ DL $ ([1,2] ++) . unDL (DL $ ([3,4] ++) . unDL (DL ([5,6] ++)))
           = toList $ DL $ ([1,2] ++) . unDL (DL $ ([3,4] ++) . ([5,6] ++))
                                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           = toList $ DL $ ([1,2] ++) . (([3,4] ++) . ([5,6] ++))
             ~~~~~~
           -- definition of toList
           = ($[]) . unDL $ DL $ ([1,2] ++) . (([3,4] ++) . ([5,6] ++))
                     ~~~~~~~~~
           -- unDL . DL == id
           = ($[]) $ (([1,2] ++) . (([3,4] ++) . ([5,6] ++)))
           -- move ($[]) to end
           = (([1,2] ++) . (([3,4] ++) . ([5,6] ++))) []
           -- def: (.) g f x = g (f x)
           = (([1,2] ++) ((([3,4] ++) . ([5,6] ++)) []))
           = (([1,2] ++) (([3,4] ++) (([5,6] ++) [])))
           -- drop unnecessary parens
           = (([1,2] ++) (([3,4] ++) ([5,6] ++ [])))
           = ([1,2] ++ ([3,4] ++ ([5,6] ++ [])))
                                  ~~~~~~~~~~~
           -- (xs ++ []) == xs
           = ([1,2] ++ ([3,4] ++ ([5,6])))
           = (as ++ (bs ++ cs))

Hah! The result is exactly the same as rightAssoc from 2a. Allright, with tension building up, we move on to leftAssoc:

leftAssoc = toList $ ((as `append` bs) `append` cs)
          = toList $ (((DL ([1,2]++)) `append` bs) `append` cs)
          = toList $ ((DL (unDL (DL ([1,2]++)) . unDL bs)) `append` cs)
          = toList $ ((DL (unDL (DL ([1,2]++)) . unDL (DL ([3,4]++)))) `append` cs)
          = toList $ ((DL (([1,2]++) . ([3,4]++))) `append` cs)
          = toList $ (DL (unDL (DL (([1,2]++) . ([3,4]++))) . unDL cs))
          = toList $ (DL (unDL (DL (([1,2]++) . ([3,4]++))) . unDL (DL ([5,6]++))))
          = toList $ (DL ((([1,2]++) . ([3,4]++)) . ([5,6]++)))
          = ($[]) . unDL $ (DL ((([1,2]++) . ([3,4]++)) . ([5,6]++)))
          = ($[]) ((([1,2]++) . ([3,4]++)) . ([5,6]++))
          = ((([1,2]++) . ([3,4]++)) . ([5,6]++)) []
          -- expand (f . g) to \x -> f (g x)
          = ((\x -> ([1,2]++) (([3,4]++) x)) . ([5,6]++)) []
          = ((\x -> ([1,2]++) (([3,4]++) x)) (([5,6]++) []))
          -- apply lambda
          = ((([1,2]++) (([3,4]++) (([5,6]++) []))))
          = ([1,2] ++ ([3,4] ++ [5,6]))
          = as',bs',cs' ~ versions of 2a with no prime
          = (as' ++ (bs' ++ cs'))

Heureka! The result is associated correctly (to the right), no quadratic slowdown.

3b. Codensity

Okay if you've come to this point you must be seriously interested, that's good, because so am I :). We start with the definition and Monad instance of Codensity (with abbreviated names):

newtype Codensity m a = C { run :: forall b. (a -> m b) -> m b }

instance Monad (Codensity f) where
  return x = C (\k -> k x)
  m >>= k = C (\c -> run m (\a -> run (k a) c))

-- hidden as a instance for `MonadTrans`
liftCodensity :: Monad m => m a -> Codensity m a
liftCodensity m = C (m >>=)

lowerCodensity :: Monad m => Codensity m a -> m a
lowerCodensity a = run a return

I guess you know what comes next:

x :: Codensity (Free Identity) Int
x = liftCodensity (Free (Identity (Pure 20)))
  = C (Free (Identity (Pure 20)) >>=)
  -- note the similarity to (DL (as ++))
  -- with DL ~ Codensity and (++) ~ (>>=) !

f :: Int -> Codensity (Free Identity) Int
f x = liftCodensity (Free (Identity (Pure (x+1))))
    = C (Free (Identity (Pure (x+1))) >>=)

g :: Int -> Codensity (Free Identity) Int
g x = liftCodensity (Free (Identity (Pure (x*2))))
    = C (Free (Identity (Pure (x*2))) >>=)

rightAssoc :: Free Identity Int
rightAssoc = lowerCodensity (x >>= \x -> (f x >>= g))

leftAssoc :: Free Identity Int
leftAssoc = lowerCodensity ((x >>= f) >>= g)

Before we go through the evaluation once again, you might be interested in the comparison of append from DList and (>>=) from Codensity (unDL ~ run), go ahead and do that if you want, I'll wait for you.

Okay we start with rightAssoc:

rightAssoc = lowerCodensity (x >>= \x -> (f x >>= g))
                            ~~~
           -- def of x
           = lowerCodensity ((C (Free (Identity (Pure 20)) >>=)) >>= \x -> (f x >>= g))
           -- (>>=) of codensity
           = lowerCodensity (C (\c -> run (C (Free (Identity (Pure 20)) >>=)) (\a -> run ((\x -> (f x >>= g)) a) c)))
           -- run . C == id
           = lowerCodensity (C (\c -> Free (Identity (Pure 20)) >>= \a -> run ((\x -> (f x >>= g)) a) c))
           -- substitute x' for 'Free (Identity (Pure 20))' (same as only x from 2b)
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (f x >>= g)) a) c))
                                                                ~~~
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (C (Free (Identity (Pure (x+1))) >>=)) >>= g) a) c))
                                                                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> run (C (Free (Identity (Pure (x+1))) >>=)) (\a2 -> run (g a2) c2)))) a) c))
                                                                           ~~~~~~
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> (Free (Identity (Pure (x+1))) >>=) (\a2 -> run (g a2) c2)))) a) c))
           -- again, substitute f' for '\x -> Free (Identity (Pure (x+1)))' (same as only f from 2b)
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> (f' x >>=) (\a2 -> run (g a2) c2)))) a) c))
                                                                                                   ~~~~
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> (f' x >>=) (\a2 -> run (C (Free (Identity (Pure (a2*2))) >>=)) c2)))) a) c))
                                                                                              ~~~~~~
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> (f' x >>=) (\a2 -> (Free (Identity (Pure (a2*2))) >>=) c2)))) a) c))
           -- one last time, substitute g' (g from 2b)
           = lowerCodensity (C (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> (f' x >>=) (\a2 -> (g' a2 >>=) c2)))) a) c))
           -- def of lowerCodensity
           = run (C (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> (f' x >>=) (\a2 -> (g' a2 >>=) c2)))) a) c)) return
           = (\c -> x' >>= \a -> run ((\x -> (C (\c2 -> (f' x >>=) (\a2 -> (g' a2 >>=) c2)))) a) c) return
           = (x' >>= \a -> run ((\x -> (C (\c2 -> (f' x >>=) (\a2 -> (g' a2 >>=) c2)))) a) return)
                                 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           = (x' >>= \a -> run (C (\c2 -> (f' a >>=) (\a2 -> (g' a2 >>=) c2))) return)
                           ~~~~~~
           = (x' >>= \a -> (\c2 -> (f' a >>=) (\a2 -> (g' a2 >>=) c2)) return)
                            ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
           = (x' >>= \a -> (f' a >>=) (\a2 -> g' a2 >>= return))
           -- m >>= return ~ m
           = (x' >>= \a -> (f' a >>=) (\a2 -> g' a2))
           -- m >>= (\x -> f x) ~ m >>= f
           = (x' >>= \a -> (f' a >>= g'))
           -- rename a to x
           = (x' >>= \x -> (f' x >>= g'))

And we can now see that the (>>=)s are associated to the right, this is not yet particularly astonishing, given that this was also the case at the start. So, full of anticipation, we turn our attention to our last and final evaluation trace, leftAssoc:

leftAssoc = lowerCodensity ((x >>= f) >>= g)
          -- def of x
          = lowerCodensity ((C (Free (Identity (Pure 20)) >>=) >>= f) >>= g)
          -- (>>=) from Codensity
          = lowerCodensity ((C (\c -> run (C (Free (Identity (Pure 20)) >>=)) (\a -> run (f a) c))) >>= g)
                                      ~~~~~~
          = lowerCodensity ((C (\c -> (Free (Identity (Pure 20)) >>=) (\a -> run (f a) c))) >>= g)
          -- subst x'
          = lowerCodensity ((C (\c -> (x' >>=) (\a -> run (f a) c))) >>= g)
          -- def of f
          = lowerCodensity ((C (\c -> (x' >>=) (\a -> run (C (Free (Identity (Pure (a+1))) >>=)) c))) >>= g)
                                                      ~~~~~~
          = lowerCodensity ((C (\c -> (x' >>=) (\a -> (Free (Identity (Pure (a+1))) >>=) c))) >>= g)
          -- subst f'
          = lowerCodensity ((C (\c -> (x' >>=) (\a -> (f' a >>=) c))) >>= g)
                            ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
          = lowerCodensity (C (\c2 -> run (C (\c -> (x' >>=) (\a -> (f' a >>=) c))) (\a2 -> run (g a2) c2)))
                                      ~~~~~~
          = lowerCodensity (C (\c2 -> (\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> run (g a2) c2)))
          -- def of g
          = lowerCodensity (C (\c2 -> (\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> run (C (Free (Identity (Pure (a2*2))) >>=)) c2)))
                                                                                    ~~~~~~
          = lowerCodensity (C (\c2 -> (\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> (Free (Identity (Pure (a2*2))) >>=) c2)))
          -- subst g'
          = lowerCodensity (C (\c2 -> (\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> (g' a2 >>=) c2)))
          -- def lowerCodensity
          = run (C (\c2 -> (\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> (g' a2 >>=) c2))) return
          = (\c2 -> (\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> (g' a2 >>=) c2)) return
          = ((\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> g' a2 >>= return))
          = ((\c -> (x' >>=) (\a -> (f' a >>=) c)) (\a2 -> g' a2))
          = ((\c -> (x' >>=) (\a -> (f' a >>=) c)) g')
          = (x' >>=) (\a -> (f' a >>=) g')
          = (x' >>=) (\a -> (f' a >>= g')
          = (x' >>= (\a -> (f' a >>= g'))
          = (x' >>= (\x -> (f' x >>= g'))

Finally there we have it, all binds associated to the right, just how we like them!

4. Aftermath

If you made it until here, congratulations. Let's summarize what we did:

1. We demonstrated the problem with wrongly associated (++) in 2a and (>>=) in 2b
2. We've shown the solution using DList in 3a and Codensity in 3b.
3. Demonstrated the power of equational reasoning in Haskell :)

5. Bonus

Actuall, we can generalize DList from (++) and use (<>) instead to get DMonoid, reordering (<>).

newtype DMonoid m = DM { unDM :: m -> m }

instance Monoid m => Monoid (DMonoid m) where
  mempty = DM (mempty <>)
  x `mappend` y = DM (unDM x . unDM y)

liftDM :: Monoid m => m -> DMonoid m
liftDM = DM . (<>)

lowerDM :: Monoid m => DMonoid m -> m
lowerDM = ($ mempty) . unDM

Then the comparison goes as follows:

• DMonoid is a (my invention) "monoid transformer", reassociating (<>) to the right
• Codensity is a monad transformer, reassociating (>>=) to the right

Answer 2

一种观点可能是DList重新排序monoid操作的方法,就像Codensity重新排序monad操作一样.

[]是一个免费的幺半群a,所以让我们用自由作家monad表示列表,即Free ((,) a):

module Codensity where

import Control.Monad
import Control.Monad.Free
import Control.Monad.Codensity
import Control.Monad.Trans (lift)

type DList a = Free ((,) a) ()

现在我们可以定义标准列表操作:

nil :: DList a
nil = return ()

singleton :: a -> DList a
singleton x = liftF (x, ())

append :: DList a -> DList a -> DList a
append = (>>)

infixr 5 `snoc`
snoc :: DList a -> a -> DList a
snoc xs x = xs >> singleton x

exec :: Free ((,) a) () -> [a]
exec (Free (x, xs)) = x : exec xs
exec (Pure _) = []

fromList :: [a] -> DList a
fromList = mapM_ singleton

toList :: DList a -> [a]
toList = exec

这种表示与列表中的列表具有相同的缺点snoc.我们可以验证一下

last . toList . foldl snoc nil $ [1..10000]

需要大量(二次)时间.然而,就像每个免费的monad一样,它可以使用改进Codensity.我们只是将定义替换为

type DList a = Codensity (Free ((,) a)) ()

并toList与

toList = exec . lowerCodensity

现在,同样的表达式立即执行,Codensity重新排序操作,就像原始差异列表一样.