将语义应用于免费Monad
我试图通过一些函子抽象出将某种语义应用于自由monad的模式。 我用来激励这个的运行示例是将更新应用于游戏中的实体。 所以我导入了一些库，并为本例的目的定义了一些示例类型和一个实体类（我使用免费monad实现在无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.
这一切都可以正常工作，但是这让我感到有些不安，觉得它可能更一般，或者可以组织得更好。 不得不提供延续的功能起初并不明显，我不确定这是最好的方法。 我做了一些努力，重新interpret中的Control.Monad.Free模块中的功能，如条款foldFree和induce 。 但他们似乎都没有工作。
我是否正确地对待这个问题，或者做出错误判断？ 我发现大多数关于免费monads的文章都集中在它们的效率或不同的实现方式上，而不是像这样实际使用它们的模式。
将它封装在某种Semantic类中似乎也是可取的，所以我可以简单地通过将函数包装成新类型并将其作为此类的一个实例，从我的自由单体中创建不同的monad实例。 然而，我无法完全解决如何做到这一点。
更新 -
我希望我可以接受这两个答案，因为它们都是非常丰富和仔细写作。 最后，对接受的答案的编辑包含我之后的功能：
interpret :: (Functor m, Monad m) => (forall x. f x -> m x) -> Free f a -> m a
interpret evalF = retract . hoistFree evalF
（ retract和hoistFree在Control.Monad.Free中的Edward Kemmet的免费软件包中）。
所有三种pipes ， operational和sacundim的免费运营包都非常相关，看起来对未来我将非常有用。 谢谢你们。
我不太了解你的例子，但我认为你基本上是在这里重新构建operational包。 你EntityUpdate类型是很像的意义上的指令集operational ，你的UpdateFunctor是一样的东西放在指令的自由函子集，而这恰恰是关系到建设operational和免费单子。 （请参阅“是否真的与一个免费的monad同构？”以及这个Reddit讨论）。
但无论如何，这个operational包有你想要的功能， interpretWithMonad ：
interpretWithMonad :: forall instr m b.
Monad m =>
(forall a. instr a -> m a)
-> Program instr b
-> m b
这使您可以提供一种功能，将程序中的每条指令（每个EntityUpdate值）解释为EntityUpdate操作，并负责处理其余部分。
如果我可以被允许的自我提升一点点，我只是最近写我自己的版本的operational使用免费的单子，因为我想有一个Applicative的版本operational的Program类型。 既然你的例子让我觉得自己是纯粹的应用，那么我就按照自己的库来完成evalLog的编写工作，不妨将它粘贴到这里。 （我无法理解你的eval函数。）这里有：
{-# LANGUAGE GADTs, ScopedTypeVariables, RankNTypes #-}
import Control.Applicative
import Control.Applicative.Operational
import Control.Monad.Writer
data Order = Order deriving Show
data Damage = Damage deriving Show
-- UpdateI is short for "UpdateInstruction"
data UpdateI a where
UpdateTime :: Double -> UpdateI ()
UpdateOrder :: Order -> UpdateI ()
UpdateDamage :: Damage -> UpdateI ()
type Update = ProgramA UpdateI
updateTime :: Double -> Update ()
updateTime = singleton . UpdateTime
updateOrder :: Order -> Update ()
updateOrder = singleton . UpdateOrder
updateDamage :: Damage -> Update ()
updateDamage = singleton . UpdateDamage
test :: Update ()
test = updateTime 8.0
*> updateOrder Order
*> updateDamage Damage
*> updateTime 4.0
*> updateDamage Damage
*> updateTime 6.0
*> updateOrder Order
*> updateTime 8.0
evalLog :: forall a. Update a -> Writer String a
evalLog = interpretA evalI
where evalI :: forall x. UpdateI x -> Writer String x
evalI (UpdateTime t) =
tell $ "Simulating time for " ++ show t ++ " seconds.n"
evalI (UpdateOrder Order) = tell $ "Giving an order.n"
evalI (UpdateDamage Damage) = tell $ "Applying damage.n"
输出：
*Main> putStr $ execWriter (evalLog test)
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.
这里的诀窍与原始包中的interpretWithMonad函数相同，但适用于应用程序：
interpretA :: forall instr f a. Applicative f =>
(forall x. instr x -> f x)
-> ProgramA instr a -> f a
如果你真的需要一个monadic解释，它只是导入Control.Monad.Operational （原始的或我的）而不是Control.Applicative.Operational ，并使用Program而不是ProgramA 。 然而， ProgramA给你更大的权力来静态检查程序：
-- Sum the total time requested by updateTime instructions in an
-- applicative UpdateI program. You can't do this with monads.
sumTime :: ProgramA UpdateI () -> Double
sumTime = sumTime' . viewA
where sumTime' :: forall x. ProgramViewA UpdateI x -> Double
sumTime' (UpdateTime t :<**> k) = t + sumTime' k
sumTime' (_ :<**> k) = sumTime' k
sumTime' (Pure _) = 0
sumTime使用sumTime ：
*Main> sumTime test
26.0
编辑：回想起来，我应该提供这个较短的答案。 这假设你使用的是Edward Kmett的包中的Control.Monad.Free ：
interpret :: (Functor m, Monad m) =>
(forall x. f x -> m x)
-> Free f a -> m a
interpret evalF = retract . hoistFree evalF
你可以使用我的pipes库，它提供更高层次的抽象来处理免费单子。
pipes使用空闲单子来确定计算的每个部分：
Producer （即你的更新）是一个免费的monad Consumer （即你的翻译）是一个免费的单子 Pipe （即你的记录器）是一个免费的monad 事实上，他们不是三个独立的自由单体：他们都是变相的自由单体。 一旦定义了它们全部三个，就可以使用管道组合(>->)连接它们，以便开始流式数据。
我将从你的示例的略微修改版本开始，它跳过你写的类型类：
{-# 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定义为EntityUpdate的Producer ：
type Update r = forall m p . (Monad m, Proxy p) => Producer p EntityUpdate m r
然后我们定义实际的命令。 每个命令使用respond管道原语产生相应的更新， 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)
由于Producer是一个免费的单子，我们就可以组装它使用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 s：
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 sa值的表示，然后使用respond将值传递到下游。
我们可以在test和logger之间插入它。 我们唯一必须注意的是，所有阶段都必须具有相同的基本monad，因此我们使用raiseK为eval插入一个WriterT图层，以便它匹配logger的基本monad：
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将所有这些概念pipes处理，并将它们全部建模为可连接的流DSL。 这使得交换进出各种行为非常容易，而无需定义自己的定制解释器框架。
如果你是管道新手，那么你可能想看看这个教程。
链接地址: http://www.djcxy.com/p/47693.html