在 Free Monad 上缩放实例

Question

我正在尝试构建一个免费的 monad（使用 free），它的作用类似于 StateT monad，但它也允许您在基本状态 AppState 上运行 monad。我有一个单独的构造函数LiftAction 保存这些类型。这个想法是你保持zooming Actions 直到它们到达 AppState，它可以在它的扩展映射中存储不同的状态。

这是我之前使用 mtl 的尝试（失败）：Lift through nested state transformers (mtl)

无论如何，因为它基本上是StateT 的包装器，所以我给了它一个MonadState 实例，但现在我正在努力添加使用lens library 缩放monad 状态的功能；我遇到了一些奇怪的编译器错误，我无法理解（镜头错误通常对用户不太友好）。

这是我的代码和初步尝试：

{-# language GeneralizedNewtypeDeriving #-}
{-# language DeriveFunctor #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language RankNTypes #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
module Eve.Internal.AppF
  ( Action(..)
  , App
  , AppState(..)
  , liftAction
  , execApp
  ) where

import Control.Monad.State
import Control.Monad.Free
import Control.Lens

type App a = Action AppState a
data AppState = AppState
  { baseExts :: Int -- Assume this actually contains many nested states which we can zoom
  }

data ActionF s next =
    LiftAction (Action AppState next)
    | LiftIO (IO next)
    | StateAction (StateT s IO next)
    deriving Functor

newtype Action s a = Action
  { getAction :: Free (ActionF s) a
  } deriving (Functor, Applicative, Monad)

liftActionF :: ActionF s next -> Action s next
liftActionF = Action . liftF

instance MonadState s (Action s) where
  state = liftActionF . StateAction . state

liftAction :: Action AppState a -> Action s a
liftAction = liftActionF . LiftAction

execApp :: Action AppState a -> StateT AppState IO a
execApp (Action actionF) = foldFree toState actionF
  where
    toState (LiftAction act) = execApp act
    toState (LiftIO io) = liftIO io
    toState (StateAction st) = st

type instance Zoomed (Action s) = Zoomed (StateT s IO)
instance Zoom (Action s) (Action t) s t where
  zoom l (Action actionF) = Action $ hoistFree (zoomActionF l) actionF
    where
      zoomActionF _ (LiftAction act) = LiftAction act
      zoomActionF _ (LiftIO io) = LiftIO io
      zoomActionF lns (StateAction act) = StateAction $ zoom lns act

我收到了错误：

/Users/chris/dev/eve/src/Eve/Internal/AppF.hs:53:65: error:
    • Couldn't match type ‘a’ with ‘c’
      ‘a’ is a rigid type variable bound by
        a type expected by the context:
          forall a. ActionF s a -> ActionF t a
        at /Users/chris/dev/eve/src/Eve/Internal/AppF.hs:53:42
      ‘c’ is a rigid type variable bound by
        the type signature for:
          zoom :: forall c.
                  LensLike' (Zoomed (Action s) c) t s -> Action s c -> Action t c
        at /Users/chris/dev/eve/src/Eve/Internal/AppF.hs:53:7
      Expected type: LensLike'
                       (Control.Lens.Internal.Zoom.Focusing IO a) t s
        Actual type: LensLike' (Zoomed (Action s) c) t s
    • In the first argument of ‘zoomActionF’, namely ‘l’
      In the first argument of ‘hoistFree’, namely ‘(zoomActionF l)’
      In the second argument of ‘($)’, namely
        ‘hoistFree (zoomActionF l) actionF’
    • Relevant bindings include
        actionF :: Free (ActionF s) c
          (bound at /Users/chris/dev/eve/src/Eve/Internal/AppF.hs:53:22)
        l :: LensLike' (Zoomed (Action s) c) t s
          (bound at /Users/chris/dev/eve/src/Eve/Internal/AppF.hs:53:12)
        zoom :: LensLike' (Zoomed (Action s) c) t s
                -> Action s c -> Action t c
          (bound at /Users/chris/dev/eve/src/Eve/Internal/AppF.hs:53:7)

据我所知，它变得很混乱，因为 StateT 嵌入在 Free 构造函数中，并且它丢失了 a 的类型。

我之前通过定义我自己的缩放函数来获得一个工作版本，该函数在给定“镜头”的情况下缩放底层 StateT，但诀窍是我希望它也可以与 Traversal's 一起使用，所以最干净的方法是是写缩放实例。

有人知道如何编译吗？提前致谢！！如果可能的话，请在发布之前尝试编译您的答案，谢谢！

Answer 1

虽然我无法编译之前的版本，但我想出了一个可接受的解决方案，使用 FreeT 作为 State monad 的包装器，它只是将提升值的缩放推迟到以后，不幸的是我需要手动实现 @结果是 987654325@ 和 MonadFree，这并不容易弄清楚。此外，如果没有太多好的教程，除了 Gabriel Gonzalez 的（稍微过时的）指南，解释 FreeT 也有点棘手。

这就是我最终得到的结果

{-# language GeneralizedNewtypeDeriving #-}
{-# language DeriveFunctor #-}
{-# language FlexibleInstances #-}
{-# language MultiParamTypeClasses #-}
{-# language RankNTypes #-}
{-# language TypeFamilies #-}
{-# language UndecidableInstances #-}
{-# language ScopedTypeVariables #-}
module Eve.Internal.Actions
( AppF(..)
, ActionT(..)
, AppT

, execApp
, liftAction
) where

import Control.Monad.State
import Control.Monad.Trans.Free
import Control.Lens

-- | An 'App' has the same base and zoomed values.
type AppT s m a = ActionT s s m a

-- | A Free Functor for storing lifted App actions.
newtype AppF base m next = LiftAction (StateT base m next)
    deriving (Functor, Applicative)

-- | Base Action type. Allows paramaterization over application state,
-- zoomed state and underlying monad.
newtype ActionT base zoomed m a = ActionT
    { getAction :: FreeT (AppF base m) (StateT zoomed m) a
    } deriving (Functor, Applicative, Monad, MonadIO, MonadState zoomed)

instance Monad n => MonadFree (AppF base n) (ActionT base zoomed n) where
    wrap (LiftAction act) = join . ActionT . liftF . LiftAction $ act

instance MonadTrans (ActionT base zoomed) where
    lift = ActionT . lift . lift

-- | Helper method to run FreeTs.
unLift :: Monad m => FreeT (AppF base m) (StateT base m) a -> StateT base m a
unLift m = do
    step <- runFreeT m
    case step of
        Pure a -> return a
        Free (LiftAction next) -> next >>= unLift

-- | Allows 'zoom'ing 'Action's.
type instance Zoomed (ActionT base zoomed m) =
    Zoomed (FreeT (AppF base m) (StateT zoomed m))
instance Monad m => Zoom (ActionT base s m) (ActionT base t m) s t where
    zoom l (ActionT action) = ActionT $ zoom l action

-- | Given a 'Lens' or 'Traversal' or something similar from "Control.Lens"
-- which focuses the state (t) of an 'Action' from a base state (s),
-- this will convert @Action t a -> Action s a@.
--
-- Given a lens @HasStates s => Lens' s t@ it can also convert 
-- @Action t a -> App a@
runAction :: Zoom m n s t => LensLike' (Zoomed m c) t s -> m c -> n c
runAction = zoom

-- | Allows you to run an 'App' or 'AppM' inside of an 'Action' or 'ActionM'
liftAction :: Monad m => AppT base m a -> ActionT base zoomed m a
liftAction = liftF .  LiftAction . unLift . getAction

-- | Runs an application and returns the value and state.
runApp :: Monad m => base -> AppT base m a -> m (a, base)
runApp baseState = flip runStateT baseState . unLift . getAction

-- | Runs an application and returns the resulting state.
execApp :: Monad m => base -> AppT base m a -> m base
execApp baseState = fmap snd . runApp baseState