Skip to content

hls-cabal-plugin: refactor context search to use readFields #4186

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 2 commits into from
May 31, 2024
Merged

hls-cabal-plugin: refactor context search to use readFields #4186

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
f024d2a
hls-test-utils: Add parameterised cursor test utils
fendor May 27, 2024
6e09f48
Refactor context search to use `readFields`
fendor May 27, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
6 changes: 5 additions & 1 deletion ghcide/src/Development/IDE/Plugin/Completions/Logic.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ module Development.IDE.Plugin.Completions.Logic (
, getCompletions
, fromIdentInfo
, getCompletionPrefix
, getCompletionPrefixFromRope
) where

import Control.Applicative
Expand Down Expand Up @@ -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
Expand Down
1 change: 1 addition & 0 deletions haskell-language-server.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -241,6 +241,7 @@ library hls-cabal-plugin
Ide.Plugin.Cabal.Completion.Data
Ide.Plugin.Cabal.Completion.Types
Ide.Plugin.Cabal.LicenseSuggest
Ide.Plugin.Cabal.Orphans
Ide.Plugin.Cabal.Parse


Expand Down
2 changes: 2 additions & 0 deletions hls-test-utils/hls-test-utils.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -49,6 +49,7 @@ library
, lsp
, lsp-test ^>=0.17
, lsp-types ^>=2.2
, neat-interpolation
, safe-exceptions
, tasty
, tasty-expected-failure
Expand All @@ -57,6 +58,7 @@ library
, tasty-rerun
, temporary
, text
, text-rope

ghc-options:
-Wall
Expand Down
163 changes: 109 additions & 54 deletions hls-test-utils/src/Test/Hls.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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,
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
-- ------------------------------------------------------------
Expand Down Expand Up @@ -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
Expand Down
Loading
Loading