{-# 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.IO.Class
import           Control.Monad.STM
import           Data.Aeson
import           Data.Aeson.Types
import           Data.Bifunctor
import           Data.CaseInsensitive                 (CI, original)
import qualified Data.HashMap.Strict                  as HM
import           Data.Maybe                           (isJust)
import           Data.String
import           Data.Text                            (Text, pack)
import           Development.IDE.Core.OfInterest      (getFilesOfInterest)
import           Development.IDE.Core.RuleTypes
import           Development.IDE.Core.Service
import           Development.IDE.Core.Shake
import           Development.IDE.Core.Rules
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.Config                    (CheckParents)
import           Ide.Types
import qualified Language.LSP.Server                  as LSP
import           Language.LSP.Types
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. 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
$cto :: forall x. Rep TestRequest x -> TestRequest
$cfrom :: forall x. TestRequest -> Rep TestRequest x
Generic
    deriving anyclass (Value -> Parser [TestRequest]
Value -> Parser TestRequest
(Value -> Parser TestRequest)
-> (Value -> Parser [TestRequest]) -> FromJSON 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
(TestRequest -> Value)
-> (TestRequest -> Encoding)
-> ([TestRequest] -> Value)
-> ([TestRequest] -> Encoding)
-> ToJSON TestRequest
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
(Value -> Parser WaitForIdeRuleResult)
-> (Value -> Parser [WaitForIdeRuleResult])
-> FromJSON 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
(WaitForIdeRuleResult -> Value)
-> (WaitForIdeRuleResult -> Encoding)
-> ([WaitForIdeRuleResult] -> Value)
-> ([WaitForIdeRuleResult] -> Encoding)
-> ToJSON WaitForIdeRuleResult
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 = (PluginId -> PluginDescriptor IdeState
forall ideState. PluginId -> PluginDescriptor ideState
defaultPluginDescriptor PluginId
"test") {
    pluginHandlers :: PluginHandlers IdeState
pluginHandlers = SClientMethod 'CustomMethod
-> PluginMethodHandler IdeState 'CustomMethod
-> PluginHandlers IdeState
forall (m :: Method 'FromClient 'Request) ideState.
PluginMethod m =>
SClientMethod m
-> PluginMethodHandler ideState m -> PluginHandlers ideState
mkPluginHandler (Text -> SClientMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"test") (PluginMethodHandler IdeState 'CustomMethod
 -> PluginHandlers IdeState)
-> PluginMethodHandler IdeState 'CustomMethod
-> PluginHandlers IdeState
forall a b. (a -> b) -> a -> b
$ \IdeState
st PluginId
_ ->
        IdeState -> Value -> LspM Config (Either ResponseError Value)
forall c. IdeState -> Value -> LspM c (Either ResponseError Value)
testRequestHandler' IdeState
st
    }
  where
      testRequestHandler' :: IdeState -> Value -> LspM c (Either ResponseError Value)
testRequestHandler' IdeState
ide Value
req
        | Just TestRequest
customReq <- (Value -> Parser TestRequest) -> Value -> Maybe TestRequest
forall a b. (a -> Parser b) -> a -> Maybe b
parseMaybe Value -> Parser TestRequest
forall a. FromJSON a => Value -> Parser a
parseJSON Value
req
        = IdeState -> TestRequest -> LspM c (Either ResponseError Value)
forall c.
IdeState -> TestRequest -> LspM c (Either ResponseError Value)
testRequestHandler IdeState
ide TestRequest
customReq
        | Bool
otherwise
        = Either ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> LspM c (Either ResponseError Value))
-> Either ResponseError Value
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ ResponseError -> Either ResponseError Value
forall a b. a -> Either a b
Left
        (ResponseError -> Either ResponseError Value)
-> ResponseError -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$ ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidRequest Text
"Cannot parse request" Maybe Value
forall a. Maybe a
Nothing


testRequestHandler ::  IdeState
                -> TestRequest
                -> LSP.LspM c (Either ResponseError Value)
testRequestHandler :: IdeState -> TestRequest -> LspM c (Either ResponseError Value)
testRequestHandler IdeState
_ (BlockSeconds Seconds
secs) = do
    SServerMethod 'CustomMethod
-> MessageParams 'CustomMethod -> LspT c IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (Text -> SServerMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"ghcide/blocking/request") (MessageParams 'CustomMethod -> LspT c IO ())
-> MessageParams 'CustomMethod -> LspT c IO ()
forall a b. (a -> b) -> a -> b
$
      Seconds -> Value
forall a. ToJSON a => a -> Value
toJSON Seconds
secs
    IO () -> LspT c IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT c IO ()) -> IO () -> LspT c IO ()
forall a b. (a -> b) -> a -> b
$ Seconds -> IO ()
sleep Seconds
secs
    Either ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null)
