Zoom instance over Free Monad

Question

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!

Answer 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