{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
-- | A plugin that adds custom messages for use in tests

module Development.IDE.Plugin.Test
  ( TestRequest(..)
  , WaitForIdeRuleResult(..)
  , plugin
  , blockCommandDescriptor
  , blockCommandId
  ) where

import Control.Monad.STM
import Data.Aeson
import Data.Aeson.Types
import Data.CaseInsensitive (CI, original)
import Development.IDE.Core.Service
import Development.IDE.Core.Shake
import Development.IDE.GHC.Compat
import Development.IDE.GHC.Util (HscEnvEq(hscEnv))
import Development.IDE.LSP.Server
import Development.IDE.Plugin
import Development.IDE.Types.Action
import GHC.Generics (Generic)
import GhcPlugins (HscEnv(hsc_dflags))
import Language.Haskell.LSP.Core
import Language.Haskell.LSP.Messages
import Language.Haskell.LSP.Types
import System.Time.Extra
import Development.IDE.Core.RuleTypes
import Control.Monad
import Development.Shake (Action)
import Data.Maybe (isJust)
import Data.Bifunctor
import Data.Text (pack, Text)
import Data.String
import Development.IDE.Types.Location (fromUri)
import Control.Concurrent (threadDelay)
import Ide.Types
import qualified Language.Haskell.LSP.Core as LSP

data TestRequest
    = BlockSeconds Seconds           -- ^ :: Null

    | GetInterfaceFilesDir FilePath  -- ^ :: String

    | GetShakeSessionQueueCount      -- ^ :: Number

    | WaitForShakeQueue -- ^ Block until the Shake queue is empty. Returns Null

    | WaitForIdeRule String Uri      -- ^ :: WaitForIdeRuleResult

    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 :: Plugin c
plugin :: Plugin c
plugin = Plugin :: forall c. Rules () -> PartialHandlers c -> Plugin c
Plugin {
    pluginRules :: Rules ()
pluginRules = () -> Rules ()
forall (m :: * -> *) a. Monad m => a -> m a
return (),
    pluginHandler :: PartialHandlers c
pluginHandler = (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall c.
(WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
PartialHandlers ((WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c)
-> (WithMessage c -> Handlers -> IO Handlers) -> PartialHandlers c
forall a b. (a -> b) -> a -> b
$ \WithMessage{(LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
forall m req.
(Show m, Show req, HasTracing req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs c -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs c
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
 HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs c
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
$sel:withInitialize:WithMessage :: forall c.
WithMessage c
-> (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
$sel:withResponseAndRequest:WithMessage :: forall c.
WithMessage c
-> forall m rm req resp newReqParams newReqBody.
   (Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
    HasTracing req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState
       -> req
       -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
   -> Maybe (Handler (RequestMessage m req resp))
$sel:withNotification:WithMessage :: forall c.
WithMessage c
-> forall m req.
   (Show m, Show req, HasTracing req) =>
   Maybe (Handler (NotificationMessage m req))
   -> (LspFuncs c -> IdeState -> req -> IO ())
   -> Maybe (Handler (NotificationMessage m req))
$sel:withResponse:WithMessage :: forall c.
WithMessage c
-> forall m req resp.
   (Show m, Show req, HasTracing req) =>
   (ResponseMessage resp -> FromServerMessage)
   -> (LspFuncs c
       -> IdeState -> req -> IO (Either ResponseError resp))
   -> Maybe (Handler (RequestMessage m req resp))
withInitialize :: (LspFuncs c -> IdeState -> InitializeParams -> IO ())
-> Maybe (Handler InitializeRequest)
withResponseAndRequest :: forall m rm req resp newReqParams newReqBody.
(Show m, Show rm, Show req, Show newReqParams, Show newReqBody,
 HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (RequestMessage rm newReqParams newReqBody -> FromServerMessage)
-> (LspFuncs c
    -> IdeState
    -> req
    -> IO (Either ResponseError resp, Maybe (rm, newReqParams)))
-> Maybe (Handler (RequestMessage m req resp))
withNotification :: forall m req.
(Show m, Show req, HasTracing req) =>
Maybe (Handler (NotificationMessage m req))
-> (LspFuncs c -> IdeState -> req -> IO ())
-> Maybe (Handler (NotificationMessage m req))
withResponse :: forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs c
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
..} Handlers
x -> Handlers -> IO Handlers
forall (m :: * -> *) a. Monad m => a -> m a
return Handlers
x {
        customRequestHandler :: Maybe (Handler CustomClientRequest)
customRequestHandler = (ResponseMessage Value -> FromServerMessage)
-> (LspFuncs c
    -> IdeState -> Value -> IO (Either ResponseError Value))
-> Maybe (Handler CustomClientRequest)
forall m req resp.
(Show m, Show req, HasTracing req) =>
(ResponseMessage resp -> FromServerMessage)
-> (LspFuncs c
    -> IdeState -> req -> IO (Either ResponseError resp))
-> Maybe (Handler (RequestMessage m req resp))
withResponse ResponseMessage Value -> FromServerMessage
RspCustomServer LspFuncs c -> IdeState -> Value -> IO (Either ResponseError Value)
forall c.
LspFuncs c -> IdeState -> Value -> IO (Either ResponseError Value)
requestHandler'
    }
}
  where
      requestHandler' :: LspFuncs c -> IdeState -> Value -> IO (Either ResponseError Value)
requestHandler' LspFuncs c
lsp 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
        = LspFuncs c
-> IdeState -> TestRequest -> IO (Either ResponseError Value)
forall c.
LspFuncs c
-> IdeState -> TestRequest -> IO (Either ResponseError Value)
requestHandler LspFuncs c
lsp IdeState
ide TestRequest
customReq
        | Bool
otherwise
        = 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
$ 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

requestHandler :: LspFuncs c
                -> IdeState
                -> TestRequest
                -> IO (Either ResponseError Value)
requestHandler :: LspFuncs c
-> IdeState -> TestRequest -> IO (Either ResponseError Value)
requestHandler LspFuncs c
lsp IdeState
_ (BlockSeconds Seconds
secs) = do
    LspFuncs c -> SendFunc
forall c. LspFuncs c -> SendFunc
sendFunc LspFuncs c
lsp SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ CustomServerNotification -> FromServerMessage
NotCustomServer (CustomServerNotification -> FromServerMessage)
-> CustomServerNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
        Text -> ServerMethod -> Value -> CustomServerNotification
forall m a. Text -> m -> a -> NotificationMessage m a
NotificationMessage Text
"2.0" (Text -> ServerMethod
CustomServerMethod Text
"ghcide/blocking/request") (Value -> CustomServerNotification)
-> Value -> CustomServerNotification
forall a b. (a -> b) -> a -> b
$
        Seconds -> Value
forall a. ToJSON a => a -> Value
toJSON Seconds
secs
    Seconds -> IO ()
sleep Seconds
secs
    Either ResponseError Value -> IO (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)
requestHandler LspFuncs c
_ IdeState
s (GetInterfaceFilesDir FilePath
fp) = do
    let nfp :: NormalizedFilePath
nfp = FilePath -> NormalizedFilePath
toNormalizedFilePath FilePath
fp
    HscEnvEq
sess <- FilePath -> IdeState -> Action HscEnvEq -> IO HscEnvEq
forall a. FilePath -> IdeState -> Action a -> IO a
runAction FilePath
"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 FilePath
hiPath = DynFlags -> Maybe FilePath
hiDir (DynFlags -> Maybe FilePath) -> DynFlags -> Maybe FilePath
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 FilePath -> Value
forall a. ToJSON a => a -> Value
toJSON Maybe FilePath
hiPath)
requestHandler LspFuncs c
_ IdeState
s TestRequest
GetShakeSessionQueueCount = 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)
requestHandler LspFuncs c
_ IdeState
s TestRequest
WaitForShakeQueue = 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
requestHandler LspFuncs c
_ IdeState
s (WaitForIdeRule FilePath
k Uri
file) = 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 <- FilePath
-> IdeState -> Action (Either Text Bool) -> IO (Either Text Bool)
forall a. FilePath -> IdeState -> Action a -> IO a
runAction (FilePath
"WaitForIdeRule " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
k FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Uri -> FilePath
forall a. Show a => a -> FilePath
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 FilePath -> NormalizedFilePath -> Action (Either Text Bool)
parseAction (FilePath -> CI FilePath
forall a. IsString a => FilePath -> a
fromString FilePath
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

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 FilePath -> NormalizedFilePath -> Action (Either Text Bool)
parseAction CI FilePath
"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 FilePath
"getLocatedImports" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe
      ([(Located ModuleName, Maybe ArtifactsLocation)],
       Set InstalledUnitId)
    -> Bool)
-> Maybe
     ([(Located ModuleName, Maybe ArtifactsLocation)],
      Set InstalledUnitId)
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe
  ([(Located ModuleName, Maybe ArtifactsLocation)],
   Set InstalledUnitId)
-> Bool
forall a. Maybe a -> Bool
isJust (Maybe
   ([(Located ModuleName, Maybe ArtifactsLocation)],
    Set InstalledUnitId)
 -> Either Text Bool)
-> Action
     (Maybe
        ([(Located ModuleName, Maybe ArtifactsLocation)],
         Set InstalledUnitId))
-> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetLocatedImports
-> NormalizedFilePath
-> Action
     (Maybe
        ([(Located ModuleName, Maybe ArtifactsLocation)],
         Set InstalledUnitId))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetLocatedImports
GetLocatedImports NormalizedFilePath
fp
parseAction CI FilePath
"getmodsummary" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe (ModSummary, [LImportDecl GhcPs]) -> Bool)
-> Maybe (ModSummary, [LImportDecl GhcPs])
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (ModSummary, [LImportDecl GhcPs]) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ModSummary, [LImportDecl GhcPs]) -> Either Text Bool)
-> Action (Maybe (ModSummary, [LImportDecl GhcPs]))
-> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetModSummary
-> NormalizedFilePath
-> Action (Maybe (ModSummary, [LImportDecl GhcPs]))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummary
GetModSummary NormalizedFilePath
fp
parseAction CI FilePath
"getmodsummarywithouttimestamps" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe (ModSummary, [LImportDecl GhcPs]) -> Bool)
-> Maybe (ModSummary, [LImportDecl GhcPs])
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (ModSummary, [LImportDecl GhcPs]) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (ModSummary, [LImportDecl GhcPs]) -> Either Text Bool)
-> Action (Maybe (ModSummary, [LImportDecl GhcPs]))
-> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetModSummaryWithoutTimestamps
-> NormalizedFilePath
-> Action (Maybe (ModSummary, [LImportDecl GhcPs]))
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetModSummaryWithoutTimestamps
GetModSummaryWithoutTimestamps NormalizedFilePath
fp
parseAction CI FilePath
"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 FilePath
"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 FilePath
"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 FilePath
"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 FilePath
"getDependencies" NormalizedFilePath
fp = Bool -> Either Text Bool
forall a b. b -> Either a b
Right (Bool -> Either Text Bool)
-> (Maybe TransitiveDependencies -> Bool)
-> Maybe TransitiveDependencies
-> Either Text Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe TransitiveDependencies -> Bool
forall a. Maybe a -> Bool
isJust (Maybe TransitiveDependencies -> Either Text Bool)
-> Action (Maybe TransitiveDependencies)
-> Action (Either Text Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetDependencies
-> NormalizedFilePath -> Action (Maybe TransitiveDependencies)
forall k v.
IdeRule k v =>
k -> NormalizedFilePath -> Action (Maybe v)
use GetDependencies
GetDependencies NormalizedFilePath
fp
parseAction CI FilePath
"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 FilePath
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
<> FilePath -> Text
pack (CI FilePath -> FilePath
forall s. CI s -> s
original CI FilePath
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 LspFuncs Config
lsp state
_ideState ExecuteCommandParams
_params
    = do
        LspFuncs Config -> SendFunc
forall c. LspFuncs c -> SendFunc
LSP.sendFunc LspFuncs Config
lsp SendFunc -> SendFunc
forall a b. (a -> b) -> a -> b
$ CustomServerNotification -> FromServerMessage
NotCustomServer (CustomServerNotification -> FromServerMessage)
-> CustomServerNotification -> FromServerMessage
forall a b. (a -> b) -> a -> b
$
            Text -> ServerMethod -> Value -> CustomServerNotification
forall m a. Text -> m -> a -> NotificationMessage m a
NotificationMessage Text
"2.0" (Text -> ServerMethod
CustomServerMethod Text
"ghcide/blocking/command") Value
Null
        Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
        (Either ResponseError Value,
 Maybe (ServerMethod, ApplyWorkspaceEditParams))
-> IO
     (Either ResponseError Value,
      Maybe (ServerMethod, ApplyWorkspaceEditParams))
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Either ResponseError Value
forall a b. b -> Either a b
Right Value
Null, Maybe (ServerMethod, ApplyWorkspaceEditParams)
forall a. Maybe a
Nothing)