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

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

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.Text                       (Text)
import qualified Data.Text                       as T
import           Development.IDE.Plugin.Test     (TestRequest (..),
                                                  WaitForIdeRuleResult,
                                                  ideResultSuccess)
import           Development.IDE.Test.Diagnostic
import           Ide.Plugin.Config               (CheckParents, checkProject)
import           Language.LSP.Test               hiding (message)
import qualified Language.LSP.Test               as LspTest
import           Language.LSP.Types              hiding
                                                 (SemanticTokenAbsolute (length, line),
                                                  SemanticTokenRelative (length),
                                                  SemanticTokensEdit (_start))
import           Language.LSP.Types.Lens         as Lsp
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 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  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just FilePath
err -> 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 =
  forall {t :: MethodType} (m :: Method 'FromServer t).
SMethod m
-> Seconds -> (ServerMessage m -> Session ()) -> Session ()
expectMessages SMethod 'TextDocumentPublishDiagnostics
STextDocumentPublishDiagnostics Seconds
timeout forall a b. (a -> b) -> a -> b
$ \ServerMessage 'TextDocumentPublishDiagnostics
diagsNot -> do
    let fileUri :: Uri
fileUri = ServerMessage 'TextDocumentPublishDiagnostics
diagsNot forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasUri s a => Lens' s a
uri
        actual :: List Diagnostic
actual = ServerMessage 'TextDocumentPublishDiagnostics
diagsNot forall s a. s -> Getting a s a -> a
^. forall s a. HasParams s a => Lens' s a
params forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasDiagnostics s a => Lens' s a
diagnostics
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (List Diagnostic
actual forall a. Eq a => a -> a -> Bool
== forall a. [a] -> List a
List []) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
      forall a. HasCallStack => FilePath -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$
        FilePath
"Got unexpected diagnostics for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Uri
fileUri
          forall a. Semigroup a => a -> a -> a
<> FilePath
" got "
          forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show List Diagnostic
actual

expectMessages :: SMethod m -> Seconds -> (ServerMessage m -> Session ()) -> Session ()
expectMessages :: forall {t :: MethodType} (m :: Method 'FromServer t).
SMethod m
-> Seconds -> (ServerMessage m -> Session ()) -> Session ()
expectMessages SMethod m
m Seconds
timeout ServerMessage m -> Session ()
handle = do
    -- Give any further diagnostic messages time to arrive.
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 'CustomMethod
cm = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
i <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
A.toJSON TestRequest
GetShakeSessionQueueCount
    SMethod 'CustomMethod -> LspId 'CustomMethod -> Session ()
go forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm LspId 'CustomMethod
i
  where
    go :: SMethod 'CustomMethod -> LspId 'CustomMethod -> Session ()
go SMethod 'CustomMethod
cm LspId 'CustomMethod
i = Session ()
handleMessages
      where
        handleMessages :: Session ()
handleMessages = (forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> Session (ServerMessage m)
LspTest.message SMethod m
m forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ServerMessage m -> Session ()
handle) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId SMethod 'CustomMethod
cm LspId 'CustomMethod
i) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Session ()
ignoreOthers
        ignoreOthers :: Session ()
ignoreOthers = forall (f :: * -> *) a. Functor f => f a -> f ()
void Session FromServerMessage
anyMessage forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Session ()
handleMessages

flushMessages :: Session ()
flushMessages :: Session ()
flushMessages = do
    let cm :: SMethod 'CustomMethod
cm = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"non-existent-method"
    LspId 'CustomMethod
i <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm Value
A.Null
    forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm LspId 'CustomMethod
i) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {m :: Method 'FromClient 'Request}.
SMethod m -> LspId m -> Session ()
ignoreOthers forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm LspId 'CustomMethod
i
    where
        ignoreOthers :: SMethod m -> LspId m -> Session ()
ignoreOthers SMethod m
cm LspId m
i = forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage (forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId SMethod m
cm LspId m
i) 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 ()
expectDiagnosticsWithTags
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (forall a b. (a -> b) -> [a] -> [b]
map (\(DiagnosticSeverity
ds, Cursor
c, Text
t) -> (DiagnosticSeverity
ds, Cursor
c, Text
t, forall a. Maybe a
Nothing))))

