问题
I'm attempting to build a free monad (using free) which acts just like a StateT monad, but which allows you to also run monads over a base state AppState. I have a separate constructor LiftAction which holds those types. The idea is that you keep zooming Actions down until they reach AppState, which can store different states inside its extension map.
Here was my earlier (failed) attempt using mtl: Lift through nested state transformers (mtl)
Anyways, since it's basically a wrapper over StateT I've given it a MonadState instance, but now I'm working on adding the ability to zoom the monad's state using the lens library; I'm getting some weird compiler errors I'm having trouble understanding (the lens errors aren't usually terribly user friendly).
Here's my code and initial attempt:
{-# 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
I'm getting the error:
/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)
So far as I can tell it's getting confused because the StateT is embedded in the Free constructor and it loses track of the type of a.
I previously had a working version by defining my own zoom function which zoomed the underlying StateT given a 'Lens', but the trick is that I'd like this to also work with Traversal's, so the cleanest way would be to write the zoom instance.
Anyone have an idea of how to get this to compile? Thanks in advance!! If at all possible please try compiling your answers before posting, thanks!
回答1:
While I couldn't ever get the previous to compile, I came up with an acceptable solution using FreeT as a wrapper around the State monad which simply defers the zooming of the lifted values till later, unfortunately I needed to manually implement MonadTrans and MonadFree as a result, which wasn't terribly easy to figure out. Also interpreting FreeT is a bit tricky without too many good tutorials out there except a (slightly out of date) guide by Gabriel Gonzalez.
Here's what I ended up with
{-# 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
来源：https://stackoverflow.com/questions/42589612/zoom-instance-over-free-monad