Skip to content

Commit 44a2f1e

Browse files
fendorfendor
committed
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.
1 parent 838a51f commit 44a2f1e

File tree

4 files changed

+261
-73
lines changed

4 files changed

+261
-73
lines changed

‎ghcide/src/Development/IDE/Plugin/Completions/Logic.hs‎

Lines changed: 5 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
1111
, getCompletions
1212
, fromIdentInfo
1313
, getCompletionPrefix
14+
, getCompletionPrefixFromRope
1415
) where
1516

1617
import Control.Applicative
@@ -897,7 +898,10 @@ mergeListsBy cmp all_lists = merge_lists all_lists
897898

898899
-- |From the given cursor position, gets the prefix module or record for autocompletion
899900
getCompletionPrefix :: Position -> VFS.VirtualFile -> PosPrefixInfo
900-
getCompletionPrefix pos@(Position l c) (VFS.VirtualFile _ _ ropetext) =
901+
getCompletionPrefix pos (VFS.VirtualFile _ _ ropetext) = getCompletionPrefixFromRope pos ropetext
902+
903+
getCompletionPrefixFromRope :: Position -> Rope.Rope -> PosPrefixInfo
904+
getCompletionPrefixFromRope pos@(Position l c) ropetext =
901905
fromMaybe (PosPrefixInfo "" "" "" pos) $ do -- Maybe monad
902906
let headMaybe = listToMaybe
903907
lastMaybe = headMaybe . reverse

‎hls-test-utils/hls-test-utils.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,7 @@ library
4949
, lsp
5050
, lsp-test ^>=0.17
5151
, lsp-types ^>=2.2
52+
, neat-interpolation
5253
, safe-exceptions
5354
, tasty
5455
, tasty-expected-failure
@@ -57,6 +58,7 @@ library
5758
, tasty-rerun
5859
, temporary
5960
, text
61+
, text-rope
6062

6163
ghc-options:
6264
-Wall

‎hls-test-utils/src/Test/Hls.hs‎

Lines changed: 109 additions & 54 deletions
Original file line numberDiff line numberDiff line change
@@ -34,6 +34,8 @@ module Test.Hls
3434
runSessionWithServer,
3535
runSessionWithServerInTmpDir,
3636
runSessionWithTestConfig,
37+
-- * Running parameterised tests for a set of test configurations
38+
parameterisedCursorTest,
3739
-- * Helpful re-exports
3840
PluginDescriptor,
3941
IdeState,
@@ -64,74 +66,76 @@ module Test.Hls
6466
where
6567