unwrapDiagnostic :: NotificationMessage TextDocumentPublishDiagnostics  -> (Uri, List Diagnostic)
unwrapDiagnostic :: NotificationMessage 'TextDocumentPublishDiagnostics
-> (Uri, List Diagnostic)
unwrapDiagnostic NotificationMessage 'TextDocumentPublishDiagnostics
diagsNot = (NotificationMessage 'TextDocumentPublishDiagnostics
diagsNotforall s a. s -> Getting a s a -> a
^.forall s a. HasParams s a => Lens' s a
paramsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasUri s a => Lens' s a
uri, NotificationMessage 'TextDocumentPublishDiagnostics
diagsNotforall s a. s -> Getting a s a -> a
^.forall s a. HasParams s a => Lens' s a
paramsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasDiagnostics s a => Lens' s a
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 forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> IO Uri
canonicalizeUri forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uri -> NormalizedUri
toNormalizedUri
        next :: Session (Uri, List Diagnostic)
next = NotificationMessage 'TextDocumentPublishDiagnostics
-> (Uri, List Diagnostic)
unwrapDiagnostic forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage Session (NotificationMessage 'TextDocumentPublishDiagnostics)
diagnostic
    Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected' <- forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Semigroup a => a -> a -> a
(<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) s t a b.
LensLike f s t a b -> LensLike f s t a b
traverseOf (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1) FilePath -> Session NormalizedUri
f [(FilePath,
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)])]
expected
    forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Uri, List Diagnostic)
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
expectDiagnosticsWithTags' Session (Uri, List Diagnostic)
next Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected'

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

expectDiagnosticsWithTags' m (Uri, List 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
      | forall k a. Map k a -> Bool
Map.null Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      | Bool
otherwise = do
        (Uri
fileUri, List Diagnostic
actual) <- m (Uri, List Diagnostic)
next
        NormalizedUri
canonUri <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Uri -> NormalizedUri
toNormalizedUri forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Uri -> IO Uri
canonicalizeUri Uri
fileUri
        case 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
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              forall a. HasCallStack => FilePath -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$
                FilePath
"Got diagnostics for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Uri
fileUri
                  forall a. Semigroup a => a -> a -> a
<> FilePath
" but only expected diagnostics for "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show (forall k a. Map k a -> [k]
Map.keys Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
m)
                  forall a. Semigroup a => a -> a -> a
<> FilePath
" got "
                  forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show List Diagnostic
actual
          Just [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall (f :: * -> *).
(Foldable f, Show (f Diagnostic), HasCallStack) =>
f Diagnostic
-> (DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)
-> Assertion
requireDiagnosticM List Diagnostic
actual) [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length List Diagnostic
actual) forall a b. (a -> b) -> a -> b
$
                forall a. HasCallStack => FilePath -> IO a
assertFailure forall a b. (a -> b) -> a -> b
$
                  FilePath
"Incorrect number of diagnostics for " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show Uri
fileUri
                    forall a. Semigroup a => a -> a -> a
<> FilePath
", expected "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected
                    forall a. Semigroup a => a -> a -> a
<> FilePath
" but got "
                    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> FilePath
show List Diagnostic
actual
            Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
go forall a b. (a -> b) -> a -> b
$ 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 ()
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
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri :: Uri
_uri} [(DiagnosticSeverity, Cursor, Text)]
expected [Diagnostic]
obtained = do
    let expected' :: Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected' = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(NormalizedUri
nuri, forall a b. (a -> b) -> [a] -> [b]
map (\(DiagnosticSeverity
ds, Cursor
c, Text
t) -> (DiagnosticSeverity
ds, Cursor
c, Text
t, forall a. Maybe a
Nothing)) [(DiagnosticSeverity, Cursor, Text)]
expected)]
        nuri :: NormalizedUri
nuri = Uri -> NormalizedUri
toNormalizedUri Uri
_uri
    forall (m :: * -> *).
(HasCallStack, MonadIO m) =>
m (Uri, List Diagnostic)
-> Map
     NormalizedUri
     [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
-> m ()
expectDiagnosticsWithTags' (forall (m :: * -> *) a. Monad m => a -> m a
return (Uri
_uri, forall a. [a] -> List a
List [Diagnostic]
obtained)) Map
  NormalizedUri
  [(DiagnosticSeverity, Cursor, Text, Maybe DiagnosticTag)]
expected'

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

