-- Copyright (c) 2019 The DAML Authors. All rights reserved.
-- SPDX-License-Identifier: Apache-2.0

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs                 #-}

module Development.IDE.Test
  ( Cursor
  , cursorPosition
  , requireDiagnostic
  , diagnostic
  , expectDiagnostics
  , expectDiagnosticsWithTags
  , expectNoMoreDiagnostics
  , expectMessages
  , expectCurrentDiagnostics
  , checkDiagnosticsForDoc
  , canonicalizeUri
  , standardizeQuotes
  , flushMessages
  , waitForAction
  , getInterfaceFilesDir
  , garbageCollectDirtyKeys
  , getFilesOfInterest
  , waitForTypecheck
  , waitForBuildQueue
  , getStoredKeys
  , waitForCustomMessage
  , waitForGC
  , configureCheckProject
  , isReferenceReady
  , referenceReady) where

import           Control.Applicative.Combinators
import           Control.Lens                    hiding (List)
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Aeson                      (toJSON)
import qualified Data.Aeson                      as A
import           Data.Bifunctor                  (second)
import           Data.Default
import qualified Data.Map.Strict                 as Map
import           Data.Maybe                      (fromJust)
import           Data.Proxy
import           Data.Text                       (Text)
import qualified Data.Text                       as T
import           Development.IDE.Plugin.Test     (TestRequest (..),
                                                  WaitForIdeRuleResult,
                                                  ideResultSuccess)
import           Development.IDE.Test.Diagnostic
import           GHC.TypeLits                    (symbolVal)
import           Ide.Plugin.Config               (CheckParents, checkProject)
import qualified Language.LSP.Protocol.Lens      as L
import           Language.LSP.Protocol.Message
import           Language.LSP.Protocol.Types
import           Language.LSP.Test               hiding (message)
import qualified Language.LSP.Test               as LspTest
import           System.Directory                (canonicalizePath)
import           System.FilePath                 (equalFilePath)
import           System.Time.Extra
import           Test.Tasty.HUnit

requireDiagnosticM
    :: (Foldable f, Show (f Diagnostic), HasCallStack)
    => f Diagnostic
    -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)
    -> Assertion
requireDiagnosticM :: forall (f :: * -> *).
(Foldable f, Show (f Diagnostic), HasCallStack) =>
f Diagnostic
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Assertion
requireDiagnosticM f Diagnostic
actuals (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
expected = case f Diagnostic
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Maybe FilePath
forall (f :: * -> *).
(Foldable f, Show (f Diagnostic), HasCallStack) =>
f Diagnostic
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Maybe FilePath
requireDiagnostic f Diagnostic
actuals (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
expected of
    Maybe FilePath
Nothing  -> () -> Assertion
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just FilePath
err -> FilePath -> Assertion
forall a. HasCallStack => FilePath -> IO a
assertFailure FilePath
err

-- |wait for @timeout@ seconds and report an assertion failure
-- if any diagnostic messages arrive in that period
expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session ()
expectNoMoreDiagnostics :: HasCallStack => Seconds -> Session ()
expectNoMoreDiagnostics Seconds
timeout =
  SMethod 'Method_TextDocumentPublishDiagnostics
-> Seconds
-> (TServerMessage 'Method_TextDocumentPublishDiagnostics
    -> Session ())
-> Session ()
forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SMethod m
-> Seconds -> (TServerMessage m -> Session ()) -> Session ()
expectMessages SMethod 'Method_TextDocumentPublishDiagnostics
SMethod_TextDocumentPublishDiagnostics Seconds
timeout ((TServerMessage 'Method_TextDocumentPublishDiagnostics
  -> Session ())
 -> Session ())
-> (TServerMessage 'Method_TextDocumentPublishDiagnostics
    -> Session ())
-> Session ()
forall a b. (a -> b) -> a -> b
$ \TServerMessage 'Method_TextDocumentPublishDiagnostics
diagsNot -> do
    let fileUri :: Uri
fileUri = TNotificationMessage 'Method_TextDocumentPublishDiagnostics
TServerMessage 'Method_TextDocumentPublishDiagnostics
diagsNot TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Getting
     Uri
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Const
     Uri (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
  PublishDiagnosticsParams
L.params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
 -> Const
      Uri (TNotificationMessage 'Method_TextDocumentPublishDiagnostics))
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting
     Uri
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams
forall s a. HasUri s a => Lens' s a
Lens' PublishDiagnosticsParams Uri
L.uri
        actual :: [Diagnostic]
actual = TNotificationMessage 'Method_TextDocumentPublishDiagnostics
TServerMessage 'Method_TextDocumentPublishDiagnostics
diagsNot TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Getting
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     [Diagnostic]
-> [Diagnostic]
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const [Diagnostic] PublishDiagnosticsParams)
-> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Const
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
  PublishDiagnosticsParams
L.params ((PublishDiagnosticsParams
  -> Const [Diagnostic] PublishDiagnosticsParams)
 -> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
 -> Const
      [Diagnostic]
      (TNotificationMessage 'Method_TextDocumentPublishDiagnostics))
-> (([Diagnostic] -> Const [Diagnostic] [Diagnostic])
    -> PublishDiagnosticsParams
    -> Const [Diagnostic] PublishDiagnosticsParams)
-> Getting
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Diagnostic] -> Const [Diagnostic] [Diagnostic])
-> PublishDiagnosticsParams
-> Const [Diagnostic] PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
Lens' PublishDiagnosticsParams [Diagnostic]
L.diagnostics
    Bool -> Session () -> Session ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Diagnostic]
actual [Diagnostic] -> [Diagnostic] -> Bool
forall a. Eq a => a -> a -> Bool
== []) (Session () -> Session ()) -> Session () -> Session ()
forall a b. (a -> b) -> a -> b
$ Assertion -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Session ()) -> Assertion -> Session ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> Assertion
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> Assertion) -> FilePath -> Assertion
forall a b. (a -> b) -> a -> b
$
        FilePath
