将语义应用于免费Monads

Question

我试图抽象将某个语义应用于某个仿函数的自由monad的模式.我用来激发这一点的运行示例是将更新应用于游戏中的实体.因此,为了本示例的目的,我导入了一些库并定义了一些示例类型和实体类(我在control-monad-free中使用了免费的monad实现):

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TypeFamilies #-}

import Control.Monad.Free
import Control.Monad.Identity
import Control.Monad.Writer

-- Things which can happen to an entity
data Order = Order deriving Show
data Damage = Damage deriving Show

class Entity a where
    evolve :: Double -> a -> a
    order :: Order -> a -> a
    damage :: Damage -> a -> a

-- Make a trivial entity for testing purposes
data Example = Example deriving Show
instance Entity Example where
    evolve _ a = a
    order _ a = a
    damage _ a = a

-- A type to hold all the possible update types
data EntityUpdate = 
      UpdateTime Double
    | UpdateOrder Order
    | UpdateDamage Damage
    deriving (Show)

-- Wrap UpdateMessage to create a Functor for constructing the free monad
data UpdateFunctor cont = 
    UpdateFunctor {updateMessage :: EntityUpdate, continue :: cont} deriving (Show, Functor)

-- Type synonym for the free monad
type Update = Free UpdateEntity

我现在将一些基本更新提升到monad中:

liftF = wrap . fmap Pure

updateTime :: Double -> Update ()
updateTime t = liftUpdate $ UpdateTime t

updateOrder :: Order -> Update ()
updateOrder o = liftUpdate $ UpdateOrder o

updateDamage :: Damage -> Update ()
updateDamage d = liftUpdate $ UpdateDamage d

test :: Update ()
test = do
    updateTime 8.0
    updateOrder Order
    updateDamage Damage
    updateTime 4.0
    updateDamage Damage
    updateTime 6.0
    updateOrder Order
    updateTime 8.0

现在我们有了免费的monad,我们需要提供monad实例的不同实现或语义解释的可能性,test如上所述.我能想到的最佳模式由以下函数给出:

interpret :: (Monad m, Functor f, fm ~ Free f c) => (f fm -> fm) -> (f fm -> a -> m a) -> fm -> a -> m a
interpret _ _ (Pure _  ) entity = return entity
interpret c f (Impure u) entity = f u entity >>= interpret c f (c u)

然后,通过一些基本的语义功能,我们可以给出以下两种可能的解释,一种作为基本评估,另一种作为编写器monad预先形成日志:

update (UpdateTime t) = evolve t
update (UpdateOrder o) = order o
update (UpdateDamage d) = damage d

eval :: Entity a => Update () -> a -> a
eval updates entity = runIdentity $ interpret continue update' updates entity where
    update' u entity = return $ update (updateMessage u) entity

logMessage (UpdateTime t) = "Simulating time for " ++ show t ++ " seconds.\n"
logMessage (UpdateOrder o) = "Giving an order.\n"
logMessage (UpdateDamage d) = "Applying damage.\n"

evalLog :: Entity a => Update () -> a -> Writer String a
evalLog = interpret continue $ \u entity -> do
    let m = updateMessage u
    tell $ logMessage m
    return $ update m entity

在GHCI中进行测试:

> eval test Example
Example
> putStr . execWriter $ evalLog test Example
Simulating time for 8.0 seconds.
Giving an order.
Applying damage.
Simulating time for 4.0 seconds.
Applying damage.
Simulating time for 6.0 seconds.
Giving an order.
Simulating time for 8.0 seconds.

这一切都很好,但它让我有点不安的感觉,它可能更一般,或者可以更好地组织.必须提供一个提供延续的功能一开始并不明显,我不确定它是最好的方法.我已经做了一些努力来重新定义interpretControl.Monad.Free模块中的函数,例如foldFree和induce.但他们似乎都不太合适.

我是否与此相符,或者是一个误判？我发现的大多数关于免费monad的文章都集中在它们的效率或实现它们的不同方式上,而不是像这样实际使用它们的模式.

似乎也希望将它封装在某种类中Semantic,因此我可以通过将functor包装在newtype中并使其成为此类的实例,从而使我的自由monad中的不同monad实例.然而,我无法理解如何做到这一点.

更新 -

我希望我能接受这两个答案,因为它们都是非常翔实和精心编写的.最后,对接受的答案的编辑包含我之后的功能:

interpret :: (Functor m, Monad m) => (forall x. f x -> m x) -> Free f a -> m a
interpret evalF = retract . hoistFree evalF

(retract并且hoistFree在Edward Kemmet的Control.Monad.Free免费软件包中).

所有这三个pipes,operational和 sacundim的自由运行包是非常相关的,看起来像他们将是我在未来是非常有用的.谢谢你们.

Answer 1

您可以使用我的pipes库,它提供更高级别的抽象,以便使用免费的monad.

pipes 使用免费monad来统一计算的每个部分:

• 该Producer数据(即你的更新)是一个免费的单子
• 该Consumer数据(即你的解释)是一个免费的单子
• 该Pipe数据(即你的记录器)是一个免费的单子

