{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GADTs              #-}
{-# LANGUAGE PackageImports     #-}
{-# LANGUAGE PolyKinds          #-}
-- | A plugin that adds custom messages for use in tests
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 Language.LSP.Server                  as LSP
import qualified "list-t" ListT
import qualified StmContainers.Map                    as STM
import           System.Time.Extra

type Age = Int
data TestRequest
    = BlockSeconds Seconds           -- ^ :: Null
    | GetInterfaceFilesDir Uri       -- ^ :: String
    | GetShakeSessionQueueCount      -- ^ :: Number
    | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null
    | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult
    | GetBuildKeysVisited        -- ^ :: [(String]
    | GetBuildKeysBuilt          -- ^ :: [(String]
    | GetBuildKeysChanged        -- ^ :: [(String]
    | GetBuildEdgesCount         -- ^ :: Int
    | GarbageCollectDirtyKeys CheckParents Age    -- ^ :: [String] (list of keys collected)
    | GetStoredKeys                  -- ^ :: [String] (list of keys in store)
    | GetFilesOfInterest             -- ^ :: [FilePath]
    | GetRebuildsCount               -- ^ :: Int (number of times we recompiled with GHC)
    deriving 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
$cto :: forall x. Rep TestRequest x -> TestRequest
$cfrom :: forall x. TestRequest -> Rep TestRequest x
Generic
    deriving anyclass (Value -> Parser [TestRequest]
Value -> Parser TestRequest
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TestRequest]
$cparseJSONList :: Value -> Parser [TestRequest]
parseJSON :: Value -> Parser TestRequest
$cparseJSON :: Value -> Parser TestRequest
FromJSON, [TestRequest] -> Encoding
[TestRequest] -> Value
TestRequest -> Encoding
TestRequest -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TestRequest] -> Encoding
$ctoEncodingList :: [TestRequest] -> Encoding
toJSONList :: [TestRequest] -> Value
$ctoJSONList :: [TestRequest] -> Value
toEncoding :: TestRequest -> Encoding
$ctoEncoding :: TestRequest -> Encoding
toJSON :: TestRequest -> Value
$ctoJSON :: TestRequest -> Value
ToJSON)

newtype WaitForIdeRuleResult = WaitForIdeRuleResult { WaitForIdeRuleResult -> Bool
ideResultSuccess::Bool}
    deriving newtype (Value -> Parser [WaitForIdeRuleResult]
Value -> Parser WaitForIdeRuleResult
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [WaitForIdeRuleResult]
$cparseJSONList :: Value -> Parser [WaitForIdeRuleResult]
parseJSON :: Value -> Parser WaitForIdeRuleResult
$cparseJSON :: Value -> Parser WaitForIdeRuleResult
FromJSON, [WaitForIdeRuleResult] -> Encoding
[WaitForIdeRuleResult] -> Value
WaitForIdeRuleResult -> Encoding
WaitForIdeRuleResult -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [WaitForIdeRuleResult] -> Encoding
$ctoEncodingList :: [WaitForIdeRuleResult] -> Encoding
toJSONList :: [WaitForIdeRuleResult] -> Value
$ctoJSONList :: [WaitForIdeRuleResult] -> Value
toEncoding :: WaitForIdeRuleResult -> Encoding
$ctoEncoding :: WaitForIdeRuleResult -> Encoding
toJSON :: WaitForIdeRuleResult -> Value
$ctoJSON :: WaitForIdeRuleResult -> Value
ToJSON)

plugin :: PluginDescriptor IdeState
plugin :: PluginDescriptor IdeState
plugin = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
"test") {
    $sel:pluginHandlers:PluginDescriptor :: PluginHandlers IdeState
pluginHandlers = forall ideState (m :: Method 'ClientToServer 'Request).
PluginRequestMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"test")) forall a b. (a -> b) -> a -> b
$ \IdeState
st PluginId
_ ->
        forall {c}.
IdeState -> Value -> ExceptT PluginError (LspT c IO) Value
testRequestHandler' IdeState
st
    }
  where
      testRequestHandler' :: IdeState -> Value -> ExceptT PluginError (LspT c IO) Value
testRequestHandler' IdeState
ide Value
req
        | Just TestRequest
customReq <- forall a b. (a -> Parser b) -> a -> Maybe b
A.parseMaybe forall a. FromJSON a => Value -> Parser a
parseJSON Value
req
        = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ forall c.
IdeState -> TestRequest -> LspM c (Either PluginError Value)
testRequestHandler IdeState
ide TestRequest
customReq
        | Bool
otherwise
        = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        forall a b. (a -> b) -> a -> b
$ Text -> PluginError
PluginInvalidParams Text
"Cannot parse request"


testRequestHandler ::  IdeState
                -> TestRequest
                -> LSP.LspM c (Either PluginError Value)
testRequestHandler :: forall c.
IdeState -> TestRequest -> LspM c (Either PluginError Value)
testRequestHandler IdeState
_ (BlockSeconds Seconds
secs) = do
    forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"ghcide/blocking/request")) forall a b. (a -> b) -> a -> b