6668
import Control.Applicative.Combinators
67-
import Control.Concurrent.Async (async, cancel, wait)
69+
import Control.Concurrent.Async (async, cancel, wait)
6870
import Control.Concurrent.Extra
6971
import Control.Exception.Safe
70-
import Control.Lens.Extras (is)
71-
import Control.Monad (guard, unless, void)
72-
import Control.Monad.Extra (forM)
72+
import Control.Lens.Extras (is)
73+
import Control.Monad (guard, unless, void)
74+
import Control.Monad.Extra (forM)
7375
import Control.Monad.IO.Class
74-
import Data.Aeson (Result (Success),
75-
Value (Null), fromJSON,
76-
toJSON)
77-
import qualified Data.Aeson as A
78-
import Data.ByteString.Lazy (ByteString)
79-
import Data.Default (Default, def)
80-
import qualified Data.Map as M
81-
import Data.Maybe (fromMaybe)
82-
import Data.Proxy (Proxy (Proxy))
83-
import qualified Data.Text as T
84-
import qualified Data.Text.Lazy as TL
85-
import qualified Data.Text.Lazy.Encoding as TL
86-
import Development.IDE (IdeState,
87-
LoggingColumn (ThreadIdColumn),
88-
defaultLayoutOptions,
89-
layoutPretty, renderStrict)
90-
import qualified Development.IDE.LSP.Notifications as Notifications
91-
import Development.IDE.Main hiding (Log)
92-
import qualified Development.IDE.Main as IDEMain
93-
import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
94-
WaitForIdeRuleResult (ideResultSuccess))
95-
import qualified Development.IDE.Plugin.Test as Test
76+
import Data.Aeson (Result (Success),
77+
Value (Null),
78+
fromJSON, toJSON)
79+
import qualified Data.Aeson as A
80+
import Data.ByteString.Lazy (ByteString)
81+
import Data.Default (Default, def)
82+
import qualified Data.Map as M
83+
import Data.Maybe (fromMaybe)
84+
import Data.Proxy (Proxy (Proxy))
85+
import qualified Data.Text as T
86+
import qualified Data.Text.Lazy as TL
87+
import qualified Data.Text.Lazy.Encoding as TL
88+
import Development.IDE (IdeState,
89+
LoggingColumn (ThreadIdColumn),
90+
defaultLayoutOptions,
91+
layoutPretty,
92+
renderStrict)
93+
import Development.IDE.Main hiding (Log)
94+
import qualified Development.IDE.Main as IDEMain
95+
import Development.IDE.Plugin.Completions.Types (PosPrefixInfo)
96+
import Development.IDE.Plugin.Test (TestRequest (GetBuildKeysBuilt, WaitForIdeRule, WaitForShakeQueue),
97+
WaitForIdeRuleResult (ideResultSuccess))
98+
import qualified Development.IDE.Plugin.Test as Test
9699
import Development.IDE.Types.Options
97100
import GHC.IO.Handle
98101
import GHC.TypeLits
99-
import Ide.Logger (Pretty (pretty),
100-
Priority (..), Recorder,
101-
WithPriority (WithPriority, priority),
102-
cfilter, cmapWithPrio,
103-
defaultLoggingColumns,
104-
logWith,
105-
makeDefaultStderrRecorder,
106-
(<+>))
107-
import qualified Ide.Logger as Logger
108-
import Ide.Plugin.Properties ((&))
109-
import Ide.PluginUtils (idePluginsToPluginDesc,
110-
pluginDescToIdePlugins)
102+
import Ide.Logger (Pretty (pretty),
103+
Priority (..),
104+
Recorder,
105+
WithPriority (WithPriority, priority),
106+
cfilter,
107+
cmapWithPrio,
108+
defaultLoggingColumns,
109+
logWith,
110+
makeDefaultStderrRecorder,
111+
(<+>))
112+
import qualified Ide.Logger as Logger
113+
import Ide.PluginUtils (idePluginsToPluginDesc,
114+
pluginDescToIdePlugins)
111115
import Ide.Types
112116
import Language.LSP.Protocol.Capabilities
113117
import Language.LSP.Protocol.Message
114-
import qualified Language.LSP.Protocol.Message as LSP
115-
import Language.LSP.Protocol.Types hiding (Null)
116-
import qualified Language.LSP.Server as LSP
118+
import qualified Language.LSP.Protocol.Message as LSP
119+
import Language.LSP.Protocol.Types hiding (Null)
120+
import qualified Language.LSP.Server as LSP
117121
import Language.LSP.Test
118-
import Prelude hiding (log)
119-
import System.Directory (canonicalizePath,
120-
createDirectoryIfMissing,
121-
getCurrentDirectory,
122-
getTemporaryDirectory,
123-
makeAbsolute,
124-
setCurrentDirectory)
125-
import System.Environment (lookupEnv, setEnv)
122+
import Prelude hiding (log)
123+
import System.Directory (canonicalizePath,
124+
createDirectoryIfMissing,
125+
getCurrentDirectory,
126+
getTemporaryDirectory,
127+
makeAbsolute,
128+
setCurrentDirectory)
129+
import System.Environment (lookupEnv, setEnv)
126130
import System.FilePath
127-
import System.IO.Extra (newTempDirWithin)
128-
import System.IO.Unsafe (unsafePerformIO)
129-
import System.Process.Extra (createPipe)
131+
import System.IO.Extra (newTempDirWithin)
132+
import System.IO.Unsafe (unsafePerformIO)
133+
import System.Process.Extra (createPipe)
130134
import System.Time.Extra
131-
import qualified Test.Hls.FileSystem as FS
135+
import qualified Test.Hls.FileSystem as FS
132136
import Test.Hls.FileSystem
133137
import Test.Hls.Util
134-
import Test.Tasty hiding (Timeout)
138+
import Test.Tasty hiding (Timeout)
135139
import Test.Tasty.ExpectedFailure
136140
import Test.Tasty.Golden
137141
import Test.Tasty.HUnit
@@ -328,6 +332,56 @@ goldenWithDocInTmpDir languageKind config plugin title tree path desc ext act =
328332
act doc
329333
documentContents doc
330334