"Got unexpected diagnostics for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Uri -> FilePath
forall a. Show a => a -> FilePath
show Uri
fileUri
          FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" got "
          FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Diagnostic] -> FilePath
forall a. Show a => a -> FilePath
show [Diagnostic]
actual

expectMessages :: SMethod m -> Seconds -> (TServerMessage m -> Session ()) -> Session ()
expectMessages :: forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SMethod m
-> Seconds -> (TServerMessage m -> Session ()) -> Session ()
expectMessages SMethod m
m Seconds
timeout TServerMessage m -> Session ()
handle = do
    -- Give any further diagnostic messages time to arrive.
    Assertion -> Session ()
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> Session ()) -> Assertion -> Session ()
forall a b. (a -> b) -> a -> b
$ Seconds -> Assertion
sleep Seconds
timeout
    -- Send a dummy message to provoke a response from the server.
    -- This guarantees that we have at least one message to
    -- process, so message won't block or timeout.
    let cm :: SMethod ('Method_CustomMethod "test")
cm = Proxy "test" -> SMethod ('Method_CustomMethod "test")
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 @"test")
    LspId ('Method_CustomMethod "test")
i <- SClientMethod ('Method_CustomMethod "test")
-> MessageParams ('Method_CustomMethod "test")
-> Session (LspId ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm (MessageParams ('Method_CustomMethod "test")
 -> Session (LspId ('Method_CustomMethod "test")))
-> MessageParams ('Method_CustomMethod "test")
-> Session (LspId ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ TestRequest -> Value
forall a. ToJSON a => a -> Value
A.toJSON TestRequest
GetShakeSessionQueueCount
    SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test") -> Session ()
go SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
i
  where
    go :: SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test") -> Session ()
go SClientMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
i = Session ()
handleMessages
      where
        handleMessages :: Session ()
handleMessages = (SMethod m -> Session (TServerMessage m)
forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> Session (TMessage m)
LspTest.message SMethod m
m Session (TServerMessage m)
-> (TServerMessage m -> Session ()) -> Session ()
forall a b. Session a -> (a -> Session b) -> Session b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TServerMessage m -> Session ()
handle) Session () -> Session () -> Session ()
forall a. Session a -> Session a -> Session a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session ())
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session ()
forall a b. (a -> b) -> a -> b
$ SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test")
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SClientMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
i) Session () -> Session () -> Session ()
forall a. Session a -> Session a -> Session a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Session ()
ignoreOthers
        ignoreOthers :: Session ()
ignoreOthers = Session FromServerMessage -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Session FromServerMessage
anyMessage Session () -> Session () -> Session ()
forall a b. Session a -> Session b -> Session b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Session ()
handleMessages

flushMessages :: Session ()
flushMessages :: Session ()
flushMessages = do
    let cm :: SMethod ('Method_CustomMethod "non-existent-method")
cm = Proxy "non-existent-method"
-> SMethod ('Method_CustomMethod "non-existent-method")
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 @"non-existent-method")
    LspId ('Method_CustomMethod "non-existent-method")
i <- SClientMethod ('Method_CustomMethod "non-existent-method")
-> MessageParams ('Method_CustomMethod "non-existent-method")
-> Session (LspId ('Method_CustomMethod "non-existent-method"))
forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod ('Method_CustomMethod "non-existent-method")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "non-existent-method")
cm Value
MessageParams ('Method_CustomMethod "non-existent-method")
A.Null
    Session
  (TResponseMessage ('Method_CustomMethod "non-existent-method"))
-> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (SClientMethod ('Method_CustomMethod "non-existent-method")
-> LspId ('Method_CustomMethod "non-existent-method")
-> Session
     (TResponseMessage ('Method_CustomMethod "non-existent-method"))
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SClientMethod ('Method_CustomMethod "non-existent-method")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "non-existent-method")
cm LspId ('Method_CustomMethod "non-existent-method")
i) Session () -> Session () -> Session ()
forall a. Session a -> Session a -> Session a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> SClientMethod ('Method_CustomMethod "non-existent-method")
-> LspId ('Method_CustomMethod "non-existent-method") -> Session ()
forall {m :: Method 'ClientToServer 'Request}.
SMethod m -> LspId m -> Session ()
ignoreOthers SClientMethod ('Method_CustomMethod "non-existent-method")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "non-existent-method")
cm LspId ('Method_CustomMethod "non-existent-method")
i
    where
        ignoreOthers :: SMethod m -> LspId m -> Session ()
ignoreOthers SMethod m
cm LspId m
i = Session FromServerMessage
-> Session (TResponseMessage m) -> Session (TResponseMessage m)
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (SMethod m -> LspId m -> Session (TResponseMessage m)
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SMethod m
cm LspId m
i) Session (TResponseMessage m) -> Session () -> Session ()
forall a b. Session a -> Session b -> Session b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Session ()
flushMessages

-- | It is not possible to use 'expectDiagnostics []' to assert the absence of diagnostics,
--   only that existing diagnostics have been cleared.
--
--   Rather than trying to assert the absence of diagnostics, introduce an
--   expected diagnostic (e.g. a redundant import) and assert the singleton diagnostic.
expectDiagnostics :: HasCallStack => [(FilePath, [(DiagnosticSeverity, Cursor, T.Text)])] -> Session ()
expectDiagnostics :: HasCallStack =>
[(FilePath, [(DiagnosticSeverity, Cursor, Text)])] -> Session ()
expectDiagnostics
  = HasCallStack =>
[(FilePath,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
-> Session ()
[(FilePath,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
-> Session ()
expectDiagnosticsWithTags
  ([(FilePath,
   [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
 -> Session ())
-> ([(FilePath, [(DiagnosticSeverity, Cursor, Text)])]
    -> [(FilePath,
         [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])])
-> [(FilePath, [(DiagnosticSeverity, Cursor, Text)])]
-> Session ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, [(DiagnosticSeverity, Cursor, Text)])
 -> (FilePath,
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]))
-> [(FilePath, [(DiagnosticSeverity, Cursor, Text)])]
-> [(FilePath,
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
forall a b. (a -> b) -> [a] -> [b]
map (([(DiagnosticSeverity, Cursor, Text)]
 -> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
-> (FilePath, [(DiagnosticSeverity, Cursor, Text)])
-> (FilePath,
    [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (((DiagnosticSeverity, Cursor, Text)
 -> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag))
-> [(DiagnosticSeverity, Cursor, Text)]
-> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DiagnosticSeverity
ds, Cursor
c, Text
t) -> (DiagnosticSeverity
ds, Cursor
c, Text
t, Maybe DiagnosticTag
forall a. Maybe a
Nothing))))

unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics  -> (Uri, [Diagnostic])
unwrapDiagnostic :: TServerMessage 'Method_TextDocumentPublishDiagnostics
-> (Uri, [Diagnostic])
unwrapDiagnostic TServerMessage 'Method_TextDocumentPublishDiagnostics
diagsNot = (TNotificationMessage 'Method_TextDocumentPublishDiagnostics
TServerMessage 'Method_TextDocumentPublishDiagnostics
diagsNotTNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Getting
     Uri
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     Uri
-> Uri
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Const
     Uri (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
  PublishDiagnosticsParams
L.params ((PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
 -> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
 -> Const
      Uri (TNotificationMessage 'Method_TextDocumentPublishDiagnostics))
-> ((Uri -> Const Uri Uri)
    -> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams)
-> Getting
     Uri
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Uri -> Const Uri Uri)
-> PublishDiagnosticsParams -> Const Uri PublishDiagnosticsParams
forall s a. HasUri s a => Lens' s a
Lens' PublishDiagnosticsParams Uri
L.uri, TNotificationMessage 'Method_TextDocumentPublishDiagnostics
TServerMessage 'Method_TextDocumentPublishDiagnostics
diagsNotTNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Getting
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     [Diagnostic]
-> [Diagnostic]
forall s a. s -> Getting a s a -> a
^. (PublishDiagnosticsParams
 -> Const [Diagnostic] PublishDiagnosticsParams)
-> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> Const
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
forall s a. HasParams s a => Lens' s a
Lens'
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
  PublishDiagnosticsParams
L.params ((PublishDiagnosticsParams
  -> Const [Diagnostic] PublishDiagnosticsParams)
 -> TNotificationMessage 'Method_TextDocumentPublishDiagnostics
 -> Const
      [Diagnostic]
      (TNotificationMessage 'Method_TextDocumentPublishDiagnostics))
-> (([Diagnostic] -> Const [Diagnostic] [Diagnostic])
    -> PublishDiagnosticsParams
    -> Const [Diagnostic] PublishDiagnosticsParams)
-> Getting
     [Diagnostic]
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
     [Diagnostic]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Diagnostic] -> Const [Diagnostic] [Diagnostic])
-> PublishDiagnosticsParams
-> Const [Diagnostic] PublishDiagnosticsParams
forall s a. HasDiagnostics s a => Lens' s a
Lens' PublishDiagnosticsParams [Diagnostic]
L.diagnostics)

expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session ()
expectDiagnosticsWithTags :: HasCallStack =>
[(FilePath,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
-> Session ()
expectDiagnosticsWithTags [(FilePath,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
expected = do
    let f :: FilePath -> Session NormalizedUri
f = FilePath -> Session Uri
getDocUri (FilePath -> Session Uri)
-> (Uri -> Session NormalizedUri)
-> FilePath
-> Session NormalizedUri
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> IO Uri -> Session Uri
forall a. IO a -> Session a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Uri -> Session Uri) -> (Uri -> IO Uri) -> Uri -> Session Uri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> IO Uri
canonicalizeUri (Uri -> Session Uri)
-> (Uri -> Session NormalizedUri) -> Uri -> Session NormalizedUri
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> NormalizedUri -> Session NormalizedUri
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NormalizedUri -> Session NormalizedUri)
-> (Uri -> NormalizedUri) -> Uri -> Session NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> NormalizedUri
toNormalizedUri
        next :: Session (Uri, [Diagnostic])
next = TNotificationMessage 'Method_TextDocumentPublishDiagnostics
-> (Uri, [Diagnostic])
TServerMessage 'Method_TextDocumentPublishDiagnostics
-> (Uri, [Diagnostic])
unwrapDiagnostic (TNotificationMessage 'Method_TextDocumentPublishDiagnostics
 -> (Uri, [Diagnostic]))
-> Session
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
-> Session (Uri, [Diagnostic])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Session FromServerMessage
-> Session
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
-> Session
     (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
diagnostic
    Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected' <- ([(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
 -> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
 -> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
-> [(NormalizedUri,
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
forall a. Semigroup a => a -> a -> a
(<>) ([(NormalizedUri,
   [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
 -> Map
      NormalizedUri
      [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
-> Session
     [(NormalizedUri,
       [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
-> Session
     (Map
        NormalizedUri
        [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LensLike
  Session
  [(FilePath,
    [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
  [(NormalizedUri,
    [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
  FilePath
  NormalizedUri
-> LensLike
     Session
     [(FilePath,
       [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
     [(NormalizedUri,
       [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
     FilePath
     NormalizedUri
forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf (((FilePath,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
 -> Session
      (NormalizedUri,
       [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]))
-> [(FilePath,
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
-> Session
     [(NormalizedUri,
       [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (((FilePath,
   [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
  -> Session
       (NormalizedUri,
        [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]))
 -> [(FilePath,
      [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
 -> Session
      [(NormalizedUri,
        [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])])
-> ((FilePath -> Session NormalizedUri)
    -> (FilePath,
        [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
    -> Session
         (NormalizedUri,
          [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]))
-> LensLike
     Session
     [(FilePath,
       [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
     [(NormalizedUri,
       [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
     FilePath
     NormalizedUri
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> Session NormalizedUri)
-> (FilePath,
    [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
-> Session
     (NormalizedUri,
      [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (FilePath,
   [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
  (NormalizedUri,
   [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])
  FilePath
  NormalizedUri
_1) FilePath -> Session NormalizedUri
f [(FilePath,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
expected
    Session (Uri, [Diagnostic])
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> Session ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Uri, [Diagnostic])
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
expectDiagnosticsWithTags' Session (Uri, [Diagnostic])
next Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected'

expectDiagnosticsWithTags' ::
  (HasCallStack, MonadIO m) =>
  m (Uri, [Diagnostic]) ->
  Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] ->
  m ()
expectDiagnosticsWithTags' :: forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Uri, [Diagnostic])
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
expectDiagnosticsWithTags' m (Uri, [Diagnostic])
next Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m | Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> Bool
forall a. Map NormalizedUri a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m = do
    (Uri
_,[Diagnostic]
actual) <- m (Uri, [Diagnostic])
next
    case [Diagnostic]
actual of
        [] ->
            () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [Diagnostic]
_ ->
            Assertion -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> m ()) -> Assertion -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Assertion
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> Assertion) -> FilePath -> Assertion
forall a b. (a -> b) -> a -> b
$ FilePath
"Got unexpected diagnostics:" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Diagnostic] -> FilePath
forall a. Show a => a -> FilePath
show [Diagnostic]
actual

expectDiagnosticsWithTags' m (Uri, [Diagnostic])
next Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected = Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
go Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected
  where
    go :: Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
go Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m
      | Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> Bool
forall k a. Map k a -> Bool
Map.null Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
        (Uri
fileUri, [Diagnostic]
actual) <- m (Uri, [Diagnostic])
next
        NormalizedUri
canonUri <- IO NormalizedUri -> m NormalizedUri
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO NormalizedUri -> m NormalizedUri)
-> IO NormalizedUri -> m NormalizedUri
forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri (Uri -> NormalizedUri) -> IO Uri -> IO NormalizedUri
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> IO Uri
canonicalizeUri Uri
fileUri
        case NormalizedUri
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> Maybe [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup NormalizedUri
canonUri Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m of
          Maybe [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
Nothing -> do
            Assertion -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> m ()) -> Assertion -> m ()
forall a b. (a -> b) -> a -> b
$
              FilePath -> Assertion
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> Assertion) -> FilePath -> Assertion
forall a b. (a -> b) -> a -> b
$
                FilePath
"Got diagnostics for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Uri -> FilePath
forall a. Show a => a -> FilePath
show Uri
fileUri
                  FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" but only expected diagnostics for "
                  FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [NormalizedUri] -> FilePath
forall a. Show a => a -> FilePath
show (Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> [NormalizedUri]
forall k a. Map k a -> [k]
Map.keys Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m)
                  FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" got "
                  FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Diagnostic] -> FilePath
forall a. Show a => a -> FilePath
show [Diagnostic]
actual
          Just [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected -> do
            Assertion -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> m ()) -> Assertion -> m ()
forall a b. (a -> b) -> a -> b
$ ((DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
 -> Assertion)
-> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> Assertion
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Diagnostic]
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Assertion
forall (f :: * -> *).
(Foldable f, Show (f Diagnostic), HasCallStack) =>
f Diagnostic
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Assertion
requireDiagnosticM [Diagnostic]
actual) [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected
            Assertion -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Assertion -> m ()) -> Assertion -> m ()
forall a b. (a -> b) -> a -> b
$
              Bool -> Assertion -> Assertion
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Diagnostic] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Diagnostic]
actual) (Assertion -> Assertion) -> Assertion -> Assertion
forall a b. (a -> b) -> a -> b
$
                FilePath -> Assertion
forall a. HasCallStack => FilePath -> IO a
assertFailure (FilePath -> Assertion) -> FilePath -> Assertion
forall a b. (a -> b) -> a -> b
$
                  FilePath
"Incorrect number of diagnostics for " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Uri -> FilePath
forall a. Show a => a -> FilePath
show Uri
fileUri
                    FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
", expected "
                    FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> FilePath
forall a. Show a => a -> FilePath
show [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected
                    FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" but got "
                    FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> [Diagnostic] -> FilePath
forall a. Show a => a -> FilePath
show [Diagnostic]
actual
            Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
go (Map
   NormalizedUri
   [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
 -> m ())
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
forall a b. (a -> b) -> a -> b
$ NormalizedUri
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete NormalizedUri
canonUri Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m

expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session ()
expectCurrentDiagnostics :: HasCallStack =>
TextDocumentIdentifier
-> [(DiagnosticSeverity, Cursor, Text)] -> Session ()
expectCurrentDiagnostics TextDocumentIdentifier
doc [(DiagnosticSeverity, Cursor, Text)]
expected = do
    [Diagnostic]
diags <- TextDocumentIdentifier -> Session [Diagnostic]
getCurrentDiagnostics TextDocumentIdentifier
doc
    HasCallStack =>
TextDocumentIdentifier
-> [(DiagnosticSeverity, Cursor, Text)]
-> [Diagnostic]
-> Session ()
TextDocumentIdentifier
-> [(DiagnosticSeverity, Cursor, Text)]
-> [Diagnostic]
-> Session ()
checkDiagnosticsForDoc TextDocumentIdentifier
doc [(DiagnosticSeverity, Cursor, Text)]
expected [Diagnostic]
diags

checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session ()
checkDiagnosticsForDoc :: HasCallStack =>
TextDocumentIdentifier
-> [(DiagnosticSeverity, Cursor, Text)]
-> [Diagnostic]
-> Session ()
checkDiagnosticsForDoc TextDocumentIdentifier {Uri
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} [(DiagnosticSeverity, Cursor, Text)]
expected [Diagnostic]
obtained = do
    let expected' :: Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected' = [(NormalizedUri,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(NormalizedUri
nuri, ((DiagnosticSeverity, Cursor, Text)
 -> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag))
-> [(DiagnosticSeverity, Cursor, Text)]
-> [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
forall a b. (a -> b) -> [a] -> [b]
map (\(DiagnosticSeverity
ds, Cursor
c, Text
t) -> (DiagnosticSeverity
ds, Cursor
c, Text
t, Maybe DiagnosticTag
forall a. Maybe a
Nothing)) [(DiagnosticSeverity, Cursor, Text)]
expected)]
        nuri :: NormalizedUri
nuri = Uri -> NormalizedUri
toNormalizedUri Uri
_uri
    Session (Uri, [Diagnostic])
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> Session ()
forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Uri, [Diagnostic])
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
expectDiagnosticsWithTags' ((Uri, [Diagnostic]) -> Session (Uri, [Diagnostic])
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Uri
_uri, [Diagnostic]
obtained)) Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected'

canonicalizeUri :: Uri -> IO Uri
canonicalizeUri :: Uri -> IO Uri
canonicalizeUri Uri
uri = FilePath -> Uri
filePathToUri (FilePath -> Uri) -> IO FilePath -> IO Uri
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
canonicalizePath (Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust (Uri -> Maybe FilePath
uriToFilePath Uri
uri))

diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics)
diagnostic :: Session
  (TNotificationMessage 'Method_TextDocumentPublishDiagnostics)
diagnostic = SMethod 'Method_TextDocumentPublishDiagnostics
-> Session (TServerMessage 'Method_TextDocumentPublishDiagnostics)
forall {t :: MessageKind} (m :: Method 'ServerToClient t).
SServerMethod m -> Session (TMessage m)
LspTest.message SMethod 'Method_TextDocumentPublishDiagnostics
SMethod_TextDocumentPublishDiagnostics

tryCallTestPlugin :: (A.FromJSON b) => TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin :: forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
cmd = do
    let cm :: SMethod ('Method_CustomMethod "test")
cm = Proxy "test" -> SMethod ('Method_CustomMethod "test")
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 @"test")
    LspId ('Method_CustomMethod "test")
waitId <- SClientMethod ('Method_CustomMethod "test")
-> MessageParams ('Method_CustomMethod "test")
-> Session (LspId ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm (TestRequest -> Value
forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    TResponseMessage{Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result :: Either ResponseError (MessageResult ('Method_CustomMethod "test"))
$sel:_result:TResponseMessage :: forall (f :: MessageDirection) (m :: Method f 'Request).
TResponseMessage m -> Either ResponseError (MessageResult m)
_result} <- Session FromServerMessage
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session (TResponseMessage ('Method_CustomMethod "test"))
 -> Session (TResponseMessage ('Method_CustomMethod "test")))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall a b. (a -> b) -> a -> b
$ SClientMethod ('Method_CustomMethod "test")
-> LspId ('Method_CustomMethod "test")
-> Session (TResponseMessage ('Method_CustomMethod "test"))
forall (m :: Method 'ClientToServer 'Request).
SMethod m -> LspId m -> Session (TResponseMessage m)
responseForId SClientMethod ('Method_CustomMethod "test")
forall {f :: MessageDirection} {t :: MessageKind}.
SMethod ('Method_CustomMethod "test")
cm LspId ('Method_CustomMethod "test")
waitId
    Either ResponseError b -> Session (Either ResponseError b)
forall a. a -> Session a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ResponseError b -> Session (Either ResponseError b))
-> Either ResponseError b -> Session (Either ResponseError b)
forall a b. (a -> b) -> a -> b
$ case Either ResponseError (MessageResult ('Method_CustomMethod "test"))
_result of
         Left ResponseError
e -> ResponseError -> Either ResponseError b
forall a b. a -> Either a b
Left ResponseError
e
         Right MessageResult ('Method_CustomMethod "test")
json -> case Value -> Result b
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
MessageResult ('Method_CustomMethod "test")
json of
             A.Success b
a -> b -> Either ResponseError b
forall a b. b -> Either a b
Right b
a
             A.Error FilePath
e   -> FilePath -> Either ResponseError b
forall a. HasCallStack => FilePath -> a
error FilePath
e

callTestPlugin :: (A.FromJSON b) => TestRequest -> Session b
callTestPlugin :: forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
cmd = do
    Either ResponseError b
res <- TestRequest -> Session (Either ResponseError b)
forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
cmd
    case Either ResponseError b
res of
        Left (ResponseError LSPErrorCodes |? ErrorCodes
t Text
err Maybe Value
_) -> FilePath -> Session b
forall a. HasCallStack => FilePath -> a
error (FilePath -> Session b) -> FilePath -> Session b
forall a b. (a -> b) -> a -> b
$ (LSPErrorCodes |? ErrorCodes) -> FilePath
forall a. Show a => a -> FilePath
show LSPErrorCodes |? ErrorCodes
t FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
": " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
err
        Right b
a                      -> b -> Session b
forall a. a -> Session a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a


waitForAction :: String -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
waitForAction :: FilePath -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
waitForAction FilePath
key TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} =
    TestRequest -> Session WaitForIdeRuleResult
forall b. FromJSON b => TestRequest -> Session b
callTestPlugin (FilePath -> Uri -> TestRequest
WaitForIdeRule FilePath
key Uri
_uri)

getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
getInterfaceFilesDir :: TextDocumentIdentifier -> Session FilePath
getInterfaceFilesDir TextDocumentIdentifier{Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} = TestRequest -> Session FilePath
forall b. FromJSON b => TestRequest -> Session b
callTestPlugin (Uri -> TestRequest
GetInterfaceFilesDir Uri
_uri)

garbageCollectDirtyKeys :: CheckParents -> Int -> Session [String]
garbageCollectDirtyKeys :: CheckParents -> Int -> Session [FilePath]
garbageCollectDirtyKeys CheckParents
parents Int
age = TestRequest -> Session [FilePath]
forall b. FromJSON b => TestRequest -> Session b
callTestPlugin (CheckParents -> Int -> TestRequest
GarbageCollectDirtyKeys CheckParents
parents Int
age)

getStoredKeys :: Session [Text]
getStoredKeys :: Session [Text]
getStoredKeys = TestRequest -> Session [Text]
forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
GetStoredKeys

waitForTypecheck :: TextDocumentIdentifier -> Session Bool
waitForTypecheck :: TextDocumentIdentifier -> Session Bool
waitForTypecheck TextDocumentIdentifier
tid = WaitForIdeRuleResult -> Bool
ideResultSuccess (WaitForIdeRuleResult -> Bool)
-> Session WaitForIdeRuleResult -> Session Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> TextDocumentIdentifier -> Session WaitForIdeRuleResult
waitForAction FilePath
"typecheck" TextDocumentIdentifier
tid

waitForBuildQueue :: Session ()
waitForBuildQueue :: Session ()
waitForBuildQueue = TestRequest -> Session ()
forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
WaitForShakeQueue

getFilesOfInterest :: Session [FilePath]
getFilesOfInterest :: Session [FilePath]
getFilesOfInterest = TestRequest -> Session [FilePath]
forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
GetFilesOfInterest

waitForCustomMessage :: T.Text -> (A.Value -> Maybe res) -> Session res
waitForCustomMessage :: forall res. Text -> (Value -> Maybe res) -> Session res
waitForCustomMessage Text
msg Value -> Maybe res
pred =
    Session FromServerMessage -> Session res -> Session res
forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (Session res -> Session res) -> Session res -> Session res
forall a b. (a -> b) -> a -> b
$ (FromServerMessage -> Maybe res) -> Session res
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe res) -> Session res)
-> (FromServerMessage -> Maybe res) -> Session res
forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess (SMethod_CustomMethod Proxy s
p) (NotMess TNotificationMessage{$sel:_params:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params = MessageParams ('Method_CustomMethod s)
value})
            | Proxy s -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal Proxy s
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FilePath
T.unpack Text
msg -> Value -> Maybe res
pred Value
MessageParams ('Method_CustomMethod s)
value
        FromServerMessage
_ -> Maybe res
forall a. Maybe a
Nothing

waitForGC :: Session [T.Text]
waitForGC :: Session [Text]
waitForGC = Text -> (Value -> Maybe [Text]) -> Session [Text]
forall res. Text -> (Value -> Maybe res) -> Session res
waitForCustomMessage Text
"ghcide/GC" ((Value -> Maybe [Text]) -> Session [Text])
-> (Value -> Maybe [Text]) -> Session [Text]
forall a b. (a -> b) -> a -> b
$ \Value
v ->
    case Value -> Result [Text]
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
v of
        A.Success [Text]
x -> [Text] -> Maybe [Text]
forall a. a -> Maybe a
Just [Text]
x
        Result [Text]
_           -> Maybe [Text]
forall a. Maybe a
Nothing

configureCheckProject :: Bool -> Session ()
configureCheckProject :: Bool -> Session ()
configureCheckProject Bool
overrideCheckProject = FilePath -> Value -> Session ()
setConfigSection FilePath
"haskell" (Config -> Value
forall a. ToJSON a => a -> Value
toJSON (Config -> Value) -> Config -> Value
forall a b. (a -> b) -> a -> b
$ Config
forall a. Default a => a
def{checkProject = overrideCheckProject})

-- | Pattern match a message from ghcide indicating that a file has been indexed
isReferenceReady :: FilePath -> Session ()
isReferenceReady :: FilePath -> Session ()
isReferenceReady FilePath
p = Session FilePath -> Session ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Session FilePath -> Session ()) -> Session FilePath -> Session ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> Bool) -> Session FilePath
referenceReady (FilePath -> FilePath -> Bool
equalFilePath FilePath
p)

referenceReady :: (FilePath -> Bool) -> Session FilePath
referenceReady :: (FilePath -> Bool) -> Session FilePath
referenceReady FilePath -> Bool
pred = (FromServerMessage -> Maybe FilePath) -> Session FilePath
forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe ((FromServerMessage -> Maybe FilePath) -> Session FilePath)
-> (FromServerMessage -> Maybe FilePath) -> Session FilePath
forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess (SMethod_CustomMethod Proxy s
p) (NotMess TNotificationMessage{MessageParams ('Method_CustomMethod s)
$sel:_params:TNotificationMessage :: forall (f :: MessageDirection) (m :: Method f 'Notification).
TNotificationMessage m -> MessageParams m
_params :: MessageParams ('Method_CustomMethod s)
_params})
    | A.Success FilePath
fp <- Value -> Result FilePath
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
MessageParams ('Method_CustomMethod s)
_params
    , FilePath -> Bool
pred FilePath
fp
    , Proxy s -> FilePath
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> FilePath
symbolVal Proxy s
p FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"ghcide/reference/ready"
    -> FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fp
  FromServerMessage
_ -> Maybe FilePath
forall a. Maybe a
Nothing