$
      forall a. ToJSON a => a -> Value
toJSON Seconds
secs
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
secs
    forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Value
A.Null)
testRequestHandler IdeState
s (GetInterfaceFilesDir Uri
file) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let nfp :: NormalizedFilePath
nfp = NormalizedUri -> NormalizedFilePath
fromUri forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
file
    HscEnvEq
sess <- forall a. String -> IdeState -> Action a -> IO a
runAction String
"Test - GhcSession" IdeState
s forall a b. (a -> b) -> a -> b
$ forall k v. IdeRule k v => k -> NormalizedFilePath -> Action v
use_ GhcSession
GhcSession NormalizedFilePath
nfp
    let hiPath :: Maybe String
hiPath = DynFlags -> Maybe String
hiDir forall a b. (a -> b) -> a -> b
$ HscEnv -> DynFlags
hsc_dflags forall a b. (a -> b) -> a -> b
$ HscEnvEq -> HscEnv
hscEnv HscEnvEq
sess
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall a. ToJSON a => a -> Value
toJSON Maybe String
hiPath)
testRequestHandler IdeState
s TestRequest
GetShakeSessionQueueCount = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Natural
n <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ ActionQueue -> STM Natural
countQueue forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ActionQueue
actionQueue forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (forall a. ToJSON a => a -> Value
toJSON Natural
n)
testRequestHandler IdeState
s TestRequest
WaitForShakeQueue = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
        Natural
n <- ActionQueue -> STM Natural
countQueue forall a b. (a -> b) -> a -> b
$ ShakeExtras -> ActionQueue
actionQueue forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
s
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Natural
nforall a. Ord a => a -> a -> Bool
>Natural
0) forall a. STM a
retry
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right Value
A.Null
testRequestHandler IdeState
s (WaitForIdeRule String
k Uri
file) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    let nfp :: NormalizedFilePath
nfp = NormalizedUri -> NormalizedFilePath
fromUri forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri Uri
file
    Either Text Bool
success <- forall a. String -> IdeState -> Action a -> IO a
runAction (String
"WaitForIdeRule " forall a. Semigroup a => a -> a -> a
<> String
k forall a. Semigroup a => a -> a -> a
<> String
" " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Uri
file) IdeState
s forall a b. (a -> b) -> a -> b
$ CI String -> NormalizedFilePath -> Action (Either Text Bool)
parseAction (forall a. IsString a => String -> a
fromString String
k) NormalizedFilePath
nfp
    let res :: Either Text WaitForIdeRuleResult
res = Bool -> WaitForIdeRuleResult
WaitForIdeRuleResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text Bool
success
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> PluginError
PluginInvalidParams forall a. ToJSON a => a -> Value
toJSON Either Text WaitForIdeRuleResult
res
testRequestHandler IdeState
s TestRequest
GetBuildKeysBuilt = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [Key]
keys <- (Result -> Step) -> ShakeDatabase -> IO [Key]
getDatabaseKeys Result -> Step
resultBuilt forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetBuildKeysChanged = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [Key]
keys <- (Result -> Step) -> ShakeDatabase -> IO [Key]
getDatabaseKeys Result -> Step
resultChanged forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetBuildKeysVisited = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    [Key]
keys <- (Result -> Step) -> ShakeDatabase -> IO [Key]
getDatabaseKeys Result -> Step
resultVisited forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetBuildEdgesCount = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
    Age