335+
-- | A parameterised test is similar to a normal test case but allows to run
336+
-- the same test case multiple times with different inputs.
337+
-- A 'parameterisedCursorTest' allows to define a test case based on an input file
338+
-- that specifies one or many cursor positions via the identification value '^'.
339+
--
340+
-- For example:
341+
--
342+
-- @
343+
-- parameterisedCursorTest "Cursor Test" [trimming|
344+
-- foo = 2
345+
-- ^
346+
-- bar = 3
347+
-- baz = foo + bar
348+
-- ^
349+
-- |]
350+
-- ["foo", "baz"]
351+
-- (\input cursor -> findFunctionNameUnderCursor input cursor)
352+
-- @
353+
--
354+
-- Assuming a fitting implementation for 'findFunctionNameUnderCursor'.
355+
--
356+
-- This test definition will run the test case 'findFunctionNameUnderCursor' for
357+
-- each cursor position, each in its own isolated 'testCase'.
358+
-- Cursor positions are identified via the character '^', which points to the
359+
-- above line as the actual cursor position.
360+
-- Lines containing '^' characters, are removed from the final text, that is
361+
-- passed to the testing function.
362+
--
363+
-- TODO: Many Haskell and Cabal source may contain '^' characters for good reasons.
364+
-- We likely need a way to change the character for certain test cases in the future.
365+
--
366+
-- The quasi quoter 'trimming' is very helpful to define such tests, as it additionally
367+
-- allows to interpolate haskell values and functions. We reexport this quasi quoter
368+
-- for easier usage.
369+
parameterisedCursorTest :: (Show a, Eq a) => String -> T.Text -> [a] -> (T.Text -> PosPrefixInfo -> IO a) -> TestTree
370+
parameterisedCursorTest title content expectations act
371+
| lenPrefs /= lenExpected = error $ "parameterisedCursorTest: Expected " <> show lenExpected <> " cursors but found: " <> show lenPrefs
372+
| otherwise = testGroup title $
373+
map singleTest testCaseSpec
374+
where
375+
lenPrefs = length prefInfos
376+
lenExpected = length expectations
377+
(cleanText, prefInfos) = extractCursorPositions content
378+
379+
testCaseSpec = zip [1 ::Int ..] (zip expectations prefInfos)
380+
381+
singleTest (n, (expected, info)) = testCase (title <> " " <> show n) $ do
382+
actual <- act cleanText info
383+
assertEqual (mkParameterisedLabel info) expected actual
384+
331385
-- ------------------------------------------------------------
332386
-- Helper function for initialising plugins under test
333387
-- ------------------------------------------------------------
@@ -429,6 +483,7 @@ initializeTestRecorder envVars = do
429483
-- ------------------------------------------------------------
430484
-- Run an HLS server testing a specific plugin
431485
-- ------------------------------------------------------------
486+
432487
runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a
433488
runSessionWithServerInTmpDir config plugin tree act =
434489
runSessionWithTestConfig def

0 commit comments

Comments
 (0)