Add ReaderT to Action and wrap Action in its own monad

This commit is contained in:
Chris Penner 2022-03-24 10:46:07 -06:00
parent 863d989856
commit da9c50d2f1
4 changed files with 32 additions and 11 deletions

View File

@ -45,7 +45,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
import Unison.Codebase.Editor.Command as Command
import Unison.Codebase.Editor.DisplayObject
import qualified Unison.Codebase.Editor.Git as Git
import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval)
import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval, liftF)
import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies
import Unison.Codebase.Editor.Input
@ -1628,7 +1628,7 @@ loop = do
doRemoveReplacement from patchPath False
ShowDefinitionByPrefixI {} -> notImplemented
UpdateBuiltinsI -> notImplemented
QuitI -> MaybeT $ pure Nothing
QuitI -> empty
GistI input -> handleGist input
where
notImplemented = eval $ Notify NotImplemented
@ -2243,7 +2243,7 @@ propagatePatchNoSync patch scopePath = do
stepAtMNoSync'
Branch.CompressHistory
( Path.unabsolute scopePath,
lift . lift . Propagate.propagateAndApply nroot patch
liftF . Propagate.propagateAndApply nroot patch
)
-- Returns True if the operation changed the namespace, False otherwise.
@ -2260,7 +2260,7 @@ propagatePatch inputDescription patch scopePath = do
Branch.CompressHistory
(inputDescription <> " (applying patch)")
( Path.unabsolute scopePath,
lift . lift . Propagate.propagateAndApply nroot patch
liftF . Propagate.propagateAndApply nroot patch
)
-- | Create the args needed for showTodoOutput and call it

View File

@ -5,8 +5,9 @@
module Unison.Codebase.Editor.HandleInput.LoopState where
import Control.Lens
import Control.Monad.Except (ExceptT)
import Control.Monad.State (StateT)
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.State
import Data.Configurator ()
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as Nel
@ -24,7 +25,23 @@ import qualified Unison.Util.Free as Free
type F m i v = Free (Command m i v)
type Action m i v = MaybeT (StateT (LoopState m v) (F m i v))
data Env = Env
newtype Action m i v a = Action {unAction :: MaybeT (ReaderT Env (StateT (LoopState m v) (F m i v))) a}
deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadState (LoopState m v), MonadReader Env)
-- We should likely remove this MonadFail instance since it's really hard to debug,
-- but it's currently in use.
deriving newtype (MonadFail)
runAction :: Env -> LoopState m v -> Action m i v a -> (F m i v (Maybe a, LoopState m v))
runAction env state (Action m) =
m
& runMaybeT
& flip runReaderT env
& flip runStateT state
liftF :: F m i v a -> Action m i v a
liftF = Action . lift . lift . lift
-- | A typeclass representing monads which can evaluate 'Command's.
class Monad n => MonadCommand n m v i | n -> m v i where
@ -42,6 +59,12 @@ instance MonadCommand n m i v => MonadCommand (MaybeT n) m i v where
instance MonadCommand n m i v => MonadCommand (ExceptT e n) m i v where
eval = lift . eval
instance MonadCommand n m i v => MonadCommand (ReaderT r n) m i v where
eval = lift . eval
instance MonadCommand (Action m i v) m i v where
eval = Action . eval
type NumberedArgs = [String]
data LoopState m v = LoopState

View File

@ -21,7 +21,6 @@ where
import Control.Concurrent.STM (atomically)
import Control.Error (rightMay)
import Control.Lens (view)
import Control.Monad.State (runStateT)
import qualified Crypto.Random as Random
import qualified Data.Char as Char
import qualified Data.Configurator as Configurator
@ -376,7 +375,7 @@ run dir stanzas codebase runtime config = UnliftIO.try $ do
loop state = do
writeIORef pathRef (view LoopState.currentPath state)
let free = runStateT (runMaybeT HandleInput.loop) state
let free = LoopState.runAction LoopState.Env state $ HandleInput.loop
rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i))
(o, state') <-
HandleCommand.commandLine

View File

@ -13,7 +13,6 @@ import Control.Concurrent.STM (atomically)
import Control.Error (rightMay)
import Control.Exception (catch, finally)
import Control.Lens (view)
import Control.Monad.State (runStateT)
import qualified Crypto.Random as Random
import Data.Configurator.Types (Config)
import Data.IORef
@ -188,7 +187,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
let loop :: LoopState.LoopState IO Symbol -> IO ()
loop state = do
writeIORef pathRef (view LoopState.currentPath state)
let free = runStateT (runMaybeT HandleInput.loop) state
let free = LoopState.runAction LoopState.Env state HandleInput.loop
let handleCommand =
HandleCommand.commandLine
config