事实上,他们不是三个独立的自由单子:他们都是伪装的自由单子.一旦定义了所有这三个,就可以使用管道组合连接它们(>->),以便启动流数据.

我将从您的示例略微修改的版本开始,跳过您编写的类型类:

{-# LANGUAGE RankNTypes #-}

import Control.Lens
import Control.Proxy
import Control.Proxy.Trans.State
import Control.Monad.Trans.Writer

data Order  = Order deriving (Show)
data Damage = Damage deriving (Show)

data EntityUpdate
    = UpdateTime   Double
    | UpdateOrder  Order
    | UpdateDamage Damage
    deriving (Show)

现在我们要做的就是定义一个Update是一个Producer的EntityUpdateS:

type Update r = forall m p . (Monad m, Proxy p) => Producer p EntityUpdate m r

然后我们定义实际的命令.每个命令使用respond管道基元产生相应的更新,管道基元将数据进一步向下游发送以进行处理.

updateTime :: Double -> Update ()
updateTime t = respond (UpdateTime t)

updateOrder :: Order -> Update ()
updateOrder o = respond (UpdateOrder o)

updateDamage :: Damage -> Update ()
updateDamage d = respond (UpdateDamage d)

由于a Producer是一个免费的monad,我们可以使用do符号来组装它,就像你为你的test函数做的那样:

test :: () -> Update ()
-- i.e. () -> Producer p EntityUpdate m ()
test () = runIdentityP $ do
    updateTime 8.0
    updateOrder Order
    updateDamage Damage
    updateTime 4.0
    updateDamage Damage
    updateTime 6.0
    updateOrder Order
    updateTime 8.0

但是,我们也可以将解释器作为Consumer数据来实现.这很好,因为我们可以直接在解释器上对状态进行分层,而不是使用Entity您定义的类.

我将使用一个简单的状态:

data MyState = MyState { _numOrders :: Int, _time :: Double, _health :: Int }
    deriving (Show)

begin :: MyState
begin= MyState 0 0 100

...为了清晰起见,定义一些方便的镜头:

numOrders :: Lens' MyState Int
numOrders = lens _numOrders (\s x -> s { _numOrders = x})

time :: Lens' MyState Double
time = lens _time (\s x -> s { _time = x })

health :: Lens' MyState Int
health = lens _health (\s x -> s { _health = x })

...现在我可以定义一个有状态的解释器:

eval :: (Proxy p) => () -> Consumer (StateP MyState p) EntityUpdate IO r
eval () = forever $ do
    entityUpdate <- request ()
    case entityUpdate of
        UpdateTime   tDiff -> modify (time      +~ tDiff)
        UpdateOrder  _     -> modify (numOrders +~ 1    )
        UpdateDamage _     -> modify (health    -~ 1    )
    s <- get
    lift $ putStrLn $ "Current state is: " ++ show s

这使得解释器正在做的事情变得更加清晰.我们可以一目了然地看到它如何以有状态的方式处理传入的值.

要连接我们Producer,Consumer我们使用(>->)组合运算符,然后runProxy将我们的管道转换回基础monad:

main1 = runProxy $ evalStateK begin $ test >-> eval

...产生以下结果:

>>> main1
Current state is: MyState {_numOrders = 0, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 98}
Current state is: MyState {_numOrders = 1, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 26.0, _health = 98}

您可能想知道为什么我们必须分两步完成此操作.为什么不摆脱这runProxy部分？

原因是我们可能希望撰写两件以上的东西.例如,我们可以很容易的插入之间的记录阶段test和eval.我将这些中间阶段称为Pipe:

logger
    :: (Monad m, Proxy p)
    => () -> Pipe p EntityUpdate EntityUpdate (WriterT String m) r
logger () = runIdentityP $ forever $ do
    entityUpdate <- request ()
    lift $ tell $ case entityUpdate of
        UpdateTime   t -> "Simulating time for " ++ show t ++ " seconds.\n"
        UpdateOrder  o -> "Giving an order.\n"
        UpdateDamage d -> "Applying damage.\n"
    respond entityUpdate

同样,我们可以非常清楚地看到logger它的作用:它request是一个值,是值的tell表示,然后使用传递值进一步下游respond.

我们可以在test和之间插入logger.我们必须注意的唯一事情是所有阶段必须具有相同的基础monad,因此我们使用raiseK插入一个WriterT层,eval以便它匹配基础monad logger:

main2 = execWriterT $ runProxy $ evalStateK begin $
    test >-> logger >-> raiseK eval

...产生以下结果:

>>> main2
Current state is: MyState {_numOrders = 0, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 100}
Current state is: MyState {_numOrders = 1, _time = 8.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 99}
Current state is: MyState {_numOrders = 1, _time = 12.0, _health = 98}
Current state is: MyState {_numOrders = 1, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 18.0, _health = 98}
Current state is: MyState {_numOrders = 2, _time = 26.0, _health = 98}
"Simulating time for 8.0 seconds.\nGiving an order.\nApplying damage.\nSimulating time for 4.0 seconds.\nApplying damage.\nSimulating time for 6.0 seconds.\nGiving an order.\nSimulating time for 8.0 seconds.\n"

pipes旨在解决您描述的问题.很多时候我们不仅想要生成数据的DSL,还要解释口译员和中间处理阶段. pipes以相同的方式处理所有这些概念,并将它们全部建模为可连接的流DSL.这样就可以轻松地交换各种行为,而无需定义自己的自定义解释器框架.

如果您是管道新手,那么您可能需要查看教程.

Answer 2

我不太明白你的例子，但我认为你基本上是operational在这里重建包。您的EntityUpdate类型非常像 意义上的指令集operational，而您的类型类似于指令集\xe2\x80\x94 上的自由函子，这正是与自由单子UpdateFunctor相关的构造。operational（参见“操作真的与自由单子同构吗？”和这个 Reddit 讨论）。

\n\n

但无论如何，这个operational包有你想要的功能，interpretWithMonad：

\n\n

interpretWithMonad :: forall instr m b.\n                      Monad m => \n                      (forall a. instr a -> m a) \n                   -> Program instr b\n                   -> m b\n

\n\n

这允许您提供一个函数，将程序中的每个指令（每个EntityUpdate值）解释为一个单子操作，并处理其余的事情。

\n\n

如果允许我进行一点自我推销的话，我最近刚刚编写了自己的operational使用 free monads的版本，因为我想要一个\类型Applicative的版本。由于您的示例给我留下了纯粹的应用性印象，因此我根据我的图书馆进行了编写您的示例的练习，我不妨将其粘贴到此处。（我无法理解你的功能。）这里是：operationalProgramevalLogeval

\n\n

{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes #-}\n\nimport Control.Applicative\nimport Control.Applicative.Operational\nimport Control.Monad.Writer\n\ndata Order = Order deriving Show\ndata Damage = Damage deriving Show\n\n-- UpdateI is short for "UpdateInstruction"\ndata UpdateI a where\n    UpdateTime   :: Double -> UpdateI ()\n    UpdateOrder  :: Order -> UpdateI ()\n    UpdateDamage :: Damage -> UpdateI ()\n\ntype Update = ProgramA UpdateI\n\nupdateTime :: Double -> Update ()\nupdateTime = singleton . UpdateTime\n\nupdateOrder :: Order -> Update ()\nupdateOrder = singleton . UpdateOrder\n\nupdateDamage :: Damage -> Update ()\nupdateDamage = singleton . UpdateDamage\n\ntest :: Update ()\ntest = updateTime 8.0 \n    *> updateOrder Order\n    *> updateDamage Damage\n    *> updateTime 4.0\n    *> updateDamage Damage\n    *> updateTime 6.0\n    *> updateOrder Order\n    *> updateTime 8.0\n\nevalLog :: forall a. Update a -> Writer String a\nevalLog = interpretA evalI\n    where evalI :: forall x. UpdateI x -> Writer String x\n          evalI (UpdateTime t) = \n              tell $ "Simulating time for " ++ show t ++ " seconds.\\n"\n          evalI (UpdateOrder Order) = tell $ "Giving an order.\\n"\n          evalI (UpdateDamage Damage) = tell $ "Applying damage.\\n"\n

\n\n

输出：

\n\n

*Main> putStr $ execWriter (evalLog test)\nSimulating time for 8.0 seconds.\nGiving an order.\nApplying damage.\nSimulating time for 4.0 seconds.\nApplying damage.\nSimulating time for 6.0 seconds.\nGiving an order.\nSimulating time for 8.0 seconds.\n

\n\n

interpretWithMonad这里的技巧与原始包中的函数相同，但适应了应用程序：

\n\n

interpretA :: forall instr f a. Applicative f =>\n              (forall x. instr x -> f x)\n           -> ProgramA instr a -> f a\n

\n\n

如果您确实需要一种单子解释，那么只需导入Control.Monad.Operational（原始的或我的）而不是Control.Applicative.Operational，并使用Program而不是ProgramA。 ProgramA但是，您可以更强大地静态检查程序：

\n\n

-- Sum the total time requested by updateTime instructions in an\n-- applicative UpdateI program.  You can\'t do this with monads.\nsumTime :: ProgramA UpdateI () -> Double\nsumTime = sumTime\' . viewA \n    where sumTime\' :: forall x. ProgramViewA UpdateI x -> Double\n          sumTime\' (UpdateTime t :<**> k) = t + sumTime\' k\n          sumTime\' (_ :<**> k) = sumTime\' k\n          sumTime\' (Pure _) = 0\n

\n\n

的用法示例sumTime：

\n\n

*Main> sumTime test\n26.0\n

\n\n\n\n

编辑：回想起来，我应该提供这个更短的答案。这假设您正在使用Control.Monad.FreeEdward Kmett 的软件包：

\n\n

interpret :: (Functor m, Monad m) =>\n             (forall x. f x -> m x) \n          -> Free f a -> m a\ninterpret evalF = retract . hoistFree evalF\n

\n