{-# LANGUAGE NamedFieldPuns #-}
module Neovim.Debug (
debug,
debug',
NvimHSDebugInstance(..),
develMain,
quitDevelMain,
restartDevelMain,
printGlobalFunctionMap,
runNeovim,
runNeovim',
module Neovim,
) where
import Neovim
import Neovim.Classes
import Neovim.Context (runNeovim)
import qualified Neovim.Context.Internal as Internal
import Neovim.Log (disableLogger)
import Neovim.Main (CommandLineOptions (..),
runPluginProvider)
import Neovim.RPC.Common (RPCConfig)
import Control.Monad
import qualified Data.Map as Map
import Foreign.Store
import UnliftIO.Async (Async, async,
cancel)
import UnliftIO.Concurrent (putMVar, takeMVar)
import UnliftIO.STM
import Data.Text.Prettyprint.Doc (nest, softline,
vcat, vsep)
import Prelude
debug :: env -> Internal.Neovim env a -> IO (Either (Doc AnsiStyle) a)
debug :: env -> Neovim env a -> IO (Either (Doc AnsiStyle) a)
debug env
env Neovim env a
a = IO (Either (Doc AnsiStyle) a) -> IO (Either (Doc AnsiStyle) a)
forall a. IO a -> IO a
disableLogger (IO (Either (Doc AnsiStyle) a) -> IO (Either (Doc AnsiStyle) a))
-> IO (Either (Doc AnsiStyle) a) -> IO (Either (Doc AnsiStyle) a)
forall a b. (a -> b) -> a -> b
$ do
CommandLineOptions
-> Maybe NeovimConfig
-> TransitionHandler (Either (Doc AnsiStyle) a)
-> IO (Either (Doc AnsiStyle) a)
forall a.
CommandLineOptions
-> Maybe NeovimConfig -> TransitionHandler a -> IO a
runPluginProvider CommandLineOptions
forall a. Default a => a
def { envVar :: Bool
envVar = Bool
True } Maybe NeovimConfig
forall a. Maybe a
Nothing TransitionHandler (Either (Doc AnsiStyle) a)
forall (t :: * -> *) a env.
Foldable t =>
t (Async a) -> Config env -> IO (Either (Doc AnsiStyle) a)
transitionHandler
where
transitionHandler :: t (Async a) -> Config env -> IO (Either (Doc AnsiStyle) a)
transitionHandler t (Async a)
tids Config env
cfg = MVar StateTransition -> IO StateTransition
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar (Config env -> MVar StateTransition
forall env. Config env -> MVar StateTransition
Internal.transitionTo Config env
cfg) IO StateTransition
-> (StateTransition -> IO (Either (Doc AnsiStyle) a))
-> IO (Either (Doc AnsiStyle) a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Internal.Failure Doc AnsiStyle
e ->
Either (Doc AnsiStyle) a -> IO (Either (Doc AnsiStyle) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Doc AnsiStyle) a -> IO (Either (Doc AnsiStyle) a))
-> Either (Doc AnsiStyle) a -> IO (Either (Doc AnsiStyle) a)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Either (Doc AnsiStyle) a
forall a b. a -> Either a b
Left Doc AnsiStyle
e
StateTransition
Internal.InitSuccess -> do
Either (Doc AnsiStyle) a
res <- (a -> IO a)
-> Config env -> Neovim env a -> IO (Either (Doc AnsiStyle) a)
forall a env.
(a -> IO a)
-> Config env -> Neovim env a -> IO (Either (Doc AnsiStyle) a)
Internal.runNeovimInternal
a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
(Config env
cfg { customConfig :: env
Internal.customConfig = env
env, pluginSettings :: Maybe (PluginSettings env)
Internal.pluginSettings = Maybe (PluginSettings env)
forall a. Maybe a
Nothing })
Neovim env a
a
(Async a -> IO ()) -> t (Async a) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async a -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel t (Async a)
tids
Either (Doc AnsiStyle) a -> IO (Either (Doc AnsiStyle) a)
forall (m :: * -> *) a. Monad m => a -> m a
return Either (Doc AnsiStyle) a
res
StateTransition
_ ->
Either (Doc AnsiStyle) a -> IO (Either (Doc AnsiStyle) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (Doc AnsiStyle) a -> IO (Either (Doc AnsiStyle) a))
-> (Doc AnsiStyle -> Either (Doc AnsiStyle) a)
-> Doc AnsiStyle
-> IO (Either (Doc AnsiStyle) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Either (Doc AnsiStyle) a
forall a b. a -> Either a b
Left (Doc AnsiStyle -> IO (Either (Doc AnsiStyle) a))
-> Doc AnsiStyle -> IO (Either (Doc AnsiStyle) a)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Unexpected transition state."
debug' :: Internal.Neovim () a -> IO (Either (Doc AnsiStyle) a)
debug' :: Neovim () a -> IO (Either (Doc AnsiStyle) a)
debug' = () -> Neovim () a -> IO (Either (Doc AnsiStyle) a)
forall env a. env -> Neovim env a -> IO (Either (Doc AnsiStyle) a)
debug ()
data NvimHSDebugInstance = NvimHSDebugInstance
{ NvimHSDebugInstance -> [Async ()]
threads :: [Async ()]
, NvimHSDebugInstance -> NeovimConfig
neovimConfig :: NeovimConfig
, NvimHSDebugInstance -> Config RPCConfig
internalConfig :: Internal.Config RPCConfig
}
develMain
:: NeovimConfig
-> IO (Maybe NvimHSDebugInstance)
develMain :: NeovimConfig -> IO (Maybe NvimHSDebugInstance)
develMain NeovimConfig
neovimConfig = Word32 -> IO (Maybe (Store (Maybe NvimHSDebugInstance)))
forall a. Word32 -> IO (Maybe (Store a))
lookupStore Word32
0 IO (Maybe (Store (Maybe NvimHSDebugInstance)))
-> (Maybe (Store (Maybe NvimHSDebugInstance))
-> IO (Maybe NvimHSDebugInstance))
-> IO (Maybe NvimHSDebugInstance)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Store (Maybe NvimHSDebugInstance))
Nothing -> do
Maybe NvimHSDebugInstance
x <- IO (Maybe NvimHSDebugInstance) -> IO (Maybe NvimHSDebugInstance)
forall a. IO a -> IO a
disableLogger (IO (Maybe NvimHSDebugInstance) -> IO (Maybe NvimHSDebugInstance))
-> IO (Maybe NvimHSDebugInstance) -> IO (Maybe NvimHSDebugInstance)
forall a b. (a -> b) -> a -> b
$ CommandLineOptions
-> Maybe NeovimConfig
-> TransitionHandler (Maybe NvimHSDebugInstance)
-> IO (Maybe NvimHSDebugInstance)
forall a.
CommandLineOptions
-> Maybe NeovimConfig -> TransitionHandler a -> IO a
runPluginProvider
CommandLineOptions
forall a. Default a => a
def{ envVar :: Bool
envVar = Bool
True }
(NeovimConfig -> Maybe NeovimConfig
forall a. a -> Maybe a
Just NeovimConfig
neovimConfig)
TransitionHandler (Maybe NvimHSDebugInstance)
transitionHandler
IO (Store (Maybe NvimHSDebugInstance)) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Store (Maybe NvimHSDebugInstance)) -> IO ())
-> IO (Store (Maybe NvimHSDebugInstance)) -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe NvimHSDebugInstance -> IO (Store (Maybe NvimHSDebugInstance))
forall a. a -> IO (Store a)
newStore Maybe NvimHSDebugInstance
x
Maybe NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NvimHSDebugInstance
x
Just Store (Maybe NvimHSDebugInstance)
x ->
Store (Maybe NvimHSDebugInstance) -> IO (Maybe NvimHSDebugInstance)
forall a. Store a -> IO a
readStore Store (Maybe NvimHSDebugInstance)
x
where
transitionHandler :: TransitionHandler (Maybe NvimHSDebugInstance)
transitionHandler [Async ()]
tids Config RPCConfig
cfg = MVar StateTransition -> IO StateTransition
forall (m :: * -> *) a. MonadIO m => MVar a -> m a
takeMVar (Config RPCConfig -> MVar StateTransition
forall env. Config env -> MVar StateTransition
Internal.transitionTo Config RPCConfig
cfg) IO StateTransition
-> (StateTransition -> IO (Maybe NvimHSDebugInstance))
-> IO (Maybe NvimHSDebugInstance)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Internal.Failure Doc AnsiStyle
e -> do
Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
e
Maybe NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NvimHSDebugInstance
forall a. Maybe a
Nothing
StateTransition
Internal.InitSuccess -> do
Async ()
transitionHandlerThread <- IO () -> IO (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
IO (Maybe NvimHSDebugInstance) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe NvimHSDebugInstance) -> IO ())
-> IO (Maybe NvimHSDebugInstance) -> IO ()
forall a b. (a -> b) -> a -> b
$ TransitionHandler (Maybe NvimHSDebugInstance)
transitionHandler ([Async ()]
tids) Config RPCConfig
cfg
Maybe NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance))
-> (NvimHSDebugInstance -> Maybe NvimHSDebugInstance)
-> NvimHSDebugInstance
-> IO (Maybe NvimHSDebugInstance)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NvimHSDebugInstance -> Maybe NvimHSDebugInstance
forall a. a -> Maybe a
Just (NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance))
-> NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance)
forall a b. (a -> b) -> a -> b
$ NvimHSDebugInstance :: [Async ()]
-> NeovimConfig -> Config RPCConfig -> NvimHSDebugInstance
NvimHSDebugInstance
{ threads :: [Async ()]
threads = (Async ()
transitionHandlerThreadAsync () -> [Async ()] -> [Async ()]
forall a. a -> [a] -> [a]
:[Async ()]
tids)
, neovimConfig :: NeovimConfig
neovimConfig = NeovimConfig
neovimConfig
, internalConfig :: Config RPCConfig
internalConfig = Config RPCConfig
cfg
}
StateTransition
Internal.Quit -> do
Word32 -> IO (Maybe (Store Any))
forall a. Word32 -> IO (Maybe (Store a))
lookupStore Word32
0 IO (Maybe (Store Any)) -> (Maybe (Store Any) -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe (Store Any)
Nothing ->
() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Store Any
x ->
Store Any -> IO ()
forall a. Store a -> IO ()
deleteStore Store Any
x
(Async () -> IO ()) -> [Async ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async () -> IO ()
forall (m :: * -> *) a. MonadIO m => Async a -> m ()
cancel [Async ()]
tids
String -> IO ()
putStrLn String
"Quit develMain"
Maybe NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NvimHSDebugInstance
forall a. Maybe a
Nothing
StateTransition
_ -> do
String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Unexpected transition state for develMain."
Maybe NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe NvimHSDebugInstance
forall a. Maybe a
Nothing
quitDevelMain :: NvimHSDebugInstance -> IO ()
quitDevelMain :: NvimHSDebugInstance -> IO ()
quitDevelMain NvimHSDebugInstance{Config RPCConfig
internalConfig :: Config RPCConfig
internalConfig :: NvimHSDebugInstance -> Config RPCConfig
internalConfig} =
MVar StateTransition -> StateTransition -> IO ()
forall (m :: * -> *) a. MonadIO m => MVar a -> a -> m ()
putMVar (Config RPCConfig -> MVar StateTransition
forall env. Config env -> MVar StateTransition
Internal.transitionTo Config RPCConfig
internalConfig) StateTransition
Internal.Quit
restartDevelMain
:: NvimHSDebugInstance
-> IO (Maybe NvimHSDebugInstance)
restartDevelMain :: NvimHSDebugInstance -> IO (Maybe NvimHSDebugInstance)
restartDevelMain NvimHSDebugInstance
di = do
NvimHSDebugInstance -> IO ()
quitDevelMain NvimHSDebugInstance
di
NeovimConfig -> IO (Maybe NvimHSDebugInstance)
develMain (NvimHSDebugInstance -> NeovimConfig
neovimConfig NvimHSDebugInstance
di)
runNeovim' :: NFData a
=> NvimHSDebugInstance -> Neovim () a -> IO (Either (Doc AnsiStyle) a)
runNeovim' :: NvimHSDebugInstance -> Neovim () a -> IO (Either (Doc AnsiStyle) a)
runNeovim' NvimHSDebugInstance{Config RPCConfig
internalConfig :: Config RPCConfig
internalConfig :: NvimHSDebugInstance -> Config RPCConfig
internalConfig} =
Config () -> Neovim () a -> IO (Either (Doc AnsiStyle) a)
forall a env.
NFData a =>
Config env -> Neovim env a -> IO (Either (Doc AnsiStyle) a)
runNeovim (() -> Config RPCConfig -> Config ()
forall env anotherEnv. env -> Config anotherEnv -> Config env
Internal.retypeConfig () (Config RPCConfig
internalConfig))
printGlobalFunctionMap :: NvimHSDebugInstance -> IO ()
printGlobalFunctionMap :: NvimHSDebugInstance -> IO ()
printGlobalFunctionMap NvimHSDebugInstance{Config RPCConfig
internalConfig :: Config RPCConfig
internalConfig :: NvimHSDebugInstance -> Config RPCConfig
internalConfig} = do
[(NvimMethod, FunctionMapEntry)]
es <- (Map NvimMethod FunctionMapEntry
-> [(NvimMethod, FunctionMapEntry)])
-> IO (Map NvimMethod FunctionMapEntry)
-> IO [(NvimMethod, FunctionMapEntry)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Map NvimMethod FunctionMapEntry -> [(NvimMethod, FunctionMapEntry)]
forall k a. Map k a -> [(k, a)]
Map.toList (IO (Map NvimMethod FunctionMapEntry)
-> IO [(NvimMethod, FunctionMapEntry)])
-> (STM (Map NvimMethod FunctionMapEntry)
-> IO (Map NvimMethod FunctionMapEntry))
-> STM (Map NvimMethod FunctionMapEntry)
-> IO [(NvimMethod, FunctionMapEntry)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. STM (Map NvimMethod FunctionMapEntry)
-> IO (Map NvimMethod FunctionMapEntry)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM (Map NvimMethod FunctionMapEntry)
-> IO [(NvimMethod, FunctionMapEntry)])
-> STM (Map NvimMethod FunctionMapEntry)
-> IO [(NvimMethod, FunctionMapEntry)]
forall a b. (a -> b) -> a -> b
$
TMVar (Map NvimMethod FunctionMapEntry)
-> STM (Map NvimMethod FunctionMapEntry)
forall a. TMVar a -> STM a
readTMVar (Config RPCConfig -> TMVar (Map NvimMethod FunctionMapEntry)
forall env. Config env -> TMVar (Map NvimMethod FunctionMapEntry)
Internal.globalFunctionMap Config RPCConfig
internalConfig)
let header :: Doc AnsiStyle
header = Doc AnsiStyle
"Printing global function map:"
funs :: [Doc ann]
funs = ((NvimMethod, FunctionMapEntry) -> Doc ann)
-> [(NvimMethod, FunctionMapEntry)] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
map (\(NvimMethod
fname, (FunctionalityDescription
d, FunctionType
f)) ->
Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
nest Int
3 (NvimMethod -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty NvimMethod
fname
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
"->"
Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
forall ann. Doc ann
softline Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> FunctionalityDescription -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty FunctionalityDescription
d Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc ann
":"
Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> FunctionType -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty FunctionType
f)) [(NvimMethod, FunctionMapEntry)]
es
Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$
Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
nest Int
2 (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep [Doc AnsiStyle
header, [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat [Doc AnsiStyle]
forall ann. [Doc ann]
funs, Doc AnsiStyle
forall a. Monoid a => a
mempty]