diagnostic :: Session (NotificationMessage TextDocumentPublishDiagnostics)
diagnostic :: Session (NotificationMessage 'TextDocumentPublishDiagnostics)
diagnostic = forall {t :: MethodType} (m :: Method 'FromServer t).
SServerMethod m -> Session (ServerMessage m)
LspTest.message SMethod 'TextDocumentPublishDiagnostics
STextDocumentPublishDiagnostics

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 'CustomMethod
cm = forall {f :: From} {t :: MethodType}. Text -> SMethod 'CustomMethod
SCustomMethod Text
"test"
    LspId 'CustomMethod
waitId <- forall (m :: Method 'FromClient 'Request).
SClientMethod m -> MessageParams m -> Session (LspId m)
sendRequest forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm (forall a. ToJSON a => a -> Value
A.toJSON TestRequest
cmd)
    ResponseMessage{Either ResponseError (ResponseResult 'CustomMethod)
$sel:_result:ResponseMessage :: forall (f :: From) (m :: Method f 'Request).
ResponseMessage m -> Either ResponseError (ResponseResult m)
_result :: Either ResponseError (ResponseResult 'CustomMethod)
_result} <- forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
SMethod m -> LspId m -> Session (ResponseMessage m)
responseForId forall {f :: From} {t :: MethodType}. SMethod 'CustomMethod
cm LspId 'CustomMethod
waitId
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either ResponseError (ResponseResult 'CustomMethod)
_result of
         Left ResponseError
e -> forall a b. a -> Either a b
Left ResponseError
e
         Right ResponseResult 'CustomMethod
json -> case forall a. FromJSON a => Value -> Result a
A.fromJSON ResponseResult 'CustomMethod
json of
             A.Success b
a -> forall a b. b -> Either a b
Right b
a
             A.Error FilePath
e   -> 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 <- forall b.
FromJSON b =>
TestRequest -> Session (Either ResponseError b)
tryCallTestPlugin TestRequest
cmd
    case Either ResponseError b
res of
        Left (ResponseError ErrorCode
t Text
err Maybe Value
_) -> forall a. HasCallStack => FilePath -> a
error forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> FilePath
show ErrorCode
t forall a. Semigroup a => a -> a -> a
<> FilePath
": " forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
T.unpack Text
err
        Right b
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
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} =
    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
_uri :: Uri
$sel:_uri:TextDocumentIdentifier :: TextDocumentIdentifier -> Uri
_uri} = 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 = forall b. FromJSON b => TestRequest -> Session b
callTestPlugin (CheckParents -> Int -> TestRequest
GarbageCollectDirtyKeys CheckParents
parents Int
age)

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

waitForTypecheck :: TextDocumentIdentifier -> Session Bool
waitForTypecheck :: TextDocumentIdentifier -> Session Bool
waitForTypecheck TextDocumentIdentifier
tid = WaitForIdeRuleResult -> Bool
ideResultSuccess 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 = forall b. FromJSON b => TestRequest -> Session b
callTestPlugin TestRequest
WaitForShakeQueue

getFilesOfInterest :: Session [FilePath]
getFilesOfInterest :: Session [FilePath]
getFilesOfInterest = 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 =
    forall (m :: * -> *) a end. Alternative m => m a -> m end -> m end
skipManyTill Session FromServerMessage
anyMessage forall a b. (a -> b) -> a -> b
$ forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
        FromServerMess (SCustomMethod Text
lbl) (NotMess NotificationMessage{$sel:_params:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params = MessageParams 'CustomMethod
value})
            | Text
lbl forall a. Eq a => a -> a -> Bool
== Text
msg -> Value -> Maybe res
pred MessageParams 'CustomMethod
value
        FromServerMessage
_ -> forall a. Maybe a
Nothing

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

configureCheckProject :: Bool -> Session ()
configureCheckProject :: Bool -> Session ()
configureCheckProject Bool
overrideCheckProject =
    forall (m :: Method 'FromClient 'Notification).
SClientMethod m -> MessageParams m -> Session ()
sendNotification SMethod 'WorkspaceDidChangeConfiguration
SWorkspaceDidChangeConfiguration
        (Value -> DidChangeConfigurationParams
DidChangeConfigurationParams forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
toJSON
            forall a. Default a => a
def{checkProject :: Bool
checkProject = Bool
overrideCheckProject})

-- | Pattern match a message from ghcide indicating that a file has been indexed
isReferenceReady :: FilePath -> Session ()
isReferenceReady :: FilePath -> Session ()
isReferenceReady FilePath
p = forall (f :: * -> *) a. Functor f => f a -> f ()
void 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 = forall a. (FromServerMessage -> Maybe a) -> Session a
satisfyMaybe forall a b. (a -> b) -> a -> b
$ \case
  FromServerMess (SCustomMethod Text
"ghcide/reference/ready") (NotMess NotificationMessage{MessageParams 'CustomMethod
_params :: MessageParams 'CustomMethod
$sel:_params:NotificationMessage :: forall (f :: From) (m :: Method f 'Notification).
NotificationMessage m -> MessageParams m
_params})
    | A.Success FilePath
fp <- forall a. FromJSON a => Value -> Result a
A.fromJSON MessageParams 'CustomMethod
_params
    , FilePath -> Bool
pred FilePath
fp
    -> forall a. a -> Maybe a
Just FilePath
fp
  FromServerMessage
_ -> forall a. Maybe a
Nothing