mirror of
https://github.com/haskell/haskell-language-server.git
synced 2024-09-11 08:45:35 +03:00
hls-test-utils: Add parameterised cursor test utils
Add utils that allows to define parameterised tests for files that require cursor positions. This enables us to define run the same tests for multiple inputs efficiently, and with readable error messages. The main advantage is the improved specification of the test cases, as we allow to specify the cursor position directly in the source of the test files.
This commit is contained in:
Fendor
fendor
parent
3979b27ab2
commit
ce2435d620
@ -11,6 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
|
||||
, getCompletions
|
||||
, fromIdentInfo
|
||||
, getCompletionPrefix
|
||||
, getCompletionPrefixFromRope
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
@ -897,7 +898,10 @@ mergeListsBy cmp all_lists = merge_lists all_lists
|
||||
|
||||
-- |From the given cursor position, gets the prefix module or record for autocompletion
|
||||
getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo
|
||||
getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
|
||||
getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext
|
||||
|
||||
getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo
|
||||
getCompletionPrefixFromRope pos@(Position l c) ropetext =
|
||||
fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
|
||||
let headMaybe = listToMaybe
|
||||
lastMaybe = headMaybe . reverse
|
||||
|
||||
@ -49,6 +49,7 @@ library
|
||||
, lsp
|
||||
, lsp-test ^>=0.17
|
||||
, lsp-types ^>=2.2
|
||||
, neat-interpolation
|
||||
, safe-exceptions
|
||||
, tasty
|
||||
, tasty-expected-failure
|
||||
@ -57,6 +58,7 @@ library
|
||||
, tasty-rerun
|
||||
, temporary
|
||||
, text
|
||||
, text-rope
|
||||
|
||||
ghc-options:
|
||||
-Wall
|
||||
|
||||
@ -34,6 +34,8 @@ module Test.Hls
|
||||
runSessionWithServer,
|
||||
runSessionWithServerInTmpDir,
|
||||
runSessionWithTestConfig,
|
||||
-- * Running parameterised tests for a set of test configurations
|
||||
parameterisedCursorTest,
|
||||
-- * Helpful re-exports
|
||||
PluginDescriptor,
|
||||
IdeState,
|
||||
@ -64,74 +66,76 @@ module Test.Hls
|
||||
where
|
||||
|
||||
import Control.Applicative.Combinators
|
||||
import Control.Concurrent.Async (async, cancel, wait)
|
||||
import Control.Concurrent.Async (async, cancel, wait)
|
||||
import Control.Concurrent.Extra
|
||||
import Control.Exception.Safe
|
||||
import Control.Lens.Extras (is)
|
||||
import Control.Monad (guard, unless, void)
|
||||
import Control.Monad.Extra (forM)
|
||||
import Control.Lens.Extras (is)
|
||||
import Control.Monad (guard, unless, void)
|
||||
import Control.Monad.Extra (forM)
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Aeson (Result (Success),
|
||||
Value (Null), fromJSON,
|
||||
toJSON)
|
||||
import qualified Data.Aeson as A
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Default (Default, def)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Encoding as TL
|
||||
import Development.IDE (IdeState,
|
||||
LoggingColumn (ThreadIdColumn),
|
||||
defaultLayoutOptions,
|
||||
layoutPretty, renderStrict)
|
||||
import qualified Development.IDE.LSP.Notifications as Notifications
|
||||
import Development.IDE.Main hiding (Log)
|
||||
import qualified Development.IDE.Main as IDEMain
|
||||
import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
|
||||
WaitForIdeRuleResult (ideResultSuccess))
|
||||
import qualified Development.IDE.Plugin.Test as Test
|
||||
import Data.Aeson (Result (Success),
|
||||
Value (Null),
|
||||
fromJSON, toJSON)
|
||||
import qualified Data.Aeson as A
|
||||
import Data.ByteString.Lazy (ByteString)
|
||||
import Data.Default (Default, def)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Proxy (Proxy (Proxy))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Encoding as TL
|
||||
import Development.IDE (IdeState,
|
||||
LoggingColumn (ThreadIdColumn),
|
||||
defaultLayoutOptions,
|
||||
layoutPretty,
|
||||
renderStrict)
|
||||
import Development.IDE.Main hiding (Log)
|
||||
import qualified Development.IDE.Main as IDEMain
|
||||
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo)
|
||||
import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
|
||||
WaitForIdeRuleResult (ideResultSuccess))
|
||||
import qualified Development.IDE.Plugin.Test as Test
|
||||
import Development.IDE.Types.Options
|
||||
import GHC.IO.Handle
|
||||
import GHC.TypeLits
|
||||
import Ide.Logger (Pretty (pretty),
|
||||
Priority (..), Recorder,
|
||||
WithPriority (WithPriority, priority),
|
||||
cfilter, cmapWithPrio,
|
||||
defaultLoggingColumns,
|
||||
logWith,
|
||||
makeDefaultStderrRecorder,
|
||||
(<+>))
|
||||
import qualified Ide.Logger as Logger
|
||||
import Ide.Plugin.Properties ((&))
|
||||
import Ide.PluginUtils (idePluginsToPluginDesc,
|
||||
pluginDescToIdePlugins)
|
||||
import Ide.Logger (Pretty (pretty),
|
||||
Priority (..),
|
||||
Recorder,
|
||||
WithPriority (WithPriority, priority),
|
||||
cfilter,
|
||||
cmapWithPrio,
|
||||
defaultLoggingColumns,
|
||||
logWith,
|
||||
makeDefaultStderrRecorder,
|
||||
(<+>))
|
||||
import qualified Ide.Logger as Logger
|
||||
import Ide.PluginUtils (idePluginsToPluginDesc,
|
||||
pluginDescToIdePlugins)
|
||||
import Ide.Types
|
||||
import Language.LSP.Protocol.Capabilities
|
||||
import Language.LSP.Protocol.Message
|
||||
import qualified Language.LSP.Protocol.Message as LSP
|
||||
import Language.LSP.Protocol.Types hiding (Null)
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import qualified Language.LSP.Protocol.Message as LSP
|
||||
import Language.LSP.Protocol.Types hiding (Null)
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import Language.LSP.Test
|
||||
import Prelude hiding (log)
|
||||
import System.Directory (canonicalizePath,
|
||||
createDirectoryIfMissing,
|
||||
getCurrentDirectory,
|
||||
getTemporaryDirectory,
|
||||
makeAbsolute,
|
||||
setCurrentDirectory)
|
||||
import System.Environment (lookupEnv, setEnv)
|
||||
import Prelude hiding (log)
|
||||
import System.Directory (canonicalizePath,
|
||||
createDirectoryIfMissing,
|
||||
getCurrentDirectory,
|
||||
getTemporaryDirectory,
|
||||
makeAbsolute,
|
||||
setCurrentDirectory)
|
||||
import System.Environment (lookupEnv, setEnv)
|
||||
import System.FilePath
|
||||
import System.IO.Extra (newTempDirWithin)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.Process.Extra (createPipe)
|
||||
import System.IO.Extra (newTempDirWithin)
|
||||
import System.IO.Unsafe (unsafePerformIO)
|
||||
import System.Process.Extra (createPipe)
|
||||
import System.Time.Extra
|
||||
import qualified Test.Hls.FileSystem as FS
|
||||
import qualified Test.Hls.FileSystem as FS
|
||||
import Test.Hls.FileSystem
|
||||
import Test.Hls.Util
|
||||
import Test.Tasty hiding (Timeout)
|
||||
import Test.Tasty hiding (Timeout)
|
||||
import Test.Tasty.ExpectedFailure
|
||||
import Test.Tasty.Golden
|
||||
import Test.Tasty.HUnit
|
||||
@ -328,6 +332,56 @@ goldenWithDocInTmpDir languageKind config plugin title tree path desc ext act =
|
||||
act doc
|
||||
documentContents doc
|
||||
|
||||
-- | A parameterised test is similar to a normal test case but allows to run
|
||||
-- the same test case multiple times with different inputs.
|
||||
-- A 'parameterisedCursorTest' allows to define a test case based on an input file
|
||||
-- that specifies one or many cursor positions via the identification value '^'.
|
||||
--
|
||||
-- For example:
|
||||
--
|
||||
-- @
|
||||
-- parameterisedCursorTest "Cursor Test" [trimming|
|
||||
-- foo = 2
|
||||
-- ^
|
||||
-- bar = 3
|
||||
-- baz = foo + bar
|
||||
-- ^
|
||||
-- |]
|
||||
-- ["foo", "baz"]
|
||||
-- (\input cursor -> findFunctionNameUnderCursor input cursor)
|
||||
-- @
|
||||
--
|
||||
-- Assuming a fitting implementation for 'findFunctionNameUnderCursor'.
|
||||
--
|
||||
-- This test definition will run the test case 'findFunctionNameUnderCursor' for
|
||||
-- each cursor position, each in its own isolated 'testCase'.
|
||||
-- Cursor positions are identified via the character '^', which points to the
|
||||
-- above line as the actual cursor position.
|
||||
-- Lines containing '^' characters, are removed from the final text, that is
|
||||
-- passed to the testing function.
|
||||
--
|
||||
-- TODO: Many Haskell and Cabal source may contain '^' characters for good reasons.
|
||||
-- We likely need a way to change the character for certain test cases in the future.
|
||||
--
|
||||
-- The quasi quoter 'trimming' is very helpful to define such tests, as it additionally
|
||||
-- allows to interpolate haskell values and functions. We reexport this quasi quoter
|
||||
-- for easier usage.
|
||||
parameterisedCursorTest :: (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree
|
||||
parameterisedCursorTest title content expectations act
|
||||
| lenPrefs /= lenExpected = error $ "parameterisedCursorTest: Expected " <> show lenExpected <> " cursors but found: " <> show lenPrefs
|
||||
| otherwise = testGroup title $
|
||||
map singleTest testCaseSpec
|
||||
where
|
||||
lenPrefs = length prefInfos
|
||||
lenExpected = length expectations
|
||||
(cleanText, prefInfos) = extractCursorPositions content
|
||||
|
||||
testCaseSpec = zip [1 ::Int ..] (zip expectations prefInfos)
|
||||
|
||||
singleTest (n, (expected, info)) = testCase (title <> " " <> show n) $ do
|
||||
actual <- act cleanText info
|
||||
assertEqual (mkParameterisedLabel info) expected actual
|
||||
|
||||
-- ------------------------------------------------------------
|
||||
-- Helper function for initialising plugins under test
|
||||
-- ------------------------------------------------------------
|
||||
@ -429,6 +483,7 @@ initializeTestRecorder envVars = do
|
||||
-- ------------------------------------------------------------
|
||||
-- Run an HLS server testing a specific plugin
|
||||
-- ------------------------------------------------------------
|
||||
|
||||
runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
|
||||
runSessionWithServerInTmpDir config plugin tree act =
|
||||
runSessionWithTestConfig def
|
||||
|
||||
@ -42,37 +42,48 @@ module Test.Hls.Util
|
||||
, withCurrentDirectoryInTmp
|
||||
, withCurrentDirectoryInTmp'
|
||||
, withCanonicalTempDir
|
||||
-- * Extract positions from input file.
|
||||
, extractCursorPositions
|
||||
, mkParameterisedLabel
|
||||
, trimming
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative.Combinators (skipManyTill, (<|>))
|
||||
import Control.Exception (catch, throwIO)
|
||||
import Control.Lens (_Just, (&), (.~), (?~), (^.))
|
||||
import Control.Applicative.Combinators (skipManyTill, (<|>))
|
||||
import Control.Exception (catch, throwIO)
|
||||
import Control.Lens (_Just, (&), (.~),
|
||||
(?~), (^.))
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Bool (bool)
|
||||
import qualified Data.Aeson as A
|
||||
import Data.Bool (bool)
|
||||
import Data.Default
|
||||
import Data.List.Extra (find)
|
||||
import Data.List.Extra (find)
|
||||
import Data.Proxy
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE (GhcVersion (..), ghcVersion)
|
||||
import qualified Language.LSP.Protocol.Lens as L
|
||||
import qualified Data.Text as T
|
||||
import Development.IDE (GhcVersion (..),
|
||||
ghcVersion)
|
||||
import qualified Language.LSP.Protocol.Lens as L
|
||||
import Language.LSP.Protocol.Message
|
||||
import Language.LSP.Protocol.Types
|
||||
import qualified Language.LSP.Test as Test
|
||||
import qualified Language.LSP.Test as Test
|
||||
import System.Directory
|
||||
import System.FilePath
|
||||
import System.Info.Extra (isMac, isWindows)
|
||||
import System.Info.Extra (isMac, isWindows)
|
||||
import qualified System.IO.Extra
|
||||
import System.IO.Temp
|
||||
import System.Time.Extra (Seconds, sleep)
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.ExpectedFailure (expectFailBecause,
|
||||
ignoreTestBecause)
|
||||
import Test.Tasty.HUnit (Assertion, assertFailure,
|
||||
(@?=))
|
||||
import System.Time.Extra (Seconds, sleep)
|
||||
import Test.Tasty (TestTree)
|
||||
import Test.Tasty.ExpectedFailure (expectFailBecause,
|
||||
ignoreTestBecause)
|
||||
import Test.Tasty.HUnit (assertFailure)
|
||||
|
||||
import qualified Data.List as List
|
||||
import qualified Data.Text.Internal.Search as T
|
||||
import qualified Data.Text.Utf16.Rope.Mixed as Rope
|
||||
import Development.IDE.Plugin.Completions.Logic (getCompletionPrefixFromRope)
|
||||
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo (..))
|
||||
import NeatInterpolation (trimming)
|
||||
|
||||
noLiteralCaps :: ClientCapabilities
|
||||
noLiteralCaps = def & L.textDocument ?~ textDocumentCaps
|
||||
@ -327,3 +338,119 @@ withCanonicalTempDir :: (FilePath -> IO a) -> IO a
|
||||
withCanonicalTempDir f = System.IO.Extra.withTempDir $ \dir -> do
|
||||
dir' <- canonicalizePath dir
|
||||
f dir'
|
||||
|
||||
-- ----------------------------------------------------------------------------
|
||||
-- Extract Position data from the source file itself.
|
||||
-- ----------------------------------------------------------------------------
|
||||
|
||||
-- | Pretty labelling for tests that use the parameterised test helpers.
|
||||
mkParameterisedLabel :: PosPrefixInfo -> String
|
||||
mkParameterisedLabel posPrefixInfo = unlines
|
||||
[ "Full Line: \"" <> T.unpack (fullLine posPrefixInfo) <> "\""
|
||||
, "Cursor Column: \"" <> replicate (fromIntegral $ cursorPos posPrefixInfo ^. L.character) ' ' ++ "^" <> "\""
|
||||
, "Prefix Text: \"" <> T.unpack (prefixText posPrefixInfo) <> "\""
|
||||
]
|
||||
|
||||
-- | Given a in-memory representation of a file, where a user can specify the
|
||||
-- current cursor position using a '^' in the next line.
|
||||
--
|
||||
-- This function allows to generate multiple tests for a single input file, without
|
||||
-- the hassle of calculating by hand where there cursor is supposed to be.
|
||||
--
|
||||
-- Example (line number has been added for readability):
|
||||
--
|
||||
-- @
|
||||
-- 0: foo = 2
|
||||
-- 1: ^
|
||||
-- 2: bar =
|
||||
-- 3: ^
|
||||
-- @
|
||||
--
|
||||
-- This example input file contains two cursor positions (y, x), at
|
||||
--
|
||||
-- * (1, 1), and
|
||||
-- * (3, 5).
|
||||
--
|
||||
-- 'extractCursorPositions' will search for '^' characters, and determine there are
|
||||
-- two cursor positions in the text.
|
||||
-- First, it will normalise the text to:
|
||||
--
|
||||
-- @
|
||||
-- 0: foo = 2
|
||||
-- 1: bar =
|
||||
-- @
|
||||
--
|
||||
-- stripping away the '^' characters. Then, the actual cursor positions are:
|
||||
--
|
||||
-- * (0, 1) and
|
||||
-- * (2, 5).
|
||||
--
|
||||
extractCursorPositions :: T.Text -> (T.Text, [PosPrefixInfo])
|
||||
extractCursorPositions t =
|
||||
let
|
||||
textLines = T.lines t
|
||||
foldState = List.foldl' go emptyFoldState textLines
|
||||
finalText = foldStateToText foldState
|
||||
reconstructCompletionPrefix pos = getCompletionPrefixFromRope pos (Rope.fromText finalText)
|
||||
cursorPositions = reverse . fmap reconstructCompletionPrefix $ foldStatePositions foldState
|
||||
in
|
||||
(finalText, cursorPositions)
|
||||
|
||||
where
|
||||
go foldState l = case T.indices "^" l of
|
||||
[] -> addTextLine foldState l
|
||||
xs -> List.foldl' addTextCursor foldState xs
|
||||
|
||||
-- | 'FoldState' is an implementation detail used to parse some file contents,
|
||||
-- extracting the cursor positions identified by '^' and producing a cleaned
|
||||
-- representation of the file contents.
|
||||
data FoldState = FoldState
|
||||
{ foldStateRows :: !Int
|
||||
-- ^ The row index of the cleaned file contents.
|
||||
--
|
||||
-- For example, the file contents
|
||||
--
|
||||
-- @
|
||||
-- 0: foo
|
||||
-- 1: ^
|
||||
-- 2: bar
|
||||
-- @
|
||||
-- will report that 'bar' is actually occurring in line '1', as '^' is
|
||||
-- a cursor position.
|
||||
-- Lines containing cursor positions are removed.
|
||||
, foldStatePositions :: ![Position]
|
||||
-- ^ List of cursors positions found in the file contents.
|
||||
--
|
||||
-- List is stored in reverse for efficient 'cons'ing
|
||||
, foldStateFinalText :: ![T.Text]
|
||||
-- ^ Final file contents with all lines containing cursor positions removed.
|
||||
--
|
||||
-- List is stored in reverse for efficient 'cons'ing
|
||||
}
|
||||
|
||||
emptyFoldState :: FoldState
|
||||
emptyFoldState = FoldState
|
||||
{ foldStateRows = 0
|
||||
, foldStatePositions = []
|
||||
, foldStateFinalText = []
|
||||
}
|
||||
|
||||
-- | Produce the final file contents, without any lines containing cursor positions.
|
||||
foldStateToText :: FoldState -> T.Text
|
||||
foldStateToText state = T.unlines $ reverse $ foldStateFinalText state
|
||||
|
||||
-- | We found a '^' at some location! Add it to the list of known cursor positions.
|
||||
--
|
||||
-- If the row index is '0', we throw an error, as there can't be a cursor position above the first line.
|
||||
addTextCursor :: FoldState -> Int -> FoldState
|
||||
addTextCursor state col
|
||||
| foldStateRows state <= 0 = error $ "addTextCursor: Invalid '^' found at: " <> show (col, foldStateRows state)
|
||||
| otherwise = state
|
||||
{ foldStatePositions = Position (fromIntegral (foldStateRows state) - 1) (fromIntegral col) : foldStatePositions state
|
||||
}
|
||||
|
||||
addTextLine :: FoldState -> T.Text -> FoldState
|
||||
addTextLine state l = state
|
||||
{ foldStateFinalText = l : foldStateFinalText state
|
||||
, foldStateRows = foldStateRows state + 1
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user