count <- ShakeDatabase -> IO Age
shakeGetBuildEdges forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON Age
count
testRequestHandler IdeState
s (GarbageCollectDirtyKeys CheckParents
parents Age
age) = do
    [Key]
res <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"garbage collect dirty" IdeState
s forall a b. (a -> b) -> a -> b
$ Age -> CheckParents -> Action [Key]
garbageCollectDirtyKeysOlderThan Age
age CheckParents
parents
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Key]
res
testRequestHandler IdeState
s TestRequest
GetStoredKeys = do
    [Key]
keys <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => ListT m a -> m [a]
ListT.toList (forall key value. Map key value -> ListT STM (key, value)
STM.listT forall a b. (a -> b) -> a -> b
$ ShakeExtras -> Values
state forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeExtras
shakeExtras IdeState
s)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Key]
keys
testRequestHandler IdeState
s TestRequest
GetFilesOfInterest = do
    HashMap NormalizedFilePath FileOfInterestStatus
ff <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IdeState -> IO (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest IdeState
s
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map NormalizedFilePath -> String
fromNormalizedFilePath forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [k]
HM.keys HashMap NormalizedFilePath FileOfInterestStatus
ff
testRequestHandler IdeState
s TestRequest
GetRebuildsCount = do
    Age
count <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. String -> IdeState -> Action a -> IO a
runAction String
"get build count" IdeState
s Action Age
getRebuildCount
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ 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
    forall (m :: * -> *) a. Monad m => a -> m a
return [ Key
k | (Key
k, Result
res) <- [(Key, Result)]
keys, Result -> Step
field Result
res 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 = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use TypeCheck
TypeCheck NormalizedFilePath
fp
parseAction CI String
"getLocatedImports" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetLocatedImports
GetLocatedImports NormalizedFilePath
fp
parseAction CI String
"getmodsummary" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummary
GetModSummary NormalizedFilePath
fp
parseAction CI String
"getmodsummarywithouttimestamps" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
fp
parseAction CI String
"getparsedmodule" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetParsedModule
GetParsedModule NormalizedFilePath
fp
parseAction CI String
"ghcsession" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSession
GhcSession NormalizedFilePath
fp
parseAction CI String
"ghcsessiondeps" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GhcSessionDeps
GhcSessionDeps NormalizedFilePath
fp
parseAction CI String
"gethieast" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetHieAst
GetHieAst NormalizedFilePath
fp
parseAction CI String
"getFileContents" NormalizedFilePath
fp = forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetFileContents
GetFileContents NormalizedFilePath
fp
parseAction CI String
other NormalizedFilePath
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Cannot parse ide rule: " forall a. Semigroup a => a -> a -> a
<> String -> Text
pack (forall s. CI s -> s
original CI String
other)

-- | a command that blocks forever. Used for testing
blockCommandId :: Text
blockCommandId :: Text
blockCommandId = Text
"ghcide.command.block"

blockCommandDescriptor :: PluginId -> PluginDescriptor state
blockCommandDescriptor :: forall ideState. PluginId -> PluginDescriptor ideState
blockCommandDescriptor PluginId
plId = (forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
plId) {
    $sel:pluginCommands:PluginDescriptor :: [PluginCommand state]
pluginCommands = [forall ideState a.
FromJSON a =>
CommandId
-> Text -> CommandFunction ideState a -> PluginCommand ideState
PluginCommand (Text -> CommandId
CommandId Text
blockCommandId) Text
"blocks forever" forall state. CommandFunction state ExecuteCommandParams
blockCommandHandler]
}

blockCommandHandler :: CommandFunction state ExecuteCommandParams
blockCommandHandler :: forall state. CommandFunction state ExecuteCommandParams
blockCommandHandler state
_ideState ExecuteCommandParams
_params = do
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ServerToClient 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (forall {f :: MessageDirection} {t :: MessageKind} (s :: Symbol).
KnownSymbol s =>
Proxy s -> SMethod ('Method_CustomMethod s)
SMethod_CustomMethod (forall {k} (t :: k). Proxy t
Proxy @"ghcide/blocking/command")) Value
A.Null
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Age -> IO ()
threadDelay forall a. Bounded a => a
maxBound
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> a |? b
InR Null
Null