{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PackageImports #-}
module Development.IDE.Plugin.Test
( TestRequest(..)
, WaitForIdeRuleResult(..)
, plugin
, blockCommandDescriptor
, blockCommandId
) where
import Control.Concurrent (threadDelay)
import Control.Monad
import Control.Monad.Except (ExceptT (..), throwError)
import Control.Monad.IO.Class
import Control.Monad.STM
import Control.Monad.Trans.Class (MonadTrans (lift))
import Data.Aeson (FromJSON (parseJSON),
ToJSON (toJSON), Value)
import qualified Data.Aeson.Types as A
import Data.Bifunctor
import Data.CaseInsensitive (CI, original)
import qualified Data.HashMap.Strict as HM
import Data.Maybe (isJust)
import Data.Proxy
import Data.String
import Data.Text (Text, pack)
import Development.IDE.Core.OfInterest (getFilesOfInterest)
import Development.IDE.Core.Rules
import Development.IDE.Core.RuleTypes
import Development.IDE.Core.Shake
import Development.IDE.GHC.Compat
import Development.IDE.Graph (Action)
import qualified Development.IDE.Graph as Graph
import Development.IDE.Graph.Database (ShakeDatabase,
shakeGetBuildEdges,
shakeGetBuildStep,
shakeGetCleanKeys)
import Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),
Step (Step))
import qualified Development.IDE.Graph.Internal.Types as Graph
import Development.IDE.Types.Action
import Development.IDE.Types.HscEnvEq (HscEnvEq (hscEnv))
import Development.IDE.Types.Location (fromUri)
import GHC.Generics (Generic)
import Ide.Plugin.Error
import Ide.Types
import Language.LSP.Protocol.Message
import Language.LSP.Protocol.Types
import qualified "list-t" ListT
import qualified StmContainers.Map as STM
import System.Time.Extra
type Age = Int
data TestRequest
= BlockSeconds Seconds
| GetInterfaceFilesDir Uri
| GetShakeSessionQueueCount
| WaitForShakeQueue
| WaitForIdeRule String Uri
| GetBuildKeysVisited
| GetBuildKeysBuilt
| GetBuildKeysChanged
| GetBuildEdgesCount
| GarbageCollectDirtyKeys CheckParents Age
| GetStoredKeys
| GetFilesOfInterest
| GetRebuildsCount
deriving (forall x. TestRequest -> Rep TestRequest x)
-> (forall x. Rep TestRequest x -> TestRequest)
-> Generic TestRequest
forall x. Rep TestRequest x -> TestRequest
forall x. TestRequest -> Rep TestRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. TestRequest -> Rep TestRequest x
from :: forall x. TestRequest -> Rep TestRequest x
$cto :: forall x. Rep TestRequest x -> TestRequest
to :: forall x. Rep TestRequest x -> TestRequest
Generic
deriving anyclass (Maybe TestRequest
Value -> Parser [TestRequest]
Value -> Parser TestRequest
(Value -> Parser TestRequest)
-> (Value -> Parser [TestRequest])
-> Maybe TestRequest
-> FromJSON TestRequest
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser TestRequest
parseJSON :: Value -> Parser TestRequest
$cparseJSONList :: Value -> Parser [TestRequest]
parseJSONList :: Value -> Parser [TestRequest]
$comittedField :: Maybe TestRequest
omittedField :: Maybe TestRequest
FromJSON, [TestRequest] -> Value
[TestRequest] -> Encoding
TestRequest -> Bool
TestRequest -> Value
TestRequest -> Encoding
(TestRequest -> Value)
-> (TestRequest -> Encoding)
-> ([TestRequest] -> Value)
-> ([TestRequest] -> Encoding)
-> (TestRequest -> Bool)
-> ToJSON TestRequest
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: TestRequest -> Value
toJSON :: TestRequest -> Value
$ctoEncoding :: TestRequest -> Encoding
toEncoding :: TestRequest -> Encoding
$ctoJSONList :: [TestRequest] -> Value
toJSONList :: [TestRequest] -> Value
$ctoEncodingList :: [TestRequest] -> Encoding
toEncodingList :: [TestRequest] -> Encoding
$comitField :: TestRequest -> Bool
omitField :: TestRequest -> Bool
ToJSON)
newtype WaitForIdeRuleResult = WaitForIdeRuleResult { WaitForIdeRuleResult -> Bool
ideResultSuccess::Bool}
deriving newtype (Maybe WaitForIdeRuleResult
Value -> Parser [WaitForIdeRuleResult]
Value -> Parser WaitForIdeRuleResult
(Value -> Parser WaitForIdeRuleResult)
-> (Value -> Parser [WaitForIdeRuleResult])
-> Maybe WaitForIdeRuleResult
-> FromJSON WaitForIdeRuleResult
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser WaitForIdeRuleResult
parseJSON :: Value -> Parser WaitForIdeRuleResult
$cparseJSONList :: Value -> Parser [WaitForIdeRuleResult]
parseJSONList :: Value -> Parser [WaitForIdeRuleResult]
$comittedField :: Maybe WaitForIdeRuleResult
omittedField :: Maybe WaitForIdeRuleResult
FromJSON, [WaitForIdeRuleResult] -> Value
[WaitForIdeRuleResult] -> Encoding
WaitForIdeRuleResult -> Bool
WaitForIdeRuleResult -> Value
WaitForIdeRuleResult -> Encoding
(WaitForIdeRuleResult -> Value)
-> (WaitForIdeRuleResult -> Encoding)
-> ([WaitForIdeRuleResult] -> Value)
-> ([WaitForIdeRuleResult] -> Encoding)
-> (WaitForIdeRuleResult -> Bool)
-> ToJSON WaitForIdeRuleResult
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: WaitForIdeRuleResult -> Value
toJSON :: WaitForIdeRuleResult -> Value
$ctoEncoding :: WaitForIdeRuleResult -> Encoding
toEncoding :: WaitForIdeRuleResult -> Encoding
$ctoJSONList :: [WaitForIdeRuleResult] -> Value
toJSONList :: [WaitForIdeRuleResult] -> Value
$ctoEncodingList :: [WaitForIdeRuleResult] -> Encoding
toEncodingList :: [WaitForIdeRuleResult] -> Encoding
$comitField :: WaitForIdeRuleResult -> Bool
omitField :: WaitForIdeRuleResult -> Bool
ToJSON)
plugin :: PluginDescriptor IdeState
plugin :: PluginDescriptor IdeState
plugin = (PluginId -> Text -> PluginDescriptor IdeState
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
"test" Text
"") {
pluginHandlers = mkPluginHandler (SMethod_CustomMethod (Proxy @"test")) $ \IdeState
st PluginId
_ ->
IdeState -> Value -> ExceptT PluginError (HandlerM Config) Value
forall {config}.
IdeState -> Value -> ExceptT PluginError (HandlerM config) Value
testRequestHandler' IdeState
st
}
where
testRequestHandler' :: IdeState -> Value -> ExceptT PluginError (HandlerM config) Value
testRequestHandler' IdeState
ide Value
req
| Just TestRequest
customReq <- (Value -> Parser TestRequest) -> Value -> Maybe TestRequest
forall a b. (a -> Parser b) -> a -> Maybe b
A.parseMaybe Value -> Parser TestRequest
forall a. FromJSON a => Value -> Parser a
parseJSON Value
req
= HandlerM config (Either PluginError Value)
-> ExceptT PluginError (HandlerM config) Value
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (HandlerM config (Either PluginError Value)
-> ExceptT PluginError (HandlerM config) Value)
-> HandlerM config (Either PluginError Value)
-> ExceptT PluginError (HandlerM config) Value
forall a b. (a -> b) -> a -> b
$ IdeState
-> TestRequest -> HandlerM config (Either PluginError Value)
forall config.
IdeState
-> TestRequest -> HandlerM config (Either PluginError Value)
testRequestHandler IdeState
ide TestRequest
customReq
| Bool
otherwise
= PluginError -> ExceptT PluginError (HandlerM config) Value
forall a. PluginError -> ExceptT PluginError (HandlerM config) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
(PluginError -> ExceptT PluginError (HandlerM config) Value)
-> PluginError -> ExceptT PluginError (HandlerM config) Value
forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInvalidParams Text
"Cannot parse request"
testRequestHandler :: IdeState
-> TestRequest
-> HandlerM config (Either PluginError Value)
testRequestHandler :: forall config.
IdeState
-> TestRequest -> HandlerM config (Either PluginError Value)
testRequestHandler IdeState
_ (BlockSeconds Seconds
secs) = do
SServerMethod ('Method_CustomMethod "ghcide/blocking/request")
-> MessageParams ('Method_CustomMethod "ghcide/blocking/request")
-> HandlerM config ()
forall (m :: Method 'ServerToClient 'Notification) config.
SServerMethod m -> MessageParams m -> HandlerM config ()
pluginSendNotification (Proxy "ghcide/blocking/request"
-> SServerMethod ('Method_CustomMethod "ghcide/blocking/request")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"ghcide/blocking/request")) (MessageParams ('Method_CustomMethod "ghcide/blocking/request")
-> HandlerM config ())
-> MessageParams ('Method_CustomMethod "ghcide/blocking/request")
-> HandlerM config ()
forall a b. (a -> b) -> a -> b
$
Seconds -> Value
forall a. ToJSON a => a -> Value
toJSON Seconds
secs
IO () -> HandlerM config ()
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> HandlerM config ()) -> IO () -> HandlerM config ()
forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
secs
Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a. a -> HandlerM config a
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either PluginError Value
forall a b. b -> Either a b
Right Value
A.Null)
testRequestHandler IdeState
s (GetInterfaceFilesDir Uri
file) = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
let nfp :: NormalizedFilePath
nfp = NormalizedUri -> NormalizedFilePath
fromUri (NormalizedUri -> NormalizedFilePath)
-> NormalizedUri -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
file
HscEnvEq
sess <- String -> IdeState -> Action HscEnvEq -> IO HscEnvEq
forall a. String -> IdeState -> Action a -> IO a
runAction String
"Test - GhcSession" IdeState
s (Action HscEnvEq -> IO HscEnvEq) -> Action HscEnvEq -> IO HscEnvEq
forall a b. (a -> b) -> a -> b
$ GhcSession -> NormalizedFilePath -> Action HscEnvEq
forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
nfp
let hiPath :: Maybe String
hiPath = DynFlags -> Maybe String
hiDir (DynFlags -> Maybe String) -> DynFlags -> Maybe String
forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags (HscEnv -> DynFlags) -> HscEnv -> DynFlags
forall a b. (a -> b) -> a -> b
$ HscEnvEq -> HscEnv
hscEnv HscEnvEq
sess
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Maybe String -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe String
hiPath)
testRequestHandler IdeState
s TestRequest
GetShakeSessionQueueCount = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
Natural
n <- STM Natural -> IO Natural
forall a. STM a -> IO a
atomically (STM Natural -> IO Natural) -> STM Natural -> IO Natural
forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM Natural
countQueue (ActionQueue -> STM Natural) -> ActionQueue -> STM Natural
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ActionQueue
actionQueue (ShakeExtras -> ActionQueue) -> ShakeExtras -> ActionQueue
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
s
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Natural -> Value
forall a. ToJSON a => a -> Value
toJSON Natural
n)
testRequestHandler IdeState
s TestRequest
WaitForShakeQueue = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Natural
n <- ActionQueue -> STM Natural
countQueue (ActionQueue -> STM Natural) -> ActionQueue -> STM Natural
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ActionQueue
actionQueue (ShakeExtras -> ActionQueue) -> ShakeExtras -> ActionQueue
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
s
Bool -> STM () -> STM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Natural
nNatural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
>Natural
0) STM ()
forall a. STM a
retry
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right Value
A.Null
testRequestHandler IdeState
s (WaitForIdeRule String
k Uri
file) = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
let nfp :: NormalizedFilePath
nfp = NormalizedUri -> NormalizedFilePath
fromUri (NormalizedUri -> NormalizedFilePath)
-> NormalizedUri -> NormalizedFilePath
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
file
Either Text Bool
success <- String
-> IdeState -> Action (Either Text Bool) -> IO (Either Text Bool)
forall a. String -> IdeState -> Action a -> IO a
runAction (String
"WaitForIdeRule " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
k String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Uri -> String
forall a. Show a => a -> String
show Uri
file) IdeState
s (Action (Either Text Bool) -> IO (Either Text Bool))
-> Action (Either Text Bool) -> IO (Either Text Bool)
forall a b. (a -> b) -> a -> b
$ CI String -> NormalizedFilePath -> Action (Either Text Bool)
parseAction (String -> CI String
forall a. IsString a => String -> a
fromString String
k) NormalizedFilePath
nfp
let res :: Either Text WaitForIdeRuleResult
res = Bool -> WaitForIdeRuleResult
WaitForIdeRuleResult (Bool -> WaitForIdeRuleResult)
-> Either Text Bool -> Either Text WaitForIdeRuleResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Bool
success
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ (Text -> PluginError)
-> (WaitForIdeRuleResult -> Value)
-> Either Text WaitForIdeRuleResult
-> Either PluginError Value
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> PluginError
PluginInvalidParams WaitForIdeRuleResult -> Value
forall a. ToJSON a => a -> Value
toJSON Either Text WaitForIdeRuleResult
res
testRequestHandler IdeState
s TestRequest
GetBuildKeysBuilt = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
[Key]
keys <- (Result -> Step) -> ShakeDatabase -> IO [Key]
getDatabaseKeys Result -> Step
resultBuilt (ShakeDatabase -> IO [Key]) -> ShakeDatabase -> IO [Key]
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ [String] -> Value
forall a. ToJSON a => a -> Value
toJSON ([String] -> Value) -> [String] -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetBuildKeysChanged = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
[Key]
keys <- (Result -> Step) -> ShakeDatabase -> IO [Key]
getDatabaseKeys Result -> Step
resultChanged (ShakeDatabase -> IO [Key]) -> ShakeDatabase -> IO [Key]
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ [String] -> Value
forall a. ToJSON a => a -> Value
toJSON ([String] -> Value) -> [String] -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetBuildKeysVisited = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
[Key]
keys <- (Result -> Step) -> ShakeDatabase -> IO [Key]
getDatabaseKeys Result -> Step
resultVisited (ShakeDatabase -> IO [Key]) -> ShakeDatabase -> IO [Key]
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ [String] -> Value
forall a. ToJSON a => a -> Value
toJSON ([String] -> Value) -> [String] -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetBuildEdgesCount = IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value))
-> IO (Either PluginError Value)
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ do
Age
count <- ShakeDatabase -> IO Age
shakeGetBuildEdges (ShakeDatabase -> IO Age) -> ShakeDatabase -> IO Age
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
Either PluginError Value -> IO (Either PluginError Value)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value -> IO (Either PluginError Value))
-> Either PluginError Value -> IO (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ Age -> Value
forall a. ToJSON a => a -> Value
toJSON Age
count
testRequestHandler IdeState
s (GarbageCollectDirtyKeys CheckParents
parents Age
age) = do
[Key]
res <- IO [Key] -> HandlerM config [Key]
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Key] -> HandlerM config [Key])
-> IO [Key] -> HandlerM config [Key]
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action [Key] -> IO [Key]
forall a. String -> IdeState -> Action a -> IO a
runAction String
"garbage collect dirty" IdeState
s (Action [Key] -> IO [Key]) -> Action [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$ Age -> CheckParents -> Action [Key]
garbageCollectDirtyKeysOlderThan Age
age CheckParents
parents
Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a. a -> HandlerM config a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value
-> HandlerM config (Either PluginError Value))
-> Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ [String] -> Value
forall a. ToJSON a => a -> Value
toJSON ([String] -> Value) -> [String] -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
forall a. Show a => a -> String
show [Key]
res
testRequestHandler IdeState
s TestRequest
GetStoredKeys = do
[Key]
keys <- IO [Key] -> HandlerM config [Key]
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Key] -> HandlerM config [Key])
-> IO [Key] -> HandlerM config [Key]
forall a b. (a -> b) -> a -> b
$ STM [Key] -> IO [Key]
forall a. STM a -> IO a
atomically (STM [Key] -> IO [Key]) -> STM [Key] -> IO [Key]
forall a b. (a -> b) -> a -> b
$ ((Key, ValueWithDiagnostics) -> Key)
-> [(Key, ValueWithDiagnostics)] -> [Key]
forall a b. (a -> b) -> [a] -> [b]
map (Key, ValueWithDiagnostics) -> Key
forall a b. (a, b) -> a
fst ([(Key, ValueWithDiagnostics)] -> [Key])
-> STM [(Key, ValueWithDiagnostics)] -> STM [Key]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ListT STM (Key, ValueWithDiagnostics)
-> STM [(Key, ValueWithDiagnostics)]
forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (Map Key ValueWithDiagnostics
-> ListT STM (Key, ValueWithDiagnostics)
forall key value. Map key value -> ListT STM (key, value)
STM.listT (Map Key ValueWithDiagnostics
-> ListT STM (Key, ValueWithDiagnostics))
-> Map Key ValueWithDiagnostics
-> ListT STM (Key, ValueWithDiagnostics)
forall a b. (a -> b) -> a -> b
$ ShakeExtras -> Map Key ValueWithDiagnostics
state (ShakeExtras -> Map Key ValueWithDiagnostics)
-> ShakeExtras -> Map Key ValueWithDiagnostics
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
s)
Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a. a -> HandlerM config a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value
-> HandlerM config (Either PluginError Value))
-> Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ [String] -> Value
forall a. ToJSON a => a -> Value
toJSON ([String] -> Value) -> [String] -> Value
forall a b. (a -> b) -> a -> b
$ (Key -> String) -> [Key] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Key -> String
forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetFilesOfInterest = do
HashMap NormalizedFilePath FileOfInterestStatus
ff <- IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> HandlerM
config (HashMap NormalizedFilePath FileOfInterestStatus)
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> HandlerM
config (HashMap NormalizedFilePath FileOfInterestStatus))
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> HandlerM
config (HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ IdeState -> IO (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest IdeState
s
Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a. a -> HandlerM config a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value
-> HandlerM config (Either PluginError Value))
-> Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ [String] -> Value
forall a. ToJSON a => a -> Value
toJSON ([String] -> Value) -> [String] -> Value
forall a b. (a -> b) -> a -> b
$ (NormalizedFilePath -> String) -> [NormalizedFilePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> String
fromNormalizedFilePath ([NormalizedFilePath] -> [String])
-> [NormalizedFilePath] -> [String]
forall a b. (a -> b) -> a -> b
$ HashMap NormalizedFilePath FileOfInterestStatus
-> [NormalizedFilePath]
forall k v. HashMap k v -> [k]
HM.keys HashMap NormalizedFilePath FileOfInterestStatus
ff
testRequestHandler IdeState
s TestRequest
GetRebuildsCount = do
Age
count <- IO Age -> HandlerM config Age
forall a. IO a -> HandlerM config a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Age -> HandlerM config Age) -> IO Age -> HandlerM config Age
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action Age -> IO Age
forall a. String -> IdeState -> Action a -> IO a
runAction String
"get build count" IdeState
s Action Age
getRebuildCount
Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a. a -> HandlerM config a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PluginError Value
-> HandlerM config (Either PluginError Value))
-> Either PluginError Value
-> HandlerM config (Either PluginError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either PluginError Value
forall a b. b -> Either a b
Right (Value -> Either PluginError Value)
-> Value -> Either PluginError Value
forall a b. (a -> b) -> a -> b
$ Age -> Value
forall a. ToJSON a => a -> Value
toJSON Age
count
getDatabaseKeys :: (Graph.Result -> Step)
-> ShakeDatabase
-> IO [Graph.Key]
getDatabaseKeys :: (Result -> Step) -> ShakeDatabase -> IO [Key]
getDatabaseKeys Result -> Step
field ShakeDatabase
db = do
[(Key, Result)]
keys <- ShakeDatabase -> IO [(Key, Result)]
shakeGetCleanKeys ShakeDatabase
db
Age
step <- ShakeDatabase -> IO Age
shakeGetBuildStep ShakeDatabase
db
[Key] -> IO [Key]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ Key
k | (Key
k, Result
res) <- [(Key, Result)]
keys, Result -> Step
field Result
res Step -> Step -> Bool
forall a. Eq a => a -> a -> Bool
== Age -> Step
Step Age
step]
parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool)
parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool)
parseAction CI String
"typecheck" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe TcModuleResult -> Bool)
-> Maybe TcModuleResult
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TcModuleResult -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TcModuleResult -> Either Text Bool)
-> Action (Maybe TcModuleResult) -> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TypeCheck -> NormalizedFilePath -> Action (Maybe TcModuleResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
fp
parseAction CI String
"getLocatedImports" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe [(Located ModuleName, Maybe ArtifactsLocation)] -> Bool)
-> Maybe [(Located ModuleName, Maybe ArtifactsLocation)]
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe [(Located ModuleName, Maybe ArtifactsLocation)] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [(Located ModuleName, Maybe ArtifactsLocation)]
-> Either Text Bool)
-> Action (Maybe [(Located ModuleName, Maybe ArtifactsLocation)])
-> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetLocatedImports
-> NormalizedFilePath
-> Action (Maybe [(Located ModuleName, Maybe ArtifactsLocation)])
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetLocatedImports
GetLocatedImports NormalizedFilePath
fp
parseAction CI String
"getmodsummary" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe ModSummaryResult -> Bool)
-> Maybe ModSummaryResult
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ModSummaryResult -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ModSummaryResult -> Either Text Bool)
-> Action (Maybe ModSummaryResult) -> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetModSummary
-> NormalizedFilePath -> Action (Maybe ModSummaryResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummary
GetModSummary NormalizedFilePath
fp
parseAction CI String
"getmodsummarywithouttimestamps" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe ModSummaryResult -> Bool)
-> Maybe ModSummaryResult
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ModSummaryResult -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ModSummaryResult -> Either Text Bool)
-> Action (Maybe ModSummaryResult) -> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetModSummaryWithoutTimestamps
-> NormalizedFilePath -> Action (Maybe ModSummaryResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
fp
parseAction CI String
"getparsedmodule" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe ParsedModule -> Bool)
-> Maybe ParsedModule
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ParsedModule -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ParsedModule -> Either Text Bool)
-> Action (Maybe ParsedModule) -> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetParsedModule
-> NormalizedFilePath -> Action (Maybe ParsedModule)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
fp
parseAction CI String
"ghcsession" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe HscEnvEq -> Bool) -> Maybe HscEnvEq -> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe HscEnvEq -> Bool
forall a. Maybe a -> Bool
isJust (Maybe HscEnvEq -> Either Text Bool)
-> Action (Maybe HscEnvEq) -> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSession -> NormalizedFilePath -> Action (Maybe HscEnvEq)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
fp
parseAction CI String
"ghcsessiondeps" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe HscEnvEq -> Bool) -> Maybe HscEnvEq -> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe HscEnvEq -> Bool
forall a. Maybe a -> Bool
isJust (Maybe HscEnvEq -> Either Text Bool)
-> Action (Maybe HscEnvEq) -> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GhcSessionDeps -> NormalizedFilePath -> Action (Maybe HscEnvEq)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSessionDeps
GhcSessionDeps NormalizedFilePath
fp
parseAction CI String
"gethieast" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe HieAstResult -> Bool)
-> Maybe HieAstResult
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe HieAstResult -> Bool
forall a. Maybe a -> Bool
isJust (Maybe HieAstResult -> Either Text Bool)
-> Action (Maybe HieAstResult) -> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetHieAst -> NormalizedFilePath -> Action (Maybe HieAstResult)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetHieAst
GetHieAst NormalizedFilePath
fp
parseAction CI String
"getFileContents" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe (FileVersion, Maybe Text) -> Bool)
-> Maybe (FileVersion, Maybe Text)
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (FileVersion, Maybe Text) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (FileVersion, Maybe Text) -> Either Text Bool)
-> Action (Maybe (FileVersion, Maybe Text))
-> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetFileContents
-> NormalizedFilePath -> Action (Maybe (FileVersion, Maybe Text))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetFileContents
GetFileContents NormalizedFilePath
fp
parseAction CI String
other NormalizedFilePath
_ = Either Text Bool -> Action (Either Text Bool)
forall a. a -> Action a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Text Bool -> Action (Either Text Bool))
-> Either Text Bool -> Action (Either Text Bool)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text Bool
forall a b. a -> Either a b
Left (Text -> Either Text Bool) -> Text -> Either Text Bool
forall a b. (a -> b) -> a -> b
$ Text
"Cannot parse ide rule: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (CI String -> String
forall s. CI s -> s
original CI String
other)
blockCommandId :: Text
blockCommandId :: Text
blockCommandId = Text
"ghcide.command.block"
blockCommandDescriptor :: PluginId -> PluginDescriptor state
blockCommandDescriptor :: forall state. PluginId -> PluginDescriptor state
blockCommandDescriptor PluginId
plId = (PluginId -> Text -> PluginDescriptor state
forall ideState. PluginId -> Text -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId Text
"") {
pluginCommands = [PluginCommand (CommandId blockCommandId) "blocks forever" blockCommandHandler]
}
blockCommandHandler :: CommandFunction state ExecuteCommandParams
blockCommandHandler :: forall state. CommandFunction state ExecuteCommandParams
blockCommandHandler state
_ideState Maybe ProgressToken
_ ExecuteCommandParams
_params = do
HandlerM Config () -> ExceptT PluginError (HandlerM Config) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT PluginError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (HandlerM Config () -> ExceptT PluginError (HandlerM Config) ())
-> HandlerM Config () -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ SServerMethod ('Method_CustomMethod "ghcide/blocking/command")
-> MessageParams ('Method_CustomMethod "ghcide/blocking/command")
-> HandlerM Config ()
forall (m :: Method 'ServerToClient 'Notification) config.
SServerMethod m -> MessageParams m -> HandlerM config ()
pluginSendNotification (Proxy "ghcide/blocking/command"
-> SServerMethod ('Method_CustomMethod "ghcide/blocking/command")
forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
forall (t :: Symbol). Proxy t
Proxy @"ghcide/blocking/command")) Value
MessageParams ('Method_CustomMethod "ghcide/blocking/command")
A.Null
IO () -> ExceptT PluginError (HandlerM Config) ()
forall a. IO a -> ExceptT PluginError (HandlerM Config) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT PluginError (HandlerM Config) ())
-> IO () -> ExceptT PluginError (HandlerM Config) ()
forall a b. (a -> b) -> a -> b
$ Age -> IO ()
threadDelay Age
forall a. Bounded a => a
maxBound
(Value |? Null)
-> ExceptT PluginError (HandlerM Config) (Value |? Null)
forall a. a -> ExceptT PluginError (HandlerM Config) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Value |? Null)
-> ExceptT PluginError (HandlerM Config) (Value |? Null))
-> (Value |? Null)
-> ExceptT PluginError (HandlerM Config) (Value |? Null)
forall a b. (a -> b) -> a -> b
$ Null -> Value |? Null
forall a b. b -> a |? b
InR Null
Null