testRequestHandler IdeState
s (GetInterfaceFilesDir Uri
file) = IO (Either ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError 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 ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError 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 ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError 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 ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError 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 ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError 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 ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null
testRequestHandler IdeState
s (WaitForIdeRule String
k Uri
file) = IO (Either ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError 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 ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ (Text -> ResponseError)
-> (WaitForIdeRuleResult -> Value)
-> Either Text WaitForIdeRuleResult
-> Either ResponseError Value
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap Text -> ResponseError
mkResponseError WaitForIdeRuleResult -> Value
forall a. ToJSON a => a -> Value
toJSON Either Text WaitForIdeRuleResult
res
testRequestHandler IdeState
s TestRequest
GetBuildKeysBuilt = IO (Either ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError 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 ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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 ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError 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 ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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 ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError 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 ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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 ResponseError Value)
-> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ResponseError Value)
 -> LspM c (Either ResponseError Value))
-> IO (Either ResponseError Value)
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ do
    Int
count <- ShakeDatabase -> IO Int
shakeGetBuildEdges (ShakeDatabase -> IO Int) -> ShakeDatabase -> IO Int
forall a b. (a -> b) -> a -> b
$ IdeState -> ShakeDatabase
shakeDb IdeState
s
    Either ResponseError Value -> IO (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> IO (Either ResponseError Value))
-> Either ResponseError Value -> IO (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
count
testRequestHandler IdeState
s (GarbageCollectDirtyKeys CheckParents
parents Int
age) = do
    [Key]
res <- IO [Key] -> LspT c IO [Key]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Key] -> LspT c IO [Key]) -> IO [Key] -> LspT c IO [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
$ Int -> CheckParents -> Action [Key]
garbageCollectDirtyKeysOlderThan Int
age CheckParents
parents
    Either ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> LspM c (Either ResponseError Value))
-> Either ResponseError Value
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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] -> LspT c IO [Key]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Key] -> LspT c IO [Key]) -> IO [Key] -> LspT c IO [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 ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> LspM c (Either ResponseError Value))
-> Either ResponseError Value
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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)
-> LspT c IO (HashMap NormalizedFilePath FileOfInterestStatus)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap NormalizedFilePath FileOfInterestStatus)
 -> LspT c IO (HashMap NormalizedFilePath FileOfInterestStatus))
-> IO (HashMap NormalizedFilePath FileOfInterestStatus)
-> LspT c IO (HashMap NormalizedFilePath FileOfInterestStatus)
forall a b. (a -> b) -> a -> b
$ IdeState -> IO (HashMap NormalizedFilePath FileOfInterestStatus)
getFilesOfInterest IdeState
s
    Either ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> LspM c (Either ResponseError Value))
-> Either ResponseError Value
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError 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
    Int
count <- IO Int -> LspT c IO Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> LspT c IO Int) -> IO Int -> LspT c IO Int
forall a b. (a -> b) -> a -> b
$ String -> IdeState -> Action Int -> IO Int
forall a. String -> IdeState -> Action a -> IO a
runAction String
"get build count" IdeState
s Action Int
getRebuildCount
    Either ResponseError Value -> LspM c (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError Value -> LspM c (Either ResponseError Value))
-> Either ResponseError Value
-> LspM c (Either ResponseError Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either ResponseError Value
forall a b. b -> Either a b
Right (Value -> Either ResponseError Value)
-> Value -> Either ResponseError Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
forall a. ToJSON a => a -> Value
toJSON Int
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
    Int
step <- ShakeDatabase -> IO Int
shakeGetBuildStep ShakeDatabase
db
    [Key] -> IO [Key]
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
== Int -> Step
Step Int
step]

mkResponseError :: Text -> ResponseError
mkResponseError :: Text -> ResponseError
mkResponseError Text
msg = ErrorCode -> Text -> Maybe Value -> ResponseError
ResponseError ErrorCode
InvalidRequest Text
msg Maybe Value
forall a. Maybe a
Nothing

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 (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)

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

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

blockCommandHandler :: CommandFunction state ExecuteCommandParams
blockCommandHandler :: CommandFunction state ExecuteCommandParams
blockCommandHandler state
_ideState ExecuteCommandParams
_params = do
  SServerMethod 'CustomMethod
-> MessageParams 'CustomMethod -> LspT Config IO ()
forall (m :: Method 'FromServer 'Notification) (f :: * -> *)
       config.
MonadLsp config f =>
SServerMethod m -> MessageParams m -> f ()
LSP.sendNotification (Text -> SServerMethod 'CustomMethod
forall (f :: From) (t :: MethodType). Text -> SMethod 'CustomMethod
SCustomMethod Text
"ghcide/blocking/command") Value
MessageParams 'CustomMethod
Null
  IO () -> LspT Config IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> LspT Config IO ()) -> IO () -> LspT Config IO ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
  Either ResponseError Value
-> LspM Config (Either ResponseError Value)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null)