mirror of
https://github.com/unisonweb/unison.git
synced 2024-11-13 00:12:21 +03:00
Add ReaderT to Action and wrap Action in its own monad
This commit is contained in:
parent
863d989856
commit
da9c50d2f1
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user