diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml index 0fbfc1c8c8..7798566e18 100644 --- a/.github/workflows/test.yml +++ b/.github/workflows/test.yml @@ -114,6 +114,10 @@ jobs: name: Test hls-graph run: cabal test hls-graph + - if: matrix.test + name: Test hls-core-plugin test suite + run: cabal test hls-core-plugin-tests + - if: needs.pre_job.outputs.should_skip_ghcide != 'true' && matrix.test name: Test ghcide # run the tests without parallelism to avoid running out of memory @@ -254,6 +258,7 @@ jobs: name: Test hls-notes-plugin test suite run: cabal test hls-notes-plugin-tests || cabal test hls-notes-plugin-tests + test_post_job: if: always() runs-on: ubuntu-latest diff --git a/.pre-commit-config.yaml b/.pre-commit-config.yaml index 9ef5013bd1..455c151fcc 100644 --- a/.pre-commit-config.yaml +++ b/.pre-commit-config.yaml @@ -4,7 +4,8 @@ "hooks": [ { "entry": "stylish-haskell --inplace", - "exclude": "(^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/test/exe/Main.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^hls-test-utils/src/Test/Hls/Util.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$)", + "exclude": "(^Setup.hs$|test/testdata/.*$|test/data/.*$|test/manual/lhs/.*$|^hie-compat/.*$|^plugins/hls-tactics-plugin/.*$|^ghcide/src/Development/IDE/GHC/Compat.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/Compat/ExactPrint.hs$|^ghcide/src/Development/IDE/GHC/Compat/Core.hs$|^ghcide/src/Development/IDE/Spans/Pragmas.hs$|^ghcide/src/Development/IDE/LSP/Outline.hs$|^plugins/hls-splice-plugin/src/Ide/Plugin/Splice.hs$|^ghcide/test/exe/Main.hs$|^ghcide/src/Development/IDE/Core/Rules.hs$|^hls-test-utils/src/Test/Hls/Util.hs$|^ghcide/src/Development/IDE/Core/Compile.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/GHC/ExactPrint.hs$|^plugins/hls-refactor-plugin/src/Development/IDE/Plugin/CodeAction/ExactPrint.hs$ + |^plugins/hls-core-plugin/Core/Outline.hs$)", "files": "\\.l?hs$", "id": "stylish-haskell", "language": "system", diff --git a/ghcide/src/Development/IDE/LSP/LanguageServer.hs b/ghcide/src/Development/IDE/LSP/LanguageServer.hs index 5663165f02..3a3ddd7d87 100644 --- a/ghcide/src/Development/IDE/LSP/LanguageServer.hs +++ b/ghcide/src/Development/IDE/LSP/LanguageServer.hs @@ -42,7 +42,6 @@ import Ide.Logger import Language.LSP.Server (LanguageContextEnv, LspServerLog, type (<~>)) -import System.IO.Unsafe (unsafeInterleaveIO) data Log = LogRegisteringIdeConfig !IdeConfiguration | LogReactorThreadException !SomeException @@ -197,18 +196,10 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa let root = LSP.resRootPath env dir <- maybe getCurrentDirectory return root dbLoc <- getHieDbLoc dir - - -- The database needs to be open for the duration of the reactor thread, but we need to pass in a reference - -- to 'getIdeState', so we use this dirty trick - dbMVar <- newEmptyMVar - ~(WithHieDbShield withHieDb,hieChan) <- unsafeInterleaveIO $ takeMVar dbMVar - - ide <- getIdeState env root withHieDb hieChan - let initConfig = parseConfiguration params - logWith recorder Info $ LogRegisteringIdeConfig initConfig - registerIdeConfiguration (shakeExtras ide) initConfig + dbMVar <- newEmptyMVar + let handleServerException (Left e) = do logWith recorder Error $ LogReactorThreadException e @@ -245,6 +236,10 @@ handleInit recorder getHieDbLoc getIdeState lifetime exitClientMsg clearReqId wa ReactorNotification act -> handle exceptionInHandler act ReactorRequest _id act k -> void $ async $ checkCancelled _id act k logWith recorder Info LogReactorThreadStopped + + (WithHieDbShield withHieDb,hieChan) <- takeMVar dbMVar + ide <- getIdeState env root withHieDb hieChan + registerIdeConfiguration (shakeExtras ide) initConfig pure $ Right (env,ide) diff --git a/haskell-language-server.cabal b/haskell-language-server.cabal index ad3b6ea097..dd9dcb61fd 100644 --- a/haskell-language-server.cabal +++ b/haskell-language-server.cabal @@ -1705,6 +1705,101 @@ test-suite hls-refactor-plugin-tests , tasty-expected-failure , tasty +----------------------------- +-- core plugin +----------------------------- + +-- flag semanticTokens +-- description: Enable semantic tokens plugin +-- default: True +-- manual: True + +common core + build-depends: haskell-language-server:hls-core-plugin + +library hls-core-plugin + import: defaults, pedantic, warnings + buildable: True + exposed-modules: + Ide.Plugin.Core + Ide.Plugin.Core.Actions + Ide.Plugin.Core.HoverDefinition + Ide.Plugin.Core.Outline + + hs-source-dirs: plugins/hls-core-plugin/src + build-depends: + , base >=4.12 && <5 + , containers + , unordered-containers + , extra + , ghc + , text-rope + , mtl >= 2.2 + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , lens + , lsp >=2.4 + , hiedb ^>= 0.6.0.0 + , text + , transformers + , bytestring + , syb + , array + , deepseq + , dlist + , hls-graph == 2.7.0.0 + , template-haskell + , data-default + , stm + , stm-containers + + default-extensions: DataKinds + +test-suite hls-core-plugin-tests + import: defaults, pedantic, test-defaults, warnings + type: exitcode-stdio-1.0 + hs-source-dirs: plugins/hls-core-plugin/test + , plugins/hls-core-plugin/test/exe + main-is: CoreTest.hs + other-modules: + Util + FindDefinitionAndHoverTests + InitializeResponseTests + OutlineTests + CompletionTests + HighlightTests + ReferenceTests + CradleTests + + + build-depends: + , aeson + , base + , async + , containers + , filepath + , haskell-language-server:hls-core-plugin + , hls-test-utils == 2.7.0.0 + , hls-plugin-api + , lens + , lsp + , text-rope + , lsp-test + , text + , tasty + , tasty-hunit + , data-default + , ghcide == 2.7.0.0 + , hls-plugin-api == 2.7.0.0 + , data-default + , row-types + , extra + , hls-test-utils + , regex-tdfa + , directory + , tasty-expected-failure + + ----------------------------- -- semantic tokens plugin ----------------------------- @@ -1886,6 +1981,7 @@ library , overloadedRecordDot , semanticTokens , notes + , core exposed-modules: Ide.Arguments diff --git a/hls-graph/hls-graph.cabal b/hls-graph/hls-graph.cabal index 33c6d44ca1..47f367a78a 100644 --- a/hls-graph/hls-graph.cabal +++ b/hls-graph/hls-graph.cabal @@ -62,6 +62,7 @@ library Development.IDE.Graph.Internal.Profile Development.IDE.Graph.Internal.Rules Development.IDE.Graph.Internal.Types + Development.IDE.Graph.Internal.DataSize Development.IDE.Graph.KeyMap Development.IDE.Graph.KeySet Development.IDE.Graph.Rule @@ -92,6 +93,7 @@ library , transformers , unliftio , unordered-containers + , ghc-heap if flag(embed-files) cpp-options: -DFILE_EMBED diff --git a/hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs b/hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs new file mode 100644 index 0000000000..a8ccb61adf --- /dev/null +++ b/hls-graph/src/Development/IDE/Graph/Internal/DataSize.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} + +{- | + Module : GHC.DataSize + Copyright : (c) Dennis Felsing + License : 3-Clause BSD-style + Maintainer : dennis@felsin9.de + -} +module Development.IDE.Graph.Internal.DataSize ( + closureSize, + recursiveSize, + recursiveSizeNF + ) + where + +import Control.DeepSeq (NFData, ($!!)) + +import GHC.Exts +import GHC.Exts.Heap hiding (size) +import GHC.Exts.Heap.Constants (wORD_SIZE) + +import Control.Monad + +import System.Mem + +-- Inspired by Simon Marlow: +-- https://ghcmutterings.wordpress.com/2009/02/12/53/ + +-- | Calculate size of GHC objects in Bytes. Note that an object may not be +-- evaluated yet and only the size of the initial closure is returned. +closureSize :: a -> IO Word +closureSize x = do + rawWds <- getClosureRawWords x + return . fromIntegral $ length rawWds * wORD_SIZE + +-- | Calculate the recursive size of GHC objects in Bytes. Note that the actual +-- size in memory is calculated, so shared values are only counted once. +-- +-- Call with +-- @ +-- recursiveSize $! 2 +-- @ +-- to force evaluation to WHNF before calculating the size. +-- +-- Call with +-- @ +-- recursiveSize $!! \"foobar\" +-- @ +-- ($!! from Control.DeepSeq) to force full evaluation before calculating the +-- size. +-- +-- A garbage collection is performed before the size is calculated, because +-- the garbage collector would make heap walks difficult. +-- +-- This function works very quickly on small data structures, but can be slow +-- on large and complex ones. If speed is an issue it's probably possible to +-- get the exact size of a small portion of the data structure and then +-- estimate the total size from that. + +recursiveSize :: a -> IO Word +recursiveSize x = do + performGC + liftM snd $ go ([], 0) $ asBox x + where go (!vs, !acc) b@(Box y) = do + isElem <- liftM or $ mapM (areBoxesEqual b) vs + if isElem + then return (vs, acc) + else do + size <- closureSize y + closure <- getClosureData y + foldM go (b : vs, acc + size) $ allClosures closure + +-- | Calculate the recursive size of GHC objects in Bytes after calling +-- Control.DeepSeq.force on the data structure to force it into Normal Form. +-- Using this function requires that the data structure has an `NFData` +-- typeclass instance. + +recursiveSizeNF :: NFData a => a -> IO Word +recursiveSizeNF x = recursiveSize $!! x + +-- | Adapted from 'GHC.Exts.Heap.getClosureRaw' which isn't exported. +-- +-- This returns the raw words of the closure on the heap. Once back in the +-- Haskell world, the raw words that hold pointers may be outdated after a +-- garbage collector run. +getClosureRawWords :: a -> IO [Word] +getClosureRawWords x = do + case unpackClosure# x of + (# _iptr, dat, _pointers #) -> do + let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE + end = fromIntegral nelems - 1 + pure [W# (indexWordArray# dat i) | I# i <- [0.. end] ] diff --git a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs index 01a6d803fc..2bf7a5607e 100644 --- a/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs +++ b/hls-graph/src/Development/IDE/Graph/Internal/Profile.hs @@ -5,8 +5,9 @@ {- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion -module Development.IDE.Graph.Internal.Profile (writeProfile) where +module Development.IDE.Graph.Internal.Profile (writeProfile, collectProfileMemory) where +import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.Stats (readTVarIO) import Data.Bifunctor import qualified Data.ByteString.Lazy.Char8 as LBS @@ -23,13 +24,16 @@ import Data.Maybe import Data.Time (getCurrentTime) import Data.Time.Format.ISO8601 (iso8601Show) import Development.IDE.Graph.Internal.Database (getDirtySet) +import Development.IDE.Graph.Internal.DataSize import Development.IDE.Graph.Internal.Key import Development.IDE.Graph.Internal.Paths import Development.IDE.Graph.Internal.Types import qualified Language.Javascript.DGTable as DGTable import qualified Language.Javascript.Flot as Flot import qualified Language.Javascript.JQuery as JQuery +import ListT (toList) import Numeric.Extra (showDP) +import qualified StmContainers.Map as SMap import System.FilePath import System.IO.Unsafe (unsafePerformIO) import System.Time.Extra (Seconds) @@ -39,6 +43,16 @@ import Data.FileEmbed import Language.Haskell.TH.Syntax (runIO) #endif +data DataBaseProfileMemory = ProfileMemory + {} + +collectProfileMemory :: ShakeDatabase -> IO DataBaseProfileMemory +collectProfileMemory (ShakeDatabase _ _ Database{databaseValues}) = do + kvss <- atomically $ (fmap . fmap) (first renderKey) $ toList $ SMap.listT databaseValues + kvs <- mapM (\(k, v)-> fmap (k, ) (recursiveSize v)) $ kvss + writeFile "profile-memory.txt" $ show kvs + pure ProfileMemory + -- | Generates an report given some build system profiling data. writeProfile :: FilePath -> Database -> IO () writeProfile out db = do diff --git a/hls-test-utils/src/Test/Hls.hs b/hls-test-utils/src/Test/Hls.hs index 38c4b9b7ae..bdef34367f 100644 --- a/hls-test-utils/src/Test/Hls.hs +++ b/hls-test-utils/src/Test/Hls.hs @@ -29,6 +29,7 @@ module Test.Hls -- * Running HLS for integration tests runSessionWithServer, runSessionWithServerAndCaps, + TestRunner, runSessionWithServerInTmpDir, runSessionWithServerAndCapsInTmpDir, runSessionWithServer', @@ -37,6 +38,7 @@ module Test.Hls PluginDescriptor, IdeState, -- * Assertion helper functions + expectNoKickDiagnostic, waitForProgressDone, waitForAllProgressDone, waitForBuildQueue, @@ -47,6 +49,7 @@ module Test.Hls getLastBuildKeys, waitForKickDone, waitForKickStart, + captureKickDiagnostics, -- * Plugin descriptor helper functions for tests PluginTestDescriptor, pluginTestRecorder, @@ -64,6 +67,7 @@ import Control.Applicative.Combinators import Control.Concurrent.Async (async, cancel, wait) import Control.Concurrent.Extra import Control.Exception.Safe +import Control.Lens ((^.)) import Control.Lens.Extras (is) import Control.Monad (guard, unless, void) import Control.Monad.Extra (forM) @@ -75,7 +79,7 @@ import qualified Data.Aeson as A import Data.ByteString.Lazy (ByteString) import Data.Default (def) import qualified Data.Map as M -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Proxy (Proxy (Proxy)) import qualified Data.Text as T import qualified Data.Text.Lazy as TL @@ -102,11 +106,13 @@ import Ide.Logger (Doc, Logger (Logger), (<+>)) import Ide.Types import Language.LSP.Protocol.Capabilities +import qualified Language.LSP.Protocol.Lens as L import Language.LSP.Protocol.Message import Language.LSP.Protocol.Types hiding (Null) import Language.LSP.Test import Prelude hiding (log) -import System.Directory (createDirectoryIfMissing, +import System.Directory (canonicalizePath, + createDirectoryIfMissing, getCurrentDirectory, getTemporaryDirectory, setCurrentDirectory) @@ -368,6 +374,87 @@ initialiseTestRecorder envVars = do -- ------------------------------------------------------------ -- Run an HLS server testing a specific plugin -- ------------------------------------------------------------ +class TestRunner cont res where + runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> cont -> IO res + runSessionWithServerInTmpDir config plugin tree act = do + recorder <- pluginTestRecorder + runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act + runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> cont -> IO res + runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do + recorder <- pluginTestRecorder + runSessionWithServerInTmpDir' (plugin recorder) config def caps tree act + + -- | Host a server, and run a test session on it. + -- + -- Creates a temporary directory, and materializes the VirtualFileTree + -- in the temporary directory. + -- + -- To debug test cases and verify the file system is correctly set up, + -- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. + -- Further, we log the temporary directory location on startup. To view + -- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. + -- + -- Example invocation to debug test cases: + -- + -- @ + -- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test + -- @ + -- + -- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. + -- + -- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. + -- + -- Note: cwd will be shifted into a temporary directory in @Session a@ + runSessionWithServerInTmpDir' :: + -- | Plugins to load on the server. + -- + -- For improved logging, make sure these plugins have been initalised with + -- the recorder produced by @pluginTestRecorder@. + IdePlugins IdeState -> + -- | lsp config for the server + Config -> + -- | config for the test session + SessionConfig -> + ClientCapabilities -> + VirtualFileTree -> + cont -> IO res + runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do + testRoot <- setupTestEnvironment + (recorder, _) <- initialiseTestRecorder + ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"] + + -- Do not clean up the temporary directory if this variable is set to anything but '0'. + -- Aids debugging. + cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" + let runSessionInDir action = do + (tempDir', cleanup) <- newTempDirWithin testRoot + tempDir <- canonicalizePath tempDir' + case cleanupTempDir of + Just val | val /= "0" -> do + a <- action tempDir + logWith recorder Debug LogNoCleanup + pure a + + _ -> do + a <- action tempDir `finally` cleanup + logWith recorder Debug LogCleanup + pure a + + runSessionInDir $ \tmpDir -> do + logWith recorder Info $ LogTestDir tmpDir + fs <- FS.materialiseVFT tmpDir tree + runSessionWithServer' plugins conf sessConf caps tmpDir (contToSessionRes fs act) + contToSessionRes :: FileSystem -> cont -> Session res + + +instance TestRunner (Session a) a where + contToSessionRes _ act = act + + +instance TestRunner (FileSystem -> Session a) a where + contToSessionRes fs act = act fs + + runSessionWithServer :: Pretty b => Config -> PluginTestDescriptor b -> FilePath -> Session a -> IO a runSessionWithServer config plugin fp act = do @@ -379,77 +466,6 @@ runSessionWithServerAndCaps config plugin caps fp act = do recorder <- pluginTestRecorder runSessionWithServer' (plugin recorder) config def caps fp act -runSessionWithServerInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> VirtualFileTree -> Session a -> IO a -runSessionWithServerInTmpDir config plugin tree act = do - recorder <- pluginTestRecorder - runSessionWithServerInTmpDir' (plugin recorder) config def fullCaps tree act - -runSessionWithServerAndCapsInTmpDir :: Pretty b => Config -> PluginTestDescriptor b -> ClientCapabilities -> VirtualFileTree -> Session a -> IO a -runSessionWithServerAndCapsInTmpDir config plugin caps tree act = do - recorder <- pluginTestRecorder - runSessionWithServerInTmpDir' (plugin recorder) config def caps tree act - --- | Host a server, and run a test session on it. --- --- Creates a temporary directory, and materializes the VirtualFileTree --- in the temporary directory. --- --- To debug test cases and verify the file system is correctly set up, --- you should set the environment variable 'HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1'. --- Further, we log the temporary directory location on startup. To view --- the logs, set the environment variable 'HLS_TEST_HARNESS_STDERR=1'. --- --- Example invocation to debug test cases: --- --- @ --- HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP=1 HLS_TEST_HARNESS_STDERR=1 cabal test --- @ --- --- Don't forget to use 'TASTY_PATTERN' to debug only a subset of tests. --- --- For plugin test logs, look at the documentation of 'mkPluginTestDescriptor'. --- --- Note: cwd will be shifted into a temporary directory in @Session a@ -runSessionWithServerInTmpDir' :: - -- | Plugins to load on the server. - -- - -- For improved logging, make sure these plugins have been initalised with - -- the recorder produced by @pluginTestRecorder@. - IdePlugins IdeState -> - -- | lsp config for the server - Config -> - -- | config for the test session - SessionConfig -> - ClientCapabilities -> - VirtualFileTree -> - Session a -> - IO a -runSessionWithServerInTmpDir' plugins conf sessConf caps tree act = withLock lockForTempDirs $ do - testRoot <- setupTestEnvironment - (recorder, _) <- initialiseTestRecorder - ["LSP_TEST_LOG_STDERR", "HLS_TEST_HARNESS_STDERR", "HLS_TEST_LOG_STDERR"] - - -- Do not clean up the temporary directory if this variable is set to anything but '0'. - -- Aids debugging. - cleanupTempDir <- lookupEnv "HLS_TEST_HARNESS_NO_TESTDIR_CLEANUP" - let runTestInDir action = case cleanupTempDir of - Just val - | val /= "0" -> do - (tempDir, _) <- newTempDirWithin testRoot - a <- action tempDir - logWith recorder Debug LogNoCleanup - pure a - - _ -> do - (tempDir, cleanup) <- newTempDirWithin testRoot - a <- action tempDir `finally` cleanup - logWith recorder Debug LogCleanup - pure a - - runTestInDir $ \tmpDir -> do - logWith recorder Info $ LogTestDir tmpDir - _fs <- FS.materialiseVFT tmpDir tree - runSessionWithServer' plugins conf sessConf caps tmpDir act -- | Setup the test environment for isolated tests. -- @@ -649,6 +665,7 @@ runSessionWithServer' plugins conf sconf caps root s = withLock lock $ keepCurr putStrLn $ "Finishing canceling (took " <> showDuration t <> "s)" pure x + -- | Wait for the next progress end step waitForProgressDone :: Session () waitForProgressDone = skipManyTill anyMessage $ satisfyMaybe $ \case @@ -731,3 +748,20 @@ kick proxyMsg = do case fromJSON _params of Success x -> return x other -> error $ "Failed to parse kick/done details: " <> show other + +expectNoKickDiagnostic :: Session () +expectNoKickDiagnostic = captureKickDiagnostics >>= \case + [] -> pure () + diags -> error $ "Expected no diagnostics, but got: " <> show diags + + +captureKickDiagnostics :: Session [Diagnostic] +captureKickDiagnostics = do + _ <- skipManyTill anyMessage nonTrivialKickStart + messages <- manyTill anyMessage nonTrivialKickDone + pure $ concat $ mapMaybe diagnostics messages + where + diagnostics :: FromServerMessage' a -> Maybe [Diagnostic] + diagnostics = \msg -> case msg of + FromServerMess SMethod_TextDocumentPublishDiagnostics diags -> Just (diags ^. L.params . L.diagnostics) + _ -> Nothing diff --git a/hls-test-utils/src/Test/Hls/FileSystem.hs b/hls-test-utils/src/Test/Hls/FileSystem.hs index b6742c4b83..a5a146e50c 100644 --- a/hls-test-utils/src/Test/Hls/FileSystem.hs +++ b/hls-test-utils/src/Test/Hls/FileSystem.hs @@ -20,6 +20,7 @@ module Test.Hls.FileSystem , directory , text , ref + , copyDir -- * Cradle helpers , directCradle , simpleCabalCradle @@ -30,6 +31,7 @@ module Test.Hls.FileSystem , simpleCabalProject' ) where +import Control.Monad.Extra (partitionM) import Data.Foldable (traverse_) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -66,6 +68,7 @@ data VirtualFileTree = data FileTree = File FilePath Content | Directory FilePath [FileTree] + | CopiedDirectory FilePath deriving (Show, Eq, Ord) data Content @@ -99,12 +102,15 @@ materialise rootDir' fileTree testDataDir' = do rootDir = FP.normalise rootDir' persist :: FilePath -> FileTree -> IO () - persist fp (File name cts) = case cts of - Inline txt -> T.writeFile (fp name) txt - Ref path -> copyFile (testDataDir FP.normalise path) (fp takeFileName name) - persist fp (Directory name nodes) = do - createDirectory (fp name) - mapM_ (persist (fp name)) nodes + persist root (File name cts) = case cts of + Inline txt -> T.writeFile (root name) txt + Ref path -> copyFile (testDataDir FP.normalise path) (root takeFileName name) + persist root (Directory name nodes) = do + createDirectory (root name) + mapM_ (persist (root name)) nodes + persist root (CopiedDirectory name) = do + nodes <- copyDir' testDataDir' name + mapM_ (persist root) nodes traverse_ (persist rootDir) fileTree pure $ FileSystem rootDir fileTree testDataDir @@ -154,6 +160,23 @@ file fp cts = File fp cts copy :: FilePath -> FileTree copy fp = File fp (Ref fp) +copyDir :: FilePath -> FileTree +copyDir dir = CopiedDirectory dir + +copyDirRecursive :: FilePath -> FilePath -> FilePath -> IO [FileTree] +copyDirRecursive previousDir root dir = do + let currentDir = root previousDir dir + let relativeDir = previousDir dir + filesOrFolders <- listDirectory currentDir + (files,folders) <- partitionM (doesFileExist . (currentDir )) filesOrFolders + let copiedFiles = fmap (copy . (relativeDir )) files + copiedDirs <- traverse (\subDir -> directory subDir <$> copyDirRecursive relativeDir root subDir) folders + return $ copiedFiles <> copiedDirs + +-- | Copy a directory into a test project. +copyDir' :: FilePath -> FilePath -> IO [FileTree] +copyDir' = copyDirRecursive "" + directory :: FilePath -> [FileTree] -> FileTree directory name nodes = Directory name nodes diff --git a/plugins/hls-core-plugin/README.md b/plugins/hls-core-plugin/README.md new file mode 100644 index 0000000000..622671029b --- /dev/null +++ b/plugins/hls-core-plugin/README.md @@ -0,0 +1,5 @@ +# Core (LSP) plugin for Haskell language server + +## Purpose + +This plugin provides the core functionality for the Haskell language server. It is based on the [Haskell IDE Engine]. diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs new file mode 100644 index 0000000000..08830864de --- /dev/null +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + + +module Ide.Plugin.Core(descriptor, CoreLog) where + +import Control.Monad.IO.Class (liftIO) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import Development.IDE +import qualified Development.IDE.Core.Shake as Shake +import Ide.Plugin.Core.Actions (refsAtPoint, workspaceSymbols) +import Ide.Plugin.Core.HoverDefinition +import Ide.Plugin.Core.Outline (moduleOutline) +import Ide.Plugin.Error (getNormalizedFilePathE) +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types (DefinitionParams (..), + DocumentHighlightParams (..), + HoverParams (..), + ReferenceParams (..), + TextDocumentIdentifier (..), + TextDocumentPositionParams (..), + TypeDefinitionParams (..), + WorkspaceSymbolParams (..), + type (|?) (InL)) + +data CoreLog + = LogShake Shake.Log + | CoreLogMsg Text + +instance Pretty CoreLog where + pretty theLog = case theLog of + LogShake shakeLog -> pretty shakeLog + CoreLogMsg msg -> "Core Message: " <> pretty msg + + + +descriptor :: Recorder (WithPriority CoreLog) -> PluginId -> PluginDescriptor IdeState +descriptor _recorder plId = + defaultPluginDescriptor plId "Provides core IDE features for Haskell" + -- { + -- Ide.Types.pluginHandlers = + -- mkPluginHandler SMethod_TextDocumentDocumentSymbol moduleOutline + -- <> mkPluginHandler SMethod_TextDocumentDefinition (\ide _ DefinitionParams{..} -> + -- gotoDefinition ide TextDocumentPositionParams{..}) + -- <> mkPluginHandler SMethod_TextDocumentTypeDefinition (\ide _ TypeDefinitionParams{..} -> + -- gotoTypeDefinition ide TextDocumentPositionParams{..}) + -- <> mkPluginHandler SMethod_TextDocumentDocumentHighlight (\ide _ DocumentHighlightParams{..} -> + -- documentHighlight ide TextDocumentPositionParams{..}) + -- <> mkPluginHandler SMethod_TextDocumentHover hover' + -- <> mkPluginHandler SMethod_WorkspaceSymbol (wsSymbols recorder) + -- <> mkPluginHandler SMethod_TextDocumentReferences references + -- } + + +wsSymbols :: Recorder (WithPriority CoreLog) -> PluginMethodHandler IdeState Method_WorkspaceSymbol +wsSymbols logger ide _ (WorkspaceSymbolParams _ _ query) = liftIO $ do + logWith logger Debug $ CoreLogMsg $ "Workspace symbols request: " <> query + runIdeAction "WorkspaceSymbols" (shakeExtras ide) $ InL . fromMaybe [] <$> workspaceSymbols query + + + +references :: PluginMethodHandler IdeState Method_TextDocumentReferences +references ide _ (ReferenceParams (TextDocumentIdentifier uri) pos _ _ _) = do + nfp <- getNormalizedFilePathE uri + liftIO $ logDebug (ideLogger ide) $ + "References request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack (show nfp) + InL <$> (liftIO $ runAction "references" ide $ refsAtPoint nfp pos) + + +hover' :: PluginMethodHandler IdeState Method_TextDocumentHover +hover' ideState _ HoverParams{..} = do + liftIO $ logDebug (ideLogger ideState) "GhcIde.hover entered (ideLogger)" -- AZ + hover ideState TextDocumentPositionParams{..} diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs new file mode 100644 index 0000000000..4a5d3879f5 --- /dev/null +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Actions.hs @@ -0,0 +1,42 @@ +module Ide.Plugin.Core.Actions where + +import Control.Monad.Extra (mapMaybeM) +import Control.Monad.Reader +import Control.Monad.Trans.Maybe +import Data.Maybe +import qualified Data.Text as T +import Data.Tuple.Extra +import Development.IDE.Core.OfInterest +import Development.IDE.Core.PluginUtils +import Development.IDE.Core.PositionMapping +import Development.IDE.Core.RuleTypes +import Development.IDE.Core.Service +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat hiding (writeHieFile) +import Development.IDE.Graph +import qualified Development.IDE.Spans.AtPoint as AtPoint +import Development.IDE.Types.HscEnvEq (hscEnv) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types (DocumentHighlight (..), + SymbolInformation (..), + normalizedFilePathToUri, + uriToNormalizedFilePath) + +import qualified Data.HashMap.Strict as HM +import qualified HieDb + + +-- Refs are not an IDE action, so it is OK to be slow and (more) accurate +refsAtPoint :: NormalizedFilePath -> Position -> Action [Location] +refsAtPoint file pos = do + ShakeExtras{withHieDb} <- getShakeExtras + fs <- HM.keys <$> getFilesOfInterestUntracked + asts <- HM.fromList . mapMaybe sequence . zip fs <$> usesWithStale GetHieAst fs + AtPoint.referencesAtPoint withHieDb file pos (AtPoint.FOIReferences asts) + + +workspaceSymbols :: T.Text -> IdeAction (Maybe [SymbolInformation]) +workspaceSymbols query = runMaybeT $ do + ShakeExtras{withHieDb} <- ask + res <- liftIO $ withHieDb (\hieDb -> HieDb.searchDef hieDb $ T.unpack query) + pure $ mapMaybe AtPoint.defRowToSymbolInfo res diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core/HoverDefinition.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core/HoverDefinition.hs new file mode 100644 index 0000000000..5ebc03e5c3 --- /dev/null +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core/HoverDefinition.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Display information on hover. +module Ide.Plugin.Core.HoverDefinition + ( + -- * For haskell-language-server + hover + , gotoDefinition + , gotoTypeDefinition + , documentHighlight + -- , references + -- , wsSymbols + ) where + +import Control.Monad.Except (ExceptT) +import Control.Monad.IO.Class +import Data.Maybe (fromMaybe) +import Development.IDE.Core.Actions +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.Types.Location +import Ide.Logger +import Ide.Plugin.Error +import Ide.Types +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types +import qualified Language.LSP.Server as LSP + +import qualified Data.Text as T + +gotoDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentDefinition) +hover :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (Hover |? Null) +gotoTypeDefinition :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) (MessageResult Method_TextDocumentTypeDefinition) +documentHighlight :: IdeState -> TextDocumentPositionParams -> ExceptT PluginError (LSP.LspM c) ([DocumentHighlight] |? Null) +gotoDefinition = request "Definition" getDefinition (InR $ InR Null) (InL . Definition. InR) +gotoTypeDefinition = request "TypeDefinition" getTypeDefinition (InR $ InR Null) (InL . Definition. InR) +hover = request "Hover" getAtPoint (InR Null) foundHover +documentHighlight = request "DocumentHighlight" highlightAtPoint (InR Null) InL + + +foundHover :: (Maybe Range, [T.Text]) -> Hover |? Null +foundHover (mbRange, contents) = + InL $ Hover (InL $ MarkupContent MarkupKind_Markdown $ T.intercalate sectionSeparator contents) mbRange + +-- | Respond to and log a hover or go-to-definition request +request + :: T.Text + -> (NormalizedFilePath -> Position -> IdeAction (Maybe a)) + -> b + -> (a -> b) + -> IdeState + -> TextDocumentPositionParams + -> ExceptT PluginError (LSP.LspM c) b +request label getResults notFound found ide (TextDocumentPositionParams (TextDocumentIdentifier uri) pos) = liftIO $ do + mbResult <- case uriToFilePath' uri of + Just path -> logAndRunRequest label getResults ide pos path + Nothing -> pure Nothing + pure $ maybe notFound found mbResult + +logAndRunRequest :: T.Text -> (NormalizedFilePath -> Position -> IdeAction b) -> IdeState -> Position -> String -> IO b +logAndRunRequest label getResults ide pos path = do + let filePath = toNormalizedFilePath' path + logDebug (ideLogger ide) $ + label <> " request at position " <> T.pack (showPosition pos) <> + " in file: " <> T.pack path + runIdeAction (T.unpack label) (shakeExtras ide) (getResults filePath pos) diff --git a/plugins/hls-core-plugin/src/Ide/Plugin/Core/Outline.hs b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Outline.hs new file mode 100644 index 0000000000..96679dd907 --- /dev/null +++ b/plugins/hls-core-plugin/src/Ide/Plugin/Core/Outline.hs @@ -0,0 +1,289 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Ide.Plugin.Core.Outline + ( moduleOutline + ) +where + +import Control.Monad.IO.Class +import Data.Functor +import Data.Generics hiding (Prefix) +import Data.Maybe +import Development.IDE.Core.Rules +import Development.IDE.Core.Shake +import Development.IDE.GHC.Compat +import Development.IDE.GHC.Error (rangeToRealSrcSpan, + realSrcSpanToRange) +import Development.IDE.Types.Location +import Development.IDE.GHC.Util (printOutputable) +import Ide.Types +import Language.LSP.Protocol.Types (DocumentSymbol (..), + DocumentSymbolParams (DocumentSymbolParams, _textDocument), + SymbolKind (..), + TextDocumentIdentifier (TextDocumentIdentifier), + type (|?) (InL, InR), uriToFilePath) +import Language.LSP.Protocol.Message + +-- See Note [Guidelines For Using CPP In GHCIDE Import Statements] + +import Data.List.NonEmpty (nonEmpty) +import Data.Foldable (toList) + +#if !MIN_VERSION_ghc(9,3,0) +import qualified Data.Text as T +#endif + +moduleOutline + :: PluginMethodHandler IdeState Method_TextDocumentDocumentSymbol +moduleOutline ideState _ DocumentSymbolParams{ _textDocument = TextDocumentIdentifier uri } + = liftIO $ case uriToFilePath uri of + Just (toNormalizedFilePath' -> fp) -> do + mb_decls <- fmap fst <$> runAction "Outline" ideState (useWithStale GetParsedModule fp) + pure $ case mb_decls of + Nothing -> InL [] + Just ParsedModule { pm_parsed_source = L _ltop HsModule { hsmodName, hsmodDecls, hsmodImports } } + -> let + declSymbols = mapMaybe documentSymbolForDecl hsmodDecls + moduleSymbol = hsmodName >>= \case + (L (locA -> (RealSrcSpan l _)) m) -> Just $ + (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable m + , _kind = SymbolKind_File + , _range = Range (Position 0 0) (Position maxBound 0) -- _ltop is 0 0 0 0 + } + _ -> Nothing + importSymbols = maybe [] pure $ + documentSymbolForImportSummary + (mapMaybe documentSymbolForImport hsmodImports) + allSymbols = case moduleSymbol of + Nothing -> importSymbols <> declSymbols + Just x -> + [ x { _children = Just (importSymbols <> declSymbols) + } + ] + in + InR (InL allSymbols) + + + Nothing -> pure $ InL [] + +documentSymbolForDecl :: LHsDecl GhcPs -> Maybe DocumentSymbol +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ FamDecl { tcdFam = FamilyDecl { fdLName = L _ n, fdInfo, fdTyVars } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable n + <> (case printOutputable fdTyVars of + "" -> "" + t -> " " <> t + ) + , _detail = Just $ printOutputable fdInfo + , _kind = SymbolKind_Function + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ ClassDecl { tcdLName = L _ name, tcdSigs, tcdTyVars })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable name + <> (case printOutputable tcdTyVars of + "" -> "" + t -> " " <> t + ) + , _kind = SymbolKind_Interface + , _detail = Just "class" + , _children = + Just $ + [ (defDocumentSymbol l' :: DocumentSymbol) + { _name = printOutputable n + , _kind = SymbolKind_Method + , _selectionRange = realSrcSpanToRange l'' + } + | L (locA -> (RealSrcSpan l' _)) (ClassOpSig _ False names _) <- tcdSigs + , L (locA -> (RealSrcSpan l'' _)) n <- names + ] + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ DataDecl { tcdLName = L _ name, tcdDataDefn = HsDataDefn { dd_cons } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable name + , _kind = SymbolKind_Struct + , _children = + Just $ + [ (defDocumentSymbol l'' :: DocumentSymbol) + { _name = printOutputable n + , _kind = SymbolKind_Constructor + , _selectionRange = realSrcSpanToRange l' + , _children = toList <$> nonEmpty childs + } + | con <- extract_cons dd_cons + , let (cs, flds) = hsConDeclsBinders con + , let childs = mapMaybe cvtFld flds + , L (locA -> RealSrcSpan l' _) n <- cs + , let l'' = case con of + L (locA -> RealSrcSpan l''' _) _ -> l''' + _ -> l' + ] + } + where + cvtFld :: LFieldOcc GhcPs -> Maybe DocumentSymbol +#if MIN_VERSION_ghc(9,3,0) + cvtFld (L (locA -> RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) +#else + cvtFld (L (RealSrcSpan l' _) n) = Just $ (defDocumentSymbol l' :: DocumentSymbol) +#endif +#if MIN_VERSION_ghc(9,3,0) + { _name = printOutputable (unLoc (foLabel n)) +#else + { _name = printOutputable (unLoc (rdrNameFieldOcc n)) +#endif + , _kind = SymbolKind_Field + } + cvtFld _ = Nothing +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (TyClD _ SynDecl { tcdLName = L (locA -> (RealSrcSpan l' _)) n })) = Just + (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable n + , _kind = SymbolKind_TypeParameter + , _selectionRange = realSrcSpanToRange l' + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ ClsInstD { cid_inst = ClsInstDecl { cid_poly_ty } })) + = Just (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable cid_poly_ty + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ DataFamInstD { dfid_inst = DataFamInstDecl FamEqn { feqn_tycon, feqn_pats } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = +#if MIN_VERSION_ghc(9,3,0) + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) +#else + printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + (map printOutputable feqn_pats) +#endif + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (InstD _ TyFamInstD { tfid_inst = TyFamInstDecl _ FamEqn { feqn_tycon, feqn_pats } })) + = Just (defDocumentSymbol l :: DocumentSymbol) + { _name = +#if MIN_VERSION_ghc(9,3,0) + printOutputable $ pprHsArgsApp (unLoc feqn_tycon) Prefix (feqn_pats) +#else + printOutputable (unLoc feqn_tycon) <> " " <> T.unwords + (map printOutputable feqn_pats) +#endif + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (DerivD _ DerivDecl { deriv_type })) = + gfindtype deriv_type <&> \(L (_ :: SrcSpan) name) -> + (defDocumentSymbol l :: DocumentSymbol) { _name = printOutputable @(HsType GhcPs) + name + , _kind = SymbolKind_Interface + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ FunBind{fun_id = L _ name})) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable name + , _kind = SymbolKind_Function + } +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ValD _ PatBind{pat_lhs})) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = printOutputable pat_lhs + , _kind = SymbolKind_Function + } + +documentSymbolForDecl (L (locA -> (RealSrcSpan l _)) (ForD _ x)) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = case x of + ForeignImport{} -> name + ForeignExport{} -> name + , _kind = SymbolKind_Object + , _detail = case x of + ForeignImport{} -> Just "import" + ForeignExport{} -> Just "export" + } + where name = printOutputable $ unLoc $ fd_name x + +documentSymbolForDecl _ = Nothing + +-- | Wrap the Document imports into a hierarchical outline for +-- a better overview of symbols in scope. +-- If there are no imports, then no hierarchy will be created. +documentSymbolForImportSummary :: [DocumentSymbol] -> Maybe DocumentSymbol +documentSymbolForImportSummary [] = Nothing +documentSymbolForImportSummary importSymbols = + let + -- safe because if we have no ranges then we don't take this branch + mergeRanges xs = Range (minimum $ map _start xs) (maximum $ map _end xs) + importRange = mergeRanges $ map (\DocumentSymbol{_range} -> _range) importSymbols + in + Just (defDocumentSymbol (rangeToRealSrcSpan "" importRange)) + { _name = "imports" + , _kind = SymbolKind_Module + , _children = Just importSymbols + } + +documentSymbolForImport :: LImportDecl GhcPs -> Maybe DocumentSymbol +documentSymbolForImport (L (locA -> (RealSrcSpan l _)) ImportDecl { ideclName, ideclQualified }) = Just + (defDocumentSymbol l :: DocumentSymbol) + { _name = "import " <> printOutputable ideclName + , _kind = SymbolKind_Module + , _detail = case ideclQualified of { NotQualified -> Nothing; _ -> Just "qualified" } + } +documentSymbolForImport _ = Nothing + +defDocumentSymbol :: RealSrcSpan -> DocumentSymbol +defDocumentSymbol l = DocumentSymbol { .. } where + _detail = Nothing + _deprecated = Nothing + _name = "" + -- This used to be SkUnknown 0, which is invalid, as SymbolKinds start at 1, + -- therefore, I am replacing it with SymbolKind_File, which is the type for 1 + _kind = SymbolKind_File + _range = realSrcSpanToRange l + _selectionRange = realSrcSpanToRange l + _children = Nothing + _tags = Nothing + +-- the version of getConNames for ghc9 is restricted to only the renaming phase +hsConDeclsBinders :: LConDecl GhcPs + -> ([LIdP GhcPs], [LFieldOcc GhcPs]) + -- See hsLTyClDeclBinders for what this does + -- The function is boringly complicated because of the records + -- And since we only have equality, we have to be a little careful +hsConDeclsBinders cons + = go cons + where + go :: LConDecl GhcPs + -> ([LIdP GhcPs], [LFieldOcc GhcPs]) + go r + -- Don't re-mangle the location of field names, because we don't + -- have a record of the full location of the field declaration anyway + = case unLoc r of + -- remove only the first occurrence of any seen field in order to + -- avoid circumventing detection of duplicate fields (#9156) + ConDeclGADT { con_names = names, con_g_args = args } + -> (toList names, flds) + where + flds = get_flds_gadt args + + ConDeclH98 { con_name = name, con_args = args } + -> ([name], flds) + where + flds = get_flds_h98 args + + get_flds_h98 :: HsConDeclH98Details GhcPs + -> [LFieldOcc GhcPs] + get_flds_h98 (RecCon flds) = get_flds (reLoc flds) + get_flds_h98 _ = [] + + get_flds_gadt :: HsConDeclGADTDetails GhcPs + -> [LFieldOcc GhcPs] +#if MIN_VERSION_ghc(9,3,0) + get_flds_gadt (RecConGADT flds _) = get_flds (reLoc flds) +#else + get_flds_gadt (RecConGADT flds) = get_flds (reLoc flds) +#endif + get_flds_gadt _ = [] + + get_flds :: Located [LConDeclField GhcPs] + -> [LFieldOcc GhcPs] + get_flds flds = concatMap (cd_fld_names . unLoc) (unLoc flds) + + diff --git a/plugins/hls-core-plugin/test/CoreTest.hs b/plugins/hls-core-plugin/test/CoreTest.hs new file mode 100644 index 0000000000..2c08f5d954 --- /dev/null +++ b/plugins/hls-core-plugin/test/CoreTest.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +import qualified CompletionTests +import qualified CradleTests +import qualified FindDefinitionAndHoverTests +import qualified HighlightTests +import qualified InitializeResponseTests +import qualified OutlineTests +import qualified ReferenceTests +import Test.Hls (defaultTestRunner, testGroup) + + +main :: IO () +main = + defaultTestRunner $ + testGroup + "core" + [ + InitializeResponseTests.tests + , OutlineTests.tests + , CompletionTests.tests + , HighlightTests.tests + , FindDefinitionAndHoverTests.tests + , ReferenceTests.tests + , CradleTests.tests + ] diff --git a/plugins/hls-core-plugin/test/exe/CompletionTests.hs b/plugins/hls-core-plugin/test/exe/CompletionTests.hs new file mode 100644 index 0000000000..39a72a0394 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/CompletionTests.hs @@ -0,0 +1,581 @@ + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module CompletionTests (tests) where + +import Control.Lens ((^.)) +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Default +import Data.List.Extra +import Data.Maybe +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +import Development.IDE.Types.Location +import Ide.Plugin.Config +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import Test.Hls (knownBrokenForGhcVersions, + knownBrokenInEnv, + waitForTypecheck) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text) +import Test.Hls.Util (EnvSpec (..), OS (..), + knownBrokenOnWindows) +import Test.Tasty +import Test.Tasty.HUnit +import Util + + +tests :: TestTree +tests + = testGroup "completion" + [ + testGroup "non local" nonLocalCompletionTests + , testGroup "topLevel" topLevelCompletionTests + , testGroup "local" localCompletionTests + , testGroup "package" packageCompletionTests + , testGroup "project" projectCompletionTests + , testGroup "other" otherCompletionTests + , testGroup "doc" completionDocTests + ] + +testSessionWithCorePluginEmpty :: TestName -> Session () -> TestTree +testSessionWithCorePluginEmpty name = testCase name . runSessionWithCorePluginEmpty ["A.hs"] + +testSessionWithCorePluginEmptyWithCradle :: TestName -> T.Text -> Session () -> TestTree +testSessionWithCorePluginEmptyWithCradle name cradle = testCase name . runSessionWithCorePlugin (mkFs [file "hie.yaml" (text cradle)]) + +completionTest :: HasCallStack => String -> [T.Text] -> Position -> [(T.Text, CompletionItemKind, T.Text, Bool, Bool, Maybe [TextEdit])] -> TestTree +completionTest name src pos expected = testSessionWithCorePluginSingleFile name "A.hs" (T.unlines src) $ do + docId <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + compls <- getAndResolveCompletions docId pos + let compls' = [ (_label, _kind, _insertText, _additionalTextEdits) | CompletionItem{..} <- compls] + let emptyToMaybe x = if T.null x then Nothing else Just x + liftIO $ sortOn (Lens.view Lens._1) (take (length expected) compls') @?= + sortOn (Lens.view Lens._1) + [ (l, Just k, emptyToMaybe t, at) | (l,k,t,_,_,at) <- expected] + forM_ (zip compls expected) $ \(CompletionItem{..}, (_,_,_,expectedSig, expectedDocs, _)) -> do + when expectedSig $ + liftIO $ assertBool ("Missing type signature: " <> T.unpack _label) (isJust _detail) + when expectedDocs $ + liftIO $ assertBool ("Missing docs: " <> T.unpack _label) (isJust _documentation) + + +topLevelCompletionTests :: [TestTree] +topLevelCompletionTests = [ + completionTest + "variable" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "constructor" + ["bar = xx", "-- | haddock", "xxx :: ()", "xxx = ()", "-- | haddock", "data Xxx = XxxCon"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing) + ], + completionTest + "class method" + ["bar = xx", "class Xxx a where", "-- | haddock", "xxx :: ()", "xxx = ()"] + (Position 0 8) + [("xxx", CompletionItemKind_Function, "xxx", True, True, Nothing)], + completionTest + "type" + ["bar :: Xz", "zzz = ()", "-- | haddock", "data Xzz = XzzCon"] + (Position 0 9) + [("Xzz", CompletionItemKind_Struct, "Xzz", False, True, Nothing)], + completionTest + "class" + ["bar :: Xz", "zzz = ()", "-- | haddock", "class Xzz a"] + (Position 0 9) + [("Xzz", CompletionItemKind_Interface, "Xzz", False, True, Nothing)], + completionTest + "records" + ["data Person = Person { _personName:: String, _personAge:: Int}", "bar = Person { _pers }" ] + (Position 1 19) + [("_personName", CompletionItemKind_Function, "_personName", False, True, Nothing), + ("_personAge", CompletionItemKind_Function, "_personAge", False, True, Nothing)], + completionTest + "recordsConstructor" + ["data XxRecord = XyRecord { x:: String, y:: Int}", "bar = Xy" ] + (Position 1 19) + [("XyRecord", CompletionItemKind_Constructor, "XyRecord", False, True, Nothing), + ("XyRecord", CompletionItemKind_Snippet, "XyRecord {x=${1:_x}, y=${2:_y}}", False, True, Nothing)] + ] + +localCompletionTests :: [TestTree] +localCompletionTests = [ + completionTest + "argument" + ["bar (Just abcdef) abcdefg = abcd"] + (Position 0 32) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "let" + ["bar = let (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ," in abcd" + ] + (Position 2 15) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "where" + ["bar = abcd" + ," where (Just abcdef) = undefined" + ," abcdefg = let abcd = undefined in undefined" + ] + (Position 0 10) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing), + ("abcdefg", CompletionItemKind_Function , "abcdefg", True, False, Nothing) + ], + completionTest + "do/1" + ["bar = do" + ," Just abcdef <- undefined" + ," abcd" + ," abcdefg <- undefined" + ," pure ()" + ] + (Position 2 6) + [("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ], + completionTest + "do/2" + ["bar abcde = do" + ," Just [(abcdef,_)] <- undefined" + ," abcdefg <- undefined" + ," let abcdefgh = undefined" + ," (Just [abcdefghi]) = undefined" + ," abcd" + ," where" + ," abcdefghij = undefined" + ] + (Position 5 8) + [("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ,("abcdefghij", CompletionItemKind_Function, "abcdefghij", True, False, Nothing) + ,("abcdef", CompletionItemKind_Function, "abcdef", True, False, Nothing) + ,("abcdefg", CompletionItemKind_Function, "abcdefg", True, False, Nothing) + ,("abcdefgh", CompletionItemKind_Function, "abcdefgh", True, False, Nothing) + ,("abcdefghi", CompletionItemKind_Function, "abcdefghi", True, False, Nothing) + ], + completionTest + "type family" + ["{-# LANGUAGE DataKinds, TypeFamilies #-}" + ,"type family Bar a" + ,"a :: Ba" + ] + (Position 2 7) + [("Bar", CompletionItemKind_Struct, "Bar", True, False, Nothing) + ], + completionTest + "class method" + [ + "class Test a where" + , " abcd :: a -> ()" + , " abcde :: a -> Int" + , "instance Test Int where" + , " abcd = abc" + ] + (Position 4 14) + [("abcd", CompletionItemKind_Function, "abcd", True, False, Nothing) + ,("abcde", CompletionItemKind_Function, "abcde", True, False, Nothing) + ], + testSessionWithCorePluginEmpty "incomplete entries" $ do + let src a = "data Data = " <> a + doc <- createDoc "A.hs" "haskell" $ src "AAA" + void $ waitForTypecheck doc + let editA rhs = + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ src rhs] + editA "AAAA" + void $ waitForTypecheck doc + editA "AAAAA" + void $ waitForTypecheck doc + + compls <- getCompletions doc (Position 0 15) + liftIO $ filter ("AAA" `T.isPrefixOf`) (mapMaybe _insertText compls) @?= ["AAAAA"] + pure () + ] + +nonLocalCompletionTests :: [TestTree] +nonLocalCompletionTests = + [ brokenForWinGhc $ completionTest + "variable" + ["module A where", "f = hea"] + (Position 1 7) + [("head", CompletionItemKind_Function, "head", True, True, Nothing)], + completionTest + "constructor" + ["{-# OPTIONS_GHC -Wall #-}", "module A where", "f = True"] + (Position 2 8) + [ ("True", CompletionItemKind_Constructor, "True", True, True, Nothing) + ], + brokenForWinGhc $ completionTest + "type" + ["{-# OPTIONS_GHC -Wall #-}", "module A () where", "f :: Boo", "f = True"] + (Position 2 8) + [ ("Bool", CompletionItemKind_Struct, "Bool", True, True, Nothing) + ], + completionTest + "qualified" + ["{-# OPTIONS_GHC -Wunused-binds #-}", "module A () where", "f = Prelude.hea"] + (Position 2 15) + [ ("head", CompletionItemKind_Function, "head", True, True, Nothing) + ], + completionTest + "duplicate import" + ["module A where", "import Data.List", "import Data.List", "f = permu"] + (Position 3 9) + [ ("permutations", CompletionItemKind_Function, "permutations", False, False, Nothing) + ], + completionTest + "dont show hidden items" + [ "{-# LANGUAGE NoImplicitPrelude #-}", + "module A where", + "import Control.Monad hiding (join)", + "f = joi" + ] + (Position 3 6) + [], + testGroup "ordering" + [completionTest "qualified has priority" + ["module A where" + ,"import qualified Data.ByteString as BS" + ,"f = BS.read" + ] + (Position 2 10) + [("readFile", CompletionItemKind_Function, "readFile", True, True, Nothing)] + ], + -- we need this test to make sure the ghcide completions module does not return completions for language pragmas. this functionality is turned on in hls + completionTest + "do not show pragma completions" + [ "{-# LANGUAGE ", + "{module A where}", + "main = return ()" + ] + (Position 0 13) + [] + ] + where + brokenForWinGhc = knownBrokenOnWindows "Windows has strange things in scope for some reason" + +otherCompletionTests :: [TestTree] +otherCompletionTests = [ + completionTest + "keyword" + ["module A where", "f = newty"] + (Position 1 9) + [("newtype", CompletionItemKind_Keyword, "", False, False, Nothing)], + completionTest + "type context" + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "f = f", + "g :: Intege" + ] + -- At this point the module parses but does not typecheck. + -- This should be sufficient to detect that we are in a + -- type context and only show the completion to the type. + (Position 3 11) + [("Integer", CompletionItemKind_Struct, "Integer", True, True, Nothing)], + + testSessionWithCorePluginEmpty "duplicate record fields" $ do + void $ + createDoc "B.hs" "haskell" $ + T.unlines + [ "{-# LANGUAGE DuplicateRecordFields #-}", + "module B where", + "newtype Foo = Foo { member :: () }", + "newtype Bar = Bar { member :: () }" + ] + docA <- + createDoc "A.hs" "haskell" $ + T.unlines + [ "module A where", + "import B", + "memb" + ] + _ <- waitForDiagnostics + compls <- getCompletions docA $ Position 2 4 + let compls' = [txt | CompletionItem {_insertText = Just txt, ..} <- compls, _label == "member"] + liftIO $ take 1 compls' @?= ["member"], + + testSessionWithCorePluginEmpty "maxCompletions" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = Prelude." + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + liftIO $ length compls @?= maxCompletions def + ] + +packageCompletionTests :: [TestTree] +packageCompletionTests = + [ testSessionWithCorePluginEmptyWithCradle "fromList" "cradle: {direct: {arguments: [-hide-all-packages, -package, base, A]}}" $ do + + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 12) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "fromList" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) ( + [ "'Data.List.NonEmpty" + , "'GHC.Exts" + ] ++ if ghcVersion >= GHC94 then [ "'GHC.IsList" ] else []) + + , testSessionWithCorePluginEmpty "Map" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "a :: Map" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 2 7) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "Map" + ] + liftIO $ take 3 (sort compls') @?= + map ("Defined in "<>) + [ "'Data.Map" + , "'Data.Map.Lazy" + , "'Data.Map.Strict" + ] + , testSessionWithCorePluginEmpty "no duplicates" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let duplicate = + filter + (\case + CompletionItem + { _insertText = Just "fromList" + , _documentation = + Just (InR (MarkupContent MarkupKind_Markdown d)) + } -> + "GHC.Exts" `T.isInfixOf` d + _ -> False + ) compls + liftIO $ length duplicate @?= 1 + + , testSessionWithCorePluginEmpty "non-local before global" $ do + -- non local completions are more specific + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "{-# OPTIONS_GHC -Wunused-binds #-}", + "module A () where", + "import GHC.Exts(fromList)", + "a = fromList" + ] + _ <- waitForDiagnostics + compls <- getCompletions doc (Position 3 13) + let compls' = + [_insertText + | CompletionItem {_label, _insertText} <- compls + , _label == "fromList" + ] + liftIO $ take 3 compls' @?= + map Just ["fromList"] + ] + +projectCompletionTests :: [TestTree] +projectCompletionTests = + [ testSessionWithCorePluginEmptyWithCradle "from hiedb" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "b = anidenti" + ] + compls <- getCompletions doc (Position 1 10) + let compls' = + [T.drop 1 $ T.dropEnd 3 d + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown d)), _label} + <- compls + , _label == "anidentifier" + ] + liftIO $ compls' @?= ["Defined in 'A"], + testSessionWithCorePluginEmptyWithCradle "auto complete project imports" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"ALocalModule\", \"B\"]}}" $ do + _ <- createDoc "ALocalModule.hs" "haskell" $ T.unlines + [ "module ALocalModule (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + -- Note that B does not import A + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import ALocal" + ] + compls <- getCompletions doc (Position 1 13) + let item = head $ filter ((== "ALocalModule") . (^. L.label)) compls + liftIO $ do + item ^. L.label @?= "ALocalModule", + testSessionWithCorePluginEmptyWithCradle "auto complete functions from qualified imports without alias" "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A", + "A." + ] + compls <- getCompletions doc (Position 2 2) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier", + testSessionWithCorePluginEmptyWithCradle "auto complete functions from qualified imports with alias" + "cradle: {direct: {arguments: [\"-Wmissing-signatures\", \"A\", \"B\"]}}" $ do + _ <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A (anidentifier) where", + "anidentifier = ()" + ] + _ <- waitForDiagnostics + doc <- createDoc "B.hs" "haskell" $ T.unlines + [ "module B where", + "import qualified A as Alias", + "foo = Alias." + ] + compls <- getCompletions doc (Position 2 12) + let item = head compls + liftIO $ do + item ^. L.label @?= "anidentifier" + ] + +completionDocTests :: [TestTree] +completionDocTests = + [ testSessionWithCorePluginEmpty "local define" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + let expected = "*Defined at line 2, column 1 in this module*\n" + test doc (Position 2 8) "foo" Nothing [expected] + , testSessionWithCorePluginEmpty "local empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 2 8) "foo" Nothing ["*Defined at line 2, column 1 in this module*\n"] + , testSessionWithCorePluginEmpty "local single line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- |docdoc" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 3 8) "foo" Nothing ["*Defined at line 3, column 1 in this module*\n* * *\n\n\ndocdoc\n"] + , testSessionWithCorePluginEmpty "local multi line doc with newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 4 8) "foo" Nothing ["*Defined at line 4, column 1 in this module*\n* * *\n\n\nabcabc\n"] + , testSessionWithCorePluginEmpty "local multi line doc without newline" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "-- | abcabc" + , "--" + , "--def" + , "foo = ()" + , "bar = fo" + ] + test doc (Position 5 8) "foo" Nothing ["*Defined at line 5, column 1 in this module*\n* * *\n\n\nabcabc \n\ndef\n"] + , testSessionWithCorePluginEmpty "extern empty doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = od" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 8) "odd" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ testSessionWithCorePluginEmpty "extern single line doc without '\\n'" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = no" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nBoolean \"not\"\n" + test doc (Position 1 8) "not" (Just $ T.length expected) [expected] + , brokenForMacGhc9 $ testSessionWithCorePluginEmpty "extern mulit line doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n* * *\n\n\nIdentity function. \n```haskell\nid x = x\n```\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + , testSessionWithCorePluginEmpty "extern defined doc" $ do + doc <- createDoc "A.hs" "haskell" $ T.unlines + [ "module A where" + , "foo = i" + ] + let expected = "*Imported from 'Prelude'*\n" + test doc (Position 1 7) "id" (Just $ T.length expected) [expected] + ] + where + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20903 + brokenForMacGhc9 = knownBrokenInEnv [] "Extern doc doesn't support MacOS for ghc9" + test doc pos label mn expected = do + _ <- waitForDiagnostics + compls <- getCompletions doc pos + rcompls <- forM compls $ \item -> do + if isJust (item ^. L.data_) + then do + rsp <- request SMethod_CompletionItemResolve item + case rsp ^. L.result of + Left err -> liftIO $ assertFailure ("completionItem/resolve failed with: " <> show err) + Right x -> pure x + else pure item + let compls' = [ + -- We ignore doc uris since it points to the local path which determined by specific machines + case mn of + Nothing -> txt + Just n -> T.take n txt + | CompletionItem {_documentation = Just (InR (MarkupContent MarkupKind_Markdown txt)), ..} <- rcompls + , _label == label + ] + liftIO $ compls' @?= expected diff --git a/plugins/hls-core-plugin/test/exe/CradleTests.hs b/plugins/hls-core-plugin/test/exe/CradleTests.hs new file mode 100644 index 0000000000..a632329c91 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/CradleTests.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module CradleTests (tests) where + +import Control.Applicative.Combinators +import Control.Monad.IO.Class (liftIO) +import Data.Row +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.FilePath +import System.IO.Extra hiding (withTempDir) +-- import Test.QuickCheck.Instances () +import Control.Concurrent.Async (wait, withAsync) +import Control.Lens ((^.)) +import Development.IDE.Plugin.Test (WaitForIdeRuleResult (..)) +import GHC.TypeLits (symbolVal) +import System.Directory (getCurrentDirectory) +import Test.Hls (captureKickDiagnostics, + expectNoKickDiagnostic, + waitForAction, + waitForAllProgressDone) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (file, text, toAbsFp) +import Test.Hls.Util (knownBrokenForGhcVersions) +import Test.Tasty +import Test.Tasty.HUnit +import Util (checkDefs, expectDiagnostics, + expectDiagnosticsWithTags, + expectNoDiagnostic, + isReferenceReady, mkFs, mkL, + runSessionWithServerCorePlugin, + testSessionWithCorePlugin, + testSessionWithCorePluginEmptyVsf, + testSessionWithCorePluginSubDir) + + +tests :: TestTree +tests = testGroup "cradle" + [testGroup "dependencies" [sessionDepsArePickedUp] + ,testGroup "ignore-fatal" [ignoreFatalWarning] + ,testGroup "loading" [loadCradleOnlyonce, retryFailedCradle] + ,testGroup "multi" (multiTests "multi") + ,knownBrokenForGhcVersions [GHC92] "multiple units not supported on 9.2" + $ testGroup "multi-unit" (multiTests "multi-unit") + ,testGroup "sub-directory" [simpleSubDirectoryTest] + ,knownBrokenForGhcVersions [GHC92] "multiple units not supported on 9.2" + $ testGroup "multi-unit-rexport" [multiRexportTest] + ] + +loadCradleOnlyonce :: TestTree +loadCradleOnlyonce = testGroup "load cradle only once" + [ testSessionWithCorePluginEmptyVsf "implicit" test + , testSessionWithCorePlugin "direct" (mkFs [FS.directCradle ["B.hs", "A.hs"]]) test + ] + where + test = do + doc <- createDoc "B.hs" "haskell" "module B where\nimport Data.Foo" + msgs <- someTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 1 + changeDoc doc [TextDocumentContentChangeEvent . InR . (.==) #text $ "module B where\nimport Data.Maybe"] + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + _ <- createDoc "A.hs" "haskell" "module A where\nimport LoadCradleBar" + msgs <- manyTill (skipManyTill anyMessage cradleLoadedMessage) (skipManyTill anyMessage (message SMethod_TextDocumentPublishDiagnostics)) + liftIO $ length msgs @?= 0 + +retryFailedCradle :: TestTree +retryFailedCradle = testSessionWithCorePluginEmptyVsf "retry failed" $ \fs -> do + -- The false cradle always fails + let hieContents = "cradle: {bios: {shell: \"false\"}}" + hiePath = "hie.yaml" + liftIO $ writeFile hiePath hieContents + let aPath = "A.hs" + doc <- createDoc aPath "haskell" "main = return ()" + WaitForIdeRuleResult {..} <- handleEither (waitForAction "TypeCheck" doc) + liftIO $ "Test assumption failed: cradle should error out" `assertBool` not ideResultSuccess + + -- Fix the cradle and typecheck again + let validCradle = "cradle: {bios: {shell: \"echo A.hs\"}}" + liftIO $ writeFileUTF8 hiePath $ T.unpack validCradle + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams + [FileEvent (filePathToUri $ toAbsFp fs "hie.yaml") FileChangeType_Changed ] + + WaitForIdeRuleResult {..} <- handleEither (waitForAction "TypeCheck" doc) + liftIO $ "No joy after fixing the cradle" `assertBool` ideResultSuccess + +handleEither :: Session (Either ResponseError b) -> Session b +handleEither sei = do + ei <- sei + case ei of + Left e -> liftIO $ assertFailure $ show e + Right x -> pure x + +cradleLoadedMessage :: Session FromServerMessage +cradleLoadedMessage = satisfy $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess _) -> symbolVal p == cradleLoadedMethod + _ -> False + +cradleLoadedMethod :: String +cradleLoadedMethod = "ghcide/cradle/loaded" + +ignoreFatalWarning :: TestTree +ignoreFatalWarning = testSessionWithCorePluginSubDir "ignore-fatal-warning" "ignore-fatal" $ do + _ <- openDoc "IgnoreFatal.hs" "haskell" + diags <- captureKickDiagnostics + liftIO $ assertBool "Expecting no warning" $ null diags + + +simpleSubDirectoryTest :: TestTree +simpleSubDirectoryTest = + testSessionWithCorePluginSubDir "simple-subdirectory" "cabal-exe" $ do + let mainPath = "a/src/Main.hs" + _mdoc <- openDoc mainPath "haskell" + waitForAllProgressDone + expectDiagnosticsWithTags + [("a/src/Main.hs", [(DiagnosticSeverity_Warning,(2,0), "Top-level binding", Nothing)]) -- So that we know P has been loaded + ] + +multiTests :: FilePath -> [TestTree] +multiTests dir = + [simpleMultiTest dir, simpleMultiTest2 dir, simpleMultiTest3 dir +-- simpleMultiDefTest dir + ] + +multiTestName :: FilePath -> String -> String +multiTestName dir name = "simple-" ++ dir ++ "-" ++ name + +simpleMultiTest :: FilePath -> TestTree +simpleMultiTest variant = testSessionWithCorePluginSubDir (multiTestName variant "test") variant $ do + let aPath = "a/A.hs" + bPath = "b/B.hs" + adoc <- openDoc aPath "haskell" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {..} <- handleEither $ waitForAction "TypeCheck" adoc + liftIO $ assertBool "A should typecheck" ideResultSuccess + WaitForIdeRuleResult {..} <- handleEither $ waitForAction "TypeCheck" bdoc + liftIO $ assertBool "B should typecheck" ideResultSuccess + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL (adoc ^. L.uri) 2 0 2 3 + checkDefs locs (pure [fooL]) + +-- Like simpleMultiTest but open the files in the other order +simpleMultiTest2 :: FilePath -> TestTree +simpleMultiTest2 variant = testSessionWithCorePluginSubDir (multiTestName variant "test2") variant $ \fs -> do + let aPath = "a/A.hs" + bPath = "b/B.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" bdoc + adoc@(TextDocumentIdentifier auri) <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady (toAbsFp fs aPath) + locs <- getDefinitions bdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoDiagnostic [adoc, bdoc] + +-- Now with 3 components +simpleMultiTest3 :: FilePath -> TestTree +simpleMultiTest3 variant = + testSessionWithCorePluginSubDir (multiTestName variant "test3") variant $ \fs -> do + let aPath = "a/A.hs" + bPath = "b/B.hs" + cPath = "c/C.hs" + bdoc <- openDoc bPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" bdoc + adoc@(TextDocumentIdentifier auri) <- openDoc aPath "haskell" + skipManyTill anyMessage $ isReferenceReady (toAbsFp fs aPath) + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 2 7) + let fooL = mkL auri 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoDiagnostic [adoc, cdoc, bdoc] + + +-- todo add back this when we have a way to open a file in a separate session in the same test +-- -- Like simpleMultiTest but open the files in component 'a' in a separate session +-- simpleMultiDefTest :: FilePath -> TestTree +-- simpleMultiDefTest variant = do +-- testSessionWithCorePluginSubDir (multiTestName variant "def-test") variant $ \fs -> do +-- let aPath = "a/A.hs" +-- bPath = "b/B.hs" +-- aAbsPath = toAbsFp fs aPath +-- rootAbs = toAbsFp fs "" +-- -- should share the same session +-- -- adoc <- liftIO $ withAsync (runSessionWithServerCorePlugin rootAbs $ do +-- -- doc <- openDoc aAbsPath "haskell" +-- -- skipManyTill anyMessage $ isReferenceReady $ aAbsPath +-- -- return doc) (\t1 -> wait t1) +-- let adoc = TextDocumentIdentifier $ filePathToUri aAbsPath +-- bdoc <- openDoc bPath "haskell" +-- locs <- getDefinitions bdoc (Position 2 7) +-- let fooL = mkL (adoc ^. L.uri) 2 0 2 3 +-- checkDefs locs (pure [fooL]) +-- expectNoDiagnostic [adoc, bdoc] + +multiRexportTest :: TestTree +multiRexportTest = + testSessionWithCorePluginSubDir "multi-unit-reexport-test" "multi-unit-reexport" $ do + let cPath = "c/C.hs" + cdoc <- openDoc cPath "haskell" + WaitForIdeRuleResult {} <- handleEither $ waitForAction "TypeCheck" cdoc + locs <- getDefinitions cdoc (Position 3 7) + let aPath = "a/A.hs" + let fooL = mkL (filePathToUri aPath) 2 0 2 3 + checkDefs locs (pure [fooL]) + expectNoDiagnostic [cdoc] + +sessionDepsArePickedUp :: TestTree +sessionDepsArePickedUp = testSessionWithCorePlugin + "session-deps-are-picked-up" (mkFs [file "Foo.hs" (text fooContent) , file "hie.yaml" (text "cradle: {direct: {arguments: [-XOverloadedStrings]}}")]) + $ \fs -> do + doc <- openDoc "Foo.hs" "haskell" + expectNoKickDiagnostic + cwd <- liftIO getCurrentDirectory + liftIO $ + writeFileUTF8 + "hie.yaml" + "cradle: {direct: {arguments: []}}" + liftIO $ (filePathToUri $ cwd "hie.yaml") @?= (filePathToUri $ toAbsFp fs "hie.yaml") + sendNotification SMethod_WorkspaceDidChangeWatchedFiles $ DidChangeWatchedFilesParams [FileEvent (filePathToUri $ cwd "hie.yaml") FileChangeType_Changed] + -- Send change event. + let change = + TextDocumentContentChangeEvent $ InL $ #range .== Range (Position 4 0) (Position 4 0) + .+ #rangeLength .== Nothing + .+ #text .== "\n" + changeDoc doc [change] + expectDiagnostics [("Foo.hs", [(DiagnosticSeverity_Error, (3, 6), "Couldn't match type")])] + + where + fooContent = + T.unlines + [ "module Foo where", + "import Data.Text", + "foo :: Text", + "foo = \"hello\"" + ] diff --git a/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs new file mode 100644 index 0000000000..498cb4ab33 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/FindDefinitionAndHoverTests.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module FindDefinitionAndHoverTests (tests) where + +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.Foldable +import Data.Maybe +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..), ghcVersion) +-- import Development.IDE.Test (expectDiagnostics, +-- standardizeQuotes) +import qualified Language.LSP.Protocol.Lens as L +-- import Language.LSP.Protocol.Types hiding +-- (SemanticTokenAbsolute (..), +-- SemanticTokenRelative (..), +-- SemanticTokensEdit (..), +-- mkRange) + +import Language.LSP.Protocol.Types (Hover (..), MarkupContent (..), + Position (..), Range, + TextDocumentIdentifier, mkRange, + type (|?) (..)) + +import Language.LSP.Test +import System.Info.Extra (isWindows) + +import Control.Lens ((^.)) +import Test.Tasty +import Test.Tasty.HUnit +-- import TestUtils +import Test.Hls (waitForProgressDone, + waitForTypecheck) +import Test.Hls.FileSystem (copyDir) +import Text.Regex.TDFA ((=~)) +import Util + +tests :: TestTree +tests = let + tst :: (TextDocumentIdentifier -> Position -> Session a, a -> Session [Expect] -> Session ()) -> Position -> String -> Session [Expect] -> String -> TestTree + tst (get, check) pos sfp targetRange title = + testSessionWithCorePlugin title (mkFs [copyDir "hover"]) $ do + doc <- openDoc sfp "haskell" + waitForProgressDone + x <- waitForTypecheck doc + found <- get doc pos + check found targetRange + + + + checkHover :: (HasCallStack) => Maybe Hover -> Session [Expect] -> Session () + checkHover hover expectations = traverse_ check =<< expectations where + + check :: (HasCallStack) => Expect -> Session () + check expected = + case hover of + Nothing -> unless (expected == ExpectNoHover) $ liftIO $ assertFailure "no hover found" + Just Hover{_contents = (InL MarkupContent{_value = standardizeQuotes -> msg}) + ,_range = rangeInHover } -> + case expected of + ExpectRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverRange expectedRange -> checkHoverRange expectedRange rangeInHover msg + ExpectHoverText snippets -> liftIO $ traverse_ (`assertFoundIn` msg) snippets + ExpectHoverExcludeText snippets -> liftIO $ traverse_ (`assertNotFoundIn` msg) snippets + ExpectHoverTextRegex re -> liftIO $ assertBool ("Regex not found in " <> T.unpack msg) (msg =~ re :: Bool) + ExpectNoHover -> liftIO $ assertFailure $ "Expected no hover but got " <> show hover + _ -> pure () -- all other expectations not relevant to hover + _ -> liftIO $ assertFailure $ "test not expecting this kind of hover info" <> show hover + + extractLineColFromHoverMsg :: T.Text -> [T.Text] + extractLineColFromHoverMsg = T.splitOn ":" . head . T.splitOn "*" . last . T.splitOn (sourceFileName <> ":") + + checkHoverRange :: Range -> Maybe Range -> T.Text -> Session () + checkHoverRange expectedRange rangeInHover msg = + let + lineCol = extractLineColFromHoverMsg msg + -- looks like hovers use 1-based numbering while definitions use 0-based + -- turns out that they are stored 1-based in RealSrcLoc by GHC itself. + adjust Position{_line = l, _character = c} = + Position{_line = l + 1, _character = c + 1} + in + case map (read . T.unpack) lineCol of + [l,c] -> liftIO $ adjust (expectedRange ^. L.start) @=? Position l c + _ -> liftIO $ assertFailure $ + "expected: " <> show ("[...]" <> sourceFileName <> "::**[...]", Just expectedRange) <> + "\n but got: " <> show (msg, rangeInHover) + + assertFoundIn :: T.Text -> T.Text -> Assertion + assertFoundIn part whole = assertBool + (T.unpack $ "failed to find: `" <> part <> "` in hover message:\n" <> whole) + (part `T.isInfixOf` whole) + + assertNotFoundIn :: T.Text -> T.Text -> Assertion + assertNotFoundIn part whole = assertBool + (T.unpack $ "found unexpected: `" <> part <> "` in hover message:\n" <> whole) + (not . T.isInfixOf part $ whole) + + sourceFilePath = T.unpack sourceFileName + sourceFileName = "GotoHover.hs" + + mkFindTests tests = testGroup "get" + [ testGroup "definition" $ mapMaybe fst tests + , testGroup "hover" $ mapMaybe snd tests + -- , checkFileCompiles sourceFilePath $ + -- expectDiagnostics + -- [ ( "GotoHover.hs", [(DiagnosticSeverity_Error, (62, 7), "Found hole: _")]) + -- , ( "GotoHover.hs", [(DiagnosticSeverity_Error, (65, 8), "Found hole: _")]) + -- ] + , testGroup "type-definition" typeDefinitionTests + , testGroup "hover-record-dot-syntax" recordDotSyntaxTests ] + + typeDefinitionTests = [ tst (getTypeDefinitions, checkDefs) aaaL14 sourceFilePath (pure tcData) "Saturated data con" + , tst (getTypeDefinitions, checkDefs) aL20 sourceFilePath (pure [ExpectNoDefinitions]) "Polymorphic variable"] + + recordDotSyntaxTests = + [ tst (getHover, checkHover) (Position 17 24) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["x :: MyRecord"]]) "hover over parent" + , tst (getHover, checkHover) (Position 17 25) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over dot shows child" + , tst (getHover, checkHover) (Position 17 26) (T.unpack "RecordDotSyntax.hs") (pure [ExpectHoverText ["_ :: MyChild"]]) "hover over child" + ] + + test :: (HasCallStack) => (TestTree -> a) -> (TestTree -> b) -> Position -> [Expect] -> String -> (a, b) + test runDef runHover look expect = testM runDef runHover look (return expect) + + testM :: (HasCallStack) => (TestTree -> a) + -> (TestTree -> b) + -> Position + -> Session [Expect] + -> String + -> (a, b) + testM runDef runHover look expect title = + ( runDef $ tst def look sourceFilePath expect title + , runHover $ tst hover look sourceFilePath expect title ) where + def = (getDefinitions, checkDefs) + hover = (getHover , checkHover) + + -- search locations expectations on results + fffL4 = fffR ^. L.start; fffR = mkRange 8 4 8 7 ; fff = [ExpectRange fffR] + fffL8 = Position 12 4 ; + fffL14 = Position 18 7 ; + aL20 = Position 19 15 + aaaL14 = Position 18 20 ; aaa = [mkR 11 0 11 3] + dcL7 = Position 11 11 ; tcDC = [mkR 7 23 9 16] + dcL12 = Position 16 11 ; + xtcL5 = Position 9 11 ; xtc = [ExpectExternFail, ExpectHoverText ["Int", "Defined in ", "GHC.Types", "ghc-prim"]] + tcL6 = Position 10 11 ; tcData = [mkR 7 0 9 16, ExpectHoverText ["TypeConstructor", "GotoHover.hs:8:1"]] + vvL16 = Position 20 12 ; vv = [mkR 20 4 20 6] + opL16 = Position 20 15 ; op = [mkR 21 2 21 4] + opL18 = Position 22 22 ; opp = [mkR 22 13 22 17] + aL18 = Position 22 20 ; apmp = [mkR 22 10 22 11] + b'L19 = Position 23 13 ; bp = [mkR 23 6 23 7] + xvL20 = Position 24 8 ; xvMsg = [ExpectExternFail, ExpectHoverText ["pack", ":: String -> Text", "Data.Text", "text"]] + clL23 = Position 27 11 ; cls = [mkR 25 0 26 20, ExpectHoverText ["MyClass", "GotoHover.hs:26:1"]] + clL25 = Position 29 9 + eclL15 = Position 19 8 ; ecls = [ExpectExternFail, ExpectHoverText ["Num", "Defined in ", "GHC.Num", "base"]] + dnbL29 = Position 33 18 ; dnb = [ExpectHoverText [":: ()"], mkR 33 12 33 21] + dnbL30 = Position 34 23 + lcbL33 = Position 37 26 ; lcb = [ExpectHoverText [":: Char"], mkR 37 26 37 27] + lclL33 = Position 37 22 + mclL36 = Position 40 1 ; mcl = [mkR 40 0 40 14] + mclL37 = Position 41 1 + spaceL37 = Position 41 24 ; space = [ExpectNoDefinitions, ExpectHoverText [":: Char"]] + docL41 = Position 45 1 ; doc = [ExpectHoverText ["Recognizable docs: kpqz"]] + ; constr = [ExpectHoverText ["Monad m"]] + eitL40 = Position 44 28 ; kindE = [ExpectHoverText [":: Type -> Type -> Type\n"]] + intL40 = Position 44 34 ; kindI = [ExpectHoverText [":: Type\n"]] + tvrL40 = Position 44 37 ; kindV = [ExpectHoverText [":: * -> *\n"]] + intL41 = Position 45 20 ; litI = [ExpectHoverText ["7518"]] + chrL36 = Position 41 24 ; litC = [ExpectHoverText ["'f'"]] + txtL8 = Position 12 14 ; litT = [ExpectHoverText ["\"dfgy\""]] + lstL43 = Position 47 12 ; litL = [ExpectHoverText ["[8391 :: Int, 6268]"]] + outL45 = Position 49 3 ; outSig = [ExpectHoverText ["outer", "Bool"], mkR 50 0 50 5] + innL48 = Position 52 5 ; innSig = [ExpectHoverText ["inner", "Char"], mkR 49 2 49 7] + holeL60 = Position 62 7 ; hleInfo = [ExpectHoverText ["_ ::"]] + holeL65 = Position 65 8 ; hleInfo2 = [ExpectHoverText ["_ :: a -> Maybe a"]] + cccL17 = Position 17 16 ; docLink = [ExpectHoverTextRegex "\\*Defined in 'GHC.Types'\\* \\*\\(ghc-prim-[0-9.]+\\)\\*\n\n"] + imported = Position 56 13 ; importedSig = getDocUri "Foo.hs" >>= \foo -> return [ExpectHoverText ["foo", "Foo", "Haddock"], mkL foo 5 0 5 3] + reexported = Position 55 14 ; reexportedSig = getDocUri "Bar.hs" >>= \bar -> return [ExpectHoverText ["Bar", "Bar", "Haddock"], mkL bar 3 (if ghcVersion >= GHC94 then 5 else 0) 3 (if ghcVersion >= GHC94 then 8 else 14)] + thLocL57 = Position 59 10 ; thLoc = [ExpectHoverText ["Identity"]] + cmtL68 = Position 67 0 ; lackOfdEq = [ExpectHoverExcludeText ["$dEq"]] + import310 = Position 3 10; pkgTxt = [ExpectHoverText ["Data.Text\n\ntext-"]] + in + mkFindTests + -- def hover look expect + [ -- It suggests either going to the constructor or to the field + test broken yes fffL4 fff "field in record definition" + , test yes yes fffL8 fff "field in record construction #1102" + , test yes yes fffL14 fff "field name used as accessor" -- https://github.com/haskell/ghcide/pull/120 in Calculate.hs + , test yes yes aaaL14 aaa "top-level name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes dcL7 tcDC "data constructor record #1029" + , test yes yes dcL12 tcDC "data constructor plain" -- https://github.com/haskell/ghcide/pull/121 + , test yes yes tcL6 tcData "type constructor #1028" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes xtcL5 xtc "type constructor external #717,1028" + , test broken yes xvL20 xvMsg "value external package #717" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes vvL16 vv "plain parameter" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes aL18 apmp "pattern match name" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL16 op "top-level operator #713" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes opL18 opp "parameter operator" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes b'L19 bp "name in backticks" -- https://github.com/haskell/ghcide/pull/120 + , test yes yes clL23 cls "class in instance declaration #1027" + , test yes yes clL25 cls "class in signature #1027" -- https://github.com/haskell/ghcide/pull/147 + , test broken yes eclL15 ecls "external class in signature #717,1027" + , test yes yes dnbL29 dnb "do-notation bind #1073" + , test yes yes dnbL30 dnb "do-notation lookup" + , test yes yes lcbL33 lcb "listcomp bind #1073" + , test yes yes lclL33 lcb "listcomp lookup" + , test yes yes mclL36 mcl "top-level fn 1st clause" + , test yes yes mclL37 mcl "top-level fn 2nd clause #1030" + , test yes yes spaceL37 space "top-level fn on space #1002" + , test no yes docL41 doc "documentation #1129" + , test no yes eitL40 kindE "kind of Either #1017" + , test no yes intL40 kindI "kind of Int #1017" + , test no broken tvrL40 kindV "kind of (* -> *) type variable #1017" + , test no broken intL41 litI "literal Int in hover info #1016" + , test no broken chrL36 litC "literal Char in hover info #1016" + , test no broken txtL8 litT "literal Text in hover info #1016" + , test no broken lstL43 litL "literal List in hover info #1016" + , test yes yes cmtL68 lackOfdEq "no Core symbols #3280" + , test no yes docL41 constr "type constraint in hover info #1012" + , test no yes outL45 outSig "top-level signature #767" + , test broken broken innL48 innSig "inner signature #767" + , test no yes holeL60 hleInfo "hole without internal name #831" + , test no yes holeL65 hleInfo2 "hole with variable" + , test no yes cccL17 docLink "Haddock html links" + , testM yes yes imported importedSig "Imported symbol" + , if isWindows then + -- Flaky on Windows: https://github.com/haskell/haskell-language-server/issues/2997 + testM no yes reexported reexportedSig "Imported symbol (reexported)" + else + testM yes yes reexported reexportedSig "Imported symbol (reexported)" + , test no yes thLocL57 thLoc "TH Splice Hover" + , test yes yes import310 pkgTxt "show package name and its version" + ] + where yes, broken :: (TestTree -> Maybe TestTree) + yes = Just -- test should run and pass + broken = Just . (`xfail` "known broken") + no = const Nothing -- don't run this test at all + --skip = const Nothing -- unreliable, don't run + +-- checkFileCompiles :: FilePath -> Session () -> TestTree +-- checkFileCompiles fp diag = +-- testSessionWithCorePluginSingleFile ("hover: Does " ++ fp ++ " compile") $ \dir -> do +-- void (openTestDataDoc fp) +-- diag diff --git a/plugins/hls-core-plugin/test/exe/HighlightTests.hs b/plugins/hls-core-plugin/test/exe/HighlightTests.hs new file mode 100644 index 0000000000..e46c10d63b --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/HighlightTests.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HighlightTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Text as T +import Development.IDE.GHC.Compat (GhcVersion (..)) +import Development.IDE.Types.Location +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import Test.Hls (knownBrokenForGhcVersions) +import Test.Tasty +import Test.Tasty.HUnit +import Util + + + +tests :: TestTree +tests = testGroup "highlight" + [ testSessionWait "value" source $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 3 2) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 0 2 3) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 0 3 3) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 6 4 9) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 5 22 5 25) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "type" source $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 2 8) + liftIO $ highlights @?= + [ DocumentHighlight (R 2 7 2 10) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 3 11 3 14) (Just DocumentHighlightKind_Read) + ] + , testSessionWait "local" source $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 6 5) + liftIO $ highlights @?= + [ DocumentHighlight (R 6 4 6 7) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 6 10 6 13) (Just DocumentHighlightKind_Read) + , DocumentHighlight (R 7 12 7 15) (Just DocumentHighlightKind_Read) + ] + , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "Ghc9 highlights the constructor and not just this field" $ + testSessionWait "record" recsource $ do + doc <- openDoc "A.hs" "haskell" + _ <- waitForDiagnostics + highlights <- getHighlights doc (Position 4 15) + liftIO $ highlights @?= + [ DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 14 4 20) (Just DocumentHighlightKind_Read) + ] + highlights <- getHighlights doc (Position 3 17) + liftIO $ highlights @?= + [ DocumentHighlight (R 3 17 3 23) (Just DocumentHighlightKind_Write) + , DocumentHighlight (R 4 8 4 10) (Just DocumentHighlightKind_Read) + ] + ] + where + source = T.unlines + ["{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"foo :: Int" + ,"foo = 3 :: Int" + ,"bar = foo" + ," where baz = let x = foo in x" + ,"baz arg = arg + x" + ," where x = arg" + ] + recsource = T.unlines + ["{-# LANGUAGE RecordWildCards #-}" + ,"{-# OPTIONS_GHC -Wunused-binds #-}" + ,"module Highlight () where" + ,"data Rec = Rec { field1 :: Int, field2 :: Char }" + ,"foo Rec{..} = field2 + field1" + ] + testSessionWait name ct = testSessionWithCorePluginSingleFile name "A.hs" ct diff --git a/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs new file mode 100644 index 0000000000..30fb1ba871 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/InitializeResponseTests.hs @@ -0,0 +1,119 @@ + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} + +module InitializeResponseTests (tests) where + +import Control.Monad +import Data.List.Extra +import Data.Row +import qualified Data.Text as T +import Development.IDE.Plugin.TypeLenses (typeLensCommandId) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Message +import Language.LSP.Test +import Util + +import Control.Lens ((^.)) +import Data.Default (def) +import qualified Data.Text as Text +import Development.IDE.Plugin.Test (blockCommandId) +import Language.LSP.Protocol.Types (CodeLensOptions (..), + CompletionOptions (..), + DefinitionOptions (DefinitionOptions), + DocumentHighlightOptions (..), + DocumentSymbolOptions (..), + ExecuteCommandOptions (..), + HoverOptions (..), + InitializeResult (..), + ReferenceOptions (..), + SaveOptions (..), + ServerCapabilities (..), + TextDocumentSyncKind (..), + TextDocumentSyncOptions (..), + TypeDefinitionOptions (..), + WorkspaceFoldersServerCapabilities (..), + WorkspaceSymbolOptions (..), + type (|?) (..)) +import Test.Hls (runSessionWithServerInTmpDir) +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource acquire release tests where + + -- these tests document and monitor the evolution of the + -- capabilities announced by the server in the initialize + -- response. Currently the server advertises almost no capabilities + -- at all, in some cases failing to announce capabilities that it + -- actually does provide! Hopefully this will change ... + tests :: IO (TResponseMessage Method_Initialize) -> TestTree + tests getInitializeResponse = + testGroup "initialize response capabilities" + [ + chk " text doc sync" _textDocumentSync tds + , chk " hover" _hoverProvider (Just $ InR (HoverOptions (Just False))) + , chk " completion" _completionProvider (Just $ CompletionOptions (Just False) (Just ["."]) Nothing (Just True) Nothing) + , chk "NO signature help" _signatureHelpProvider Nothing + , chk " goto definition" _definitionProvider (Just $ InR (DefinitionOptions (Just False))) + , chk " goto type definition" _typeDefinitionProvider (Just $ InR (InL (TypeDefinitionOptions (Just False)))) + -- BUG in lsp-test, this test fails, just change the accepted response + -- for now + , chk "NO goto implementation" _implementationProvider Nothing + , chk " find references" _referencesProvider (Just $ InR (ReferenceOptions (Just False))) + , chk " doc highlight" _documentHighlightProvider (Just $ InR (DocumentHighlightOptions (Just False))) + , chk " doc symbol" _documentSymbolProvider (Just $ InR (DocumentSymbolOptions (Just False) Nothing)) + , chk " workspace symbol" _workspaceSymbolProvider (Just $ InR (WorkspaceSymbolOptions (Just False) (Just False))) + , chk "NO code action" _codeActionProvider Nothing + , chk " code lens" _codeLensProvider (Just $ CodeLensOptions (Just False) (Just True)) + , chk "NO doc formatting" _documentFormattingProvider Nothing + , chk "NO doc range formatting" + _documentRangeFormattingProvider Nothing + , chk "NO doc formatting on typing" + _documentOnTypeFormattingProvider Nothing + , chk "NO renaming" _renameProvider Nothing + , chk "NO doc link" _documentLinkProvider Nothing + , chk "NO color" (^. L.colorProvider) Nothing + , chk "NO folding range" _foldingRangeProvider Nothing + , che " execute command" _executeCommandProvider [typeLensCommandId, blockCommandId] + , chk " workspace" (^. L.workspace) (Just $ #workspaceFolders .== Just WorkspaceFoldersServerCapabilities{_supported = Just True, _changeNotifications = Just ( InR True )} + .+ #fileOperations .== Nothing) + , chk "NO experimental" (^. L.experimental) Nothing + ] where + + tds = Just (InL (TextDocumentSyncOptions + { _openClose = Just True + , _change = Just TextDocumentSyncKind_Incremental + , _willSave = Nothing + , _willSaveWaitUntil = Nothing + , _save = Just (InR $ SaveOptions {_includeText = Nothing})})) + + chk :: (Eq a, Show a) => TestName -> (ServerCapabilities -> a) -> a -> TestTree + chk title getActual expected = + testCase title $ getInitializeResponse >>= \ir -> expected @=? (getActual . innerCaps) ir + + che :: TestName -> (ServerCapabilities -> Maybe ExecuteCommandOptions) -> [T.Text] -> TestTree + che title getActual expected = testCase title $ do + ir <- getInitializeResponse + ExecuteCommandOptions {_commands = commands} <- case getActual $ innerCaps ir of + Just eco -> pure eco + Nothing -> assertFailure "Was expecting Just ExecuteCommandOptions, got Nothing" + let commandNames = (!! 2) . T.splitOn ":" <$> commands + zipWithM_ (\e o -> T.isSuffixOf e o @? show (e,o)) (sort expected) (sort commandNames) + + innerCaps :: TResponseMessage Method_Initialize -> ServerCapabilities + innerCaps (TResponseMessage _ _ (Right (InitializeResult c _))) = c + innerCaps (TResponseMessage _ _ (Left _)) = error "Initialization error" + + acquire :: IO (TResponseMessage Method_Initialize) + acquire = do + let content = Text.unlines ["module Hello where", "go _ = 1"] + let fs = mkFs $ directFile "Hello.hs" content + runSessionWithServerInTmpDir def corePlugin fs initializeResponse + + + release :: TResponseMessage Method_Initialize -> IO () + release = mempty + + diff --git a/plugins/hls-core-plugin/test/exe/OutlineTests.hs b/plugins/hls-core-plugin/test/exe/OutlineTests.hs new file mode 100644 index 0000000000..6e06e6276b --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/OutlineTests.hs @@ -0,0 +1,123 @@ + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} + +module OutlineTests (tests) where + +import Control.Monad.IO.Class (liftIO) +import Data.Text (Text) +import qualified Data.Text as T +import Language.LSP.Protocol.Types hiding (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), mkRange) +import Language.LSP.Test +import Test.Tasty +import Test.Tasty.HUnit +import Util +-- import TestUtils + + +testSymbols :: (HasCallStack) => TestName -> FilePath -> [Text] -> [DocumentSymbol] -> TestTree +testSymbols testName path content expectedSymbols = + testSessionWithCorePluginSingleFile testName path (T.unlines content) $ do + docId <- openDoc path "haskell" + symbols <- getDocumentSymbols docId + liftIO $ symbols @?= Right expectedSymbols + +testSymbolsA :: (HasCallStack) => TestName -> [Text] -> [DocumentSymbol] -> TestTree +testSymbolsA testName content expectedSymbols = + testSymbols testName "A.hs" content expectedSymbols + +tests :: TestTree +tests = testGroup + "outline" + [ + testSymbolsA "module" ["module A where", "class A a where a :: a -> Bool"] + [ moduleSymbol + "A" + (R 0 7 0 8) + [ classSymbol "A a" + (R 1 0 1 30) + [docSymbol' "a" SymbolKind_Method (R 1 16 1 30) (R 1 16 1 17)] + ] ] + , testSymbolsA "type class instance " ["class A a where", "instance A () where"] + [ classSymbol "A a" (R 0 0 0 15) [] + , docSymbol "A ()" SymbolKind_Interface (R 1 0 1 19) + ] + , testSymbolsA "type family" ["{-# language TypeFamilies #-}", "type family A"] [docSymbolD "A" "type family" SymbolKind_Function (R 1 0 1 13)] + , testSymbolsA "type family instance " [ "{-# language TypeFamilies #-}" , "type family A a" , "type instance A () = ()"] + [ docSymbolD "A a" "type family" SymbolKind_Function (R 1 0 1 15) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 23) + ] + , testSymbolsA "data family" ["{-# language TypeFamilies #-}", "data family A"] [docSymbolD "A" "data family" SymbolKind_Function (R 1 0 1 11)] + , testSymbolsA "data family instance " [ "{-# language TypeFamilies #-}" , "data family A a" , "data instance A () = A ()" ] + [ docSymbolD "A a" "data family" SymbolKind_Function (R 1 0 1 11) + , docSymbol "A ()" SymbolKind_Interface (R 2 0 2 25) + ] + , testSymbolsA "constant" ["a = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 6)] + , testSymbolsA "pattern" ["Just foo = Just 21"] [docSymbol "Just foo" SymbolKind_Function (R 0 0 0 18)] + , testSymbolsA "pattern with type signature" ["{-# language ScopedTypeVariables #-}", "a :: () = ()"] [docSymbol "a :: ()" SymbolKind_Function (R 1 0 1 12)] + , testSymbolsA "function" ["a _x = ()"] [docSymbol "a" SymbolKind_Function (R 0 0 0 9)] + , testSymbolsA "type synonym" ["type A = Bool"] [docSymbol' "A" SymbolKind_TypeParameter (R 0 0 0 13) (R 0 5 0 6)] + , testSymbolsA "datatype" ["data A = C"] [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 0 10) [docSymbol "C" SymbolKind_Constructor (R 0 9 0 10)] ] + , testSymbolsA "record fields" ["data A = B {", " x :: Int", " , y :: Int}"] + [ docSymbolWithChildren "A" SymbolKind_Struct (R 0 0 2 13) + [ docSymbolWithChildren' "B" SymbolKind_Constructor (R 0 9 2 13) (R 0 9 0 10) + [ docSymbol "x" SymbolKind_Field (R 1 2 1 3) + , docSymbol "y" SymbolKind_Field (R 2 4 2 5) + ] + ] + ] + , testSymbolsA "import" ["import Data.Maybe ()"] + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 0 0 0 20) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 0 0 0 20) + ] + ] + , testSymbolsA "multiple import" ["", "import Data.Maybe ()", "", "import Control.Exception ()", ""] + [docSymbolWithChildren "imports" + SymbolKind_Module + (R 1 0 3 27) + [ docSymbol "import Data.Maybe" SymbolKind_Module (R 1 0 1 20) + , docSymbol "import Control.Exception" SymbolKind_Module (R 3 0 3 27) + ] + ] + , testSymbolsA "foreign import" + [ "{-# language ForeignFunctionInterface #-}" + , "foreign import ccall \"a\" a :: Int" + ] [docSymbolD "a" "import" SymbolKind_Object (R 1 0 1 33)] + , testSymbolsA "foreign export" + [ "{-# language ForeignFunctionInterface #-}" + , "foreign export ccall odd :: Int -> Bool" + ] + [docSymbolD "odd" "export" SymbolKind_Object (R 1 0 1 39)] + ] + where + docSymbol name kind loc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc Nothing + docSymbol' name kind loc selectionLoc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc Nothing + docSymbolD name detail kind loc = + DocumentSymbol name (Just detail) kind Nothing Nothing loc loc Nothing + docSymbolWithChildren name kind loc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc loc (Just cc) + docSymbolWithChildren' name kind loc selectionLoc cc = + DocumentSymbol name Nothing kind Nothing Nothing loc selectionLoc (Just cc) + moduleSymbol name loc cc = DocumentSymbol name + Nothing + SymbolKind_File + Nothing + Nothing + (R 0 0 maxBound 0) + loc + (Just cc) + classSymbol name loc cc = DocumentSymbol name + (Just "class") + SymbolKind_Interface + Nothing + Nothing + loc + loc + (Just cc) diff --git a/plugins/hls-core-plugin/test/exe/ReferenceTests.hs b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs new file mode 100644 index 0000000000..36379006f6 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/ReferenceTests.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ReferenceTests (tests) where + +import Control.Applicative.Combinators +import qualified Control.Lens as Lens +import Control.Monad +import Control.Monad.IO.Class (liftIO) +import Data.List.Extra +import qualified Data.Set as Set +import Development.IDE.Types.Location +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types hiding + (SemanticTokenAbsolute (..), + SemanticTokenRelative (..), + SemanticTokensEdit (..), + mkRange) +import Language.LSP.Test +import System.Directory +-- import Test.QuickCheck.Instances () +import Control.Lens ((^.)) +import Data.Tuple.Extra +import Test.Hls.FileSystem (copyDir, toAbsFp) +import Test.Tasty +import Test.Tasty.ExpectedFailure +import Test.Tasty.HUnit +import Util + + +tests :: TestTree +tests = testGroup "references" + [ testGroup "can get references to FOIs" + [ referenceTest "can get references to symbols" + ("References.hs", 4, 7) + YesIncludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "can get references to data constructor" + ("References.hs", 13, 2) + YesIncludeDeclaration + [ ("References.hs", 13, 2) + , ("References.hs", 16, 14) + , ("References.hs", 19, 21) + ] + + , referenceTest "getting references works in the other module" + ("OtherModule.hs", 6, 0) + YesIncludeDeclaration + [ ("OtherModule.hs", 6, 0) + , ("OtherModule.hs", 8, 16) + ] + + , referenceTest "getting references works in the Main module" + ("Main.hs", 9, 0) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 10, 4) + ] + + , referenceTest "getting references to main works" + ("Main.hs", 5, 0) + YesIncludeDeclaration + [ ("Main.hs", 4, 0) + , ("Main.hs", 5, 0) + ] + + , referenceTest "can get type references" + ("Main.hs", 9, 9) + YesIncludeDeclaration + [ ("Main.hs", 9, 0) + , ("Main.hs", 9, 9) + , ("Main.hs", 10, 0) + ] + + , expectFailBecause "references provider does not respect includeDeclaration parameter" $ + referenceTest "works when we ask to exclude declarations" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + + , referenceTest "INCORRECTLY returns declarations when we ask to exclude them" + ("References.hs", 4, 7) + NoExcludeDeclaration + [ ("References.hs", 4, 6) + , ("References.hs", 6, 0) + , ("References.hs", 6, 14) + , ("References.hs", 9, 7) + , ("References.hs", 10, 11) + ] + ] + + , testGroup "can get references to non FOIs" + [ referenceTest "can get references to symbol defined in a module we import" + ("References.hs", 22, 4) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references in modules that import us to symbols we define" + ("OtherModule.hs", 4, 0) + YesIncludeDeclaration + [ ("References.hs", 22, 4) + , ("OtherModule.hs", 0, 20) + , ("OtherModule.hs", 4, 0) + ] + + , referenceTest "can get references to symbol defined in a module we import transitively" + ("References.hs", 24, 4) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get references in modules that import us transitively to symbols we define" + ("OtherOtherModule.hs", 2, 0) + YesIncludeDeclaration + [ ("References.hs", 24, 4) + , ("OtherModule.hs", 0, 48) + , ("OtherOtherModule.hs", 2, 0) + ] + + , referenceTest "can get type references to other modules" + ("Main.hs", 12, 10) + YesIncludeDeclaration + [ ("Main.hs", 12, 7) + , ("Main.hs", 13, 0) + , ("References.hs", 12, 5) + , ("References.hs", 16, 0) + ] + ] + ] + +-- | When we ask for all references to symbol "foo", should the declaration "foo +-- = 2" be among the references returned? +data IncludeDeclaration = + YesIncludeDeclaration + | NoExcludeDeclaration + +getReferences' :: SymbolLocation -> IncludeDeclaration -> Session ([Location]) +getReferences' (file, l, c) includeDeclaration = do + doc <- openDoc file "haskell" + getReferences doc (Position l c) $ toBool includeDeclaration + where toBool YesIncludeDeclaration = True + toBool NoExcludeDeclaration = False + +referenceTestSession :: String -> FilePath -> [FilePath] -> Session () -> TestTree +referenceTestSession name thisDoc docs' f = do + testSessionWithCorePlugin name (mkFs [copyDir "references"]) $ \fs -> do + -- needed to build whole project indexing + configureCheckProject True + + -- Initial Index + docid <- openDoc thisDoc "haskell" + + -- need to get the real paths through links + docs <- mapM (liftIO . canonicalizePath . toAbsFp fs) $ delete thisDoc $ nubOrd docs' + liftIO $ putStrLn $ "docs:" <> show docs + let + -- todo wait for docs + loop :: [FilePath] -> Session () + loop [] = pure () + loop docs = do + + doc <- skipManyTill anyMessage $ referenceReady (`elem` docs) + loop (delete doc docs) + loop docs + f + closeDoc docid + +-- | Given a location, lookup the symbol and all references to it. Make sure +-- they are the ones we expect. +referenceTest :: (HasCallStack) => String -> SymbolLocation -> IncludeDeclaration -> [SymbolLocation] -> TestTree +referenceTest name loc includeDeclaration expected = + referenceTestSession name (fst3 loc) docs $ do + actual <- getReferences' loc includeDeclaration + liftIO $ actual `expectSameLocations` expected + where + docs = map fst3 expected + +type SymbolLocation = (FilePath, UInt, UInt) + +expectSameLocations :: (HasCallStack) => [Location] -> [SymbolLocation] -> Assertion +expectSameLocations actual expected = do + let actual' = + Set.map (\location -> (location ^. L.uri + , location ^. L.range . L.start . L.line . Lens.to fromIntegral + , location ^. L.range . L.start . L.character . Lens.to fromIntegral)) + $ Set.fromList actual + expected' <- Set.fromList <$> + (forM expected $ \(file, l, c) -> do + fp <- canonicalizePath file + return (filePathToUri fp, l, c)) + actual' @?= expected' diff --git a/plugins/hls-core-plugin/test/exe/Util.hs b/plugins/hls-core-plugin/test/exe/Util.hs new file mode 100644 index 0000000000..55b2c3be14 --- /dev/null +++ b/plugins/hls-core-plugin/test/exe/Util.hs @@ -0,0 +1,373 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} +{-# HLINT ignore "Avoid restricted function" #-} +{-# LANGUAGE DataKinds #-} + +module Util where + +import Control.Applicative ((<|>)) +import Control.Arrow (Arrow (..)) +import Control.Lens (_1, traverseOf, (^.)) +import Control.Monad (unless, void, (>=>)) +import Control.Monad.IO.Class (MonadIO (..)) +import qualified Data.Aeson as A +import Data.Data (Proxy (..)) +import Data.Default (Default (..)) +import Data.Foldable (traverse_) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text as Text +import Debug.Trace (traceShow) +import Development.IDE (GhcVersion, ghcVersion) +import Development.IDE.Plugin.Test (TestRequest (..)) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (symbolVal) +import qualified Ide.Plugin.Core as Core +import Ide.Types (Config (..)) +import Language.LSP.Protocol.Lens (HasRange (..), HasStart (..), + HasTags (..)) +import qualified Language.LSP.Protocol.Lens as L +import Language.LSP.Protocol.Types (Definition (..), + DefinitionLink (..), Diagnostic, + DiagnosticSeverity, DiagnosticTag, + Location (..), LocationLink (..), + Null (..), Position (..), + Range (..), UInt, Uri (..), + filePathToUri, mkRange, + toNormalizedUri, + type (|?) (InL, InR), + uriToFilePath) +import qualified Language.LSP.Protocol.Types as L +import Language.LSP.Test (Session, getCurrentDiagnostics, + sendRequest) +import qualified Language.LSP.Test as LspTest +import System.Directory.Extra (canonicalizePath) +import System.FilePath (equalFilePath, ()) +import System.Time.Extra (Seconds, sleep) +import Test.Hls (FromServerMessage' (..), + Method (Method_TextDocumentPublishDiagnostics), + NormalizedUri, + PluginTestDescriptor, + SMethod (..), TCustomMessage (..), + TNotificationMessage (..), + TServerMessage, TestName, + TestRunner, TestTree, assertBool, + expectFailBecause, getDocUri, + mkPluginTestDescriptor, + runSessionWithServer, + runSessionWithServerInTmpDir, + satisfyMaybe, setConfigSection, + skipManyTill, testCase) +import qualified Test.Hls.FileSystem as FS +import Test.Hls.FileSystem (copy, file, text) +import Test.Tasty.HUnit (Assertion, assertFailure, (@=?), + (@?=)) + + +pattern R :: UInt -> UInt -> UInt -> UInt -> Range +pattern R x y x' y' = Range (Position x y) (Position x' y') + +testSessionWithCorePlugin ::(TestRunner cont ()) => TestName -> FS.VirtualFileTree -> cont -> TestTree +testSessionWithCorePlugin caseName vfs = testCase caseName . runSessionWithCorePlugin vfs + +testSessionWithCorePluginEmptyVsf ::(TestRunner cont ()) => TestName -> cont -> TestTree +testSessionWithCorePluginEmptyVsf caseName = testSessionWithCorePlugin caseName (mkFs []) + +runSessionWithCorePluginNoVsf :: Session a -> IO a +runSessionWithCorePluginNoVsf = runSessionWithCorePlugin (mkFs []) + +testSessionWithCorePluginSubDir ::(TestRunner cont ()) => TestName -> FilePath -> cont -> TestTree +testSessionWithCorePluginSubDir caseName dir = testSessionWithCorePlugin caseName (mkFs [FS.copyDir dir]) + +runSessionWithCorePlugin :: (TestRunner cont res) => FS.VirtualFileTree -> cont -> IO res +runSessionWithCorePlugin = runSessionWithServerInTmpDir def corePlugin + +runSessionWithServerCorePlugin :: FilePath -> Session a -> IO a +runSessionWithServerCorePlugin = runSessionWithServer def corePlugin + +runSessionWithCorePluginEmpty :: [Text] -> Session a -> IO a +runSessionWithCorePluginEmpty fps = runSessionWithCorePlugin (mkFs [FS.directCradle fps]) + +runSessionWithCorePluginSingleFile :: FilePath -> Text -> Session a -> IO a +runSessionWithCorePluginSingleFile fp content = runSessionWithCorePlugin (mkSingleFileFs fp content) + +runSessionWithCorePluginSingleDirFile :: FilePath -> FilePath -> Session a -> IO a +runSessionWithCorePluginSingleDirFile dir fp = runSessionWithCorePlugin (mkSingleDirFileFs dir fp) + +testSessionWithCorePluginSingleFile :: TestName -> FilePath -> Text -> Session () -> TestTree +testSessionWithCorePluginSingleFile caseName fp content = testCase caseName . runSessionWithCorePluginSingleFile fp content + +testSessionWithCorePluginSingleDirFile :: TestName + -> FilePath -- ^ subDir under testDataDir + -> FilePath -- ^ fileName + -> Session () -> TestTree +testSessionWithCorePluginSingleDirFile caseName subDir fp = testCase caseName . runSessionWithCorePluginSingleDirFile subDir fp + +corePlugin :: PluginTestDescriptor Core.CoreLog +corePlugin = mkPluginTestDescriptor Core.descriptor "core" + +mkSingleFileFs :: FilePath -> Text -> FS.VirtualFileTree +mkSingleFileFs fp = mkFs . directFile fp + +mkSingleDirFileFs :: FilePath -> FilePath -> FS.VirtualFileTree +mkSingleDirFileFs dir fp = FS.mkVirtualFileTree (testDataDir dir) [FS.directCradle [Text.pack fp], copy fp] + +directFile :: FilePath -> Text -> [FS.FileTree] +directFile fp content = + [ FS.directCradle [Text.pack fp] + , file fp (text content) + ] + +mkFs :: [FS.FileTree] -> FS.VirtualFileTree +mkFs = FS.mkVirtualFileTree testDataDir + +testDataDir :: FilePath +testDataDir = "plugins" "hls-core-plugin" "test" "testdata" + + +data Expect + = ExpectRange Range -- Both gotoDef and hover should report this range + | ExpectLocation Location +-- | ExpectDefRange Range -- Only gotoDef should report this range + | ExpectHoverRange Range -- Only hover should report this range + | ExpectHoverText [T.Text] -- the hover message must contain these snippets + | ExpectHoverExcludeText [T.Text] -- the hover message must _not_ contain these snippets + | ExpectHoverTextRegex T.Text -- the hover message must match this pattern + | ExpectExternFail -- definition lookup in other file expected to fail + | ExpectNoDefinitions + | ExpectNoHover +-- | ExpectExtern -- TODO: as above, but expected to succeed: need some more info in here, once we have some working examples + deriving Eq + +defToLocation :: Definition |? ([DefinitionLink] |? Null) -> [Location] +defToLocation (InL (Definition (InL l))) = [l] +defToLocation (InL (Definition (InR ls))) = ls +defToLocation (InR (InL defLink)) = (\(DefinitionLink LocationLink{_targetUri,_targetRange}) -> Location _targetUri _targetRange) <$> defLink +defToLocation (InR (InR Null)) = [] + +checkDefs :: Definition |? ([DefinitionLink] |? Null) -> Session [Expect] -> Session () +checkDefs (defToLocation -> defs) mkExpectations = traverse_ check =<< mkExpectations where + check (ExpectRange expectedRange) = do + def <- assertOneDefinitionFound defs + assertRangeCorrect def expectedRange + check (ExpectLocation expectedLocation) = do + def <- assertOneDefinitionFound defs + liftIO $ do + canonActualLoc <- canonicalizeLocation def + canonExpectedLoc <- canonicalizeLocation expectedLocation + canonActualLoc @?= canonExpectedLoc + check ExpectNoDefinitions = do + liftIO $ assertBool "Expecting no definitions" $ null defs + check ExpectExternFail = liftIO $ assertFailure "Expecting to fail to find in external file" + check _ = pure () -- all other expectations not relevant to getDefinition + + assertOneDefinitionFound :: [Location] -> Session Location + assertOneDefinitionFound [def] = pure def + assertOneDefinitionFound xs = liftIO . assertFailure $ "Expecting exactly one definition, got " <> show (length xs) + + assertRangeCorrect Location{_range = foundRange} expectedRange = + liftIO $ expectedRange @=? foundRange + + + +canonicalizeLocation :: Location -> IO Location +canonicalizeLocation (Location uri range) = Location <$> canonicalizeUri uri <*> pure range + +canonicalizeUri :: Uri -> IO Uri +canonicalizeUri uri = filePathToUri <$> canonicalizePath (fromJust (uriToFilePath uri)) + + +mkR :: UInt -> UInt -> UInt -> UInt -> Expect +mkR startLine startColumn endLine endColumn = ExpectRange $ mkRange startLine startColumn endLine endColumn + +mkL :: Uri -> UInt -> UInt -> UInt -> UInt -> Expect +mkL uri startLine startColumn endLine endColumn = ExpectLocation $ Location uri $ mkRange startLine startColumn endLine endColumn + +-- mkRange :: UInt -> UInt -> UInt -> UInt -> Range +-- mkRange a b c d = Range (Position a b) (Position c d) + +xfail :: TestTree -> String -> TestTree +xfail = flip expectFailBecause + +standardizeQuotes :: T.Text -> T.Text +standardizeQuotes msg = let + repl '‘' = '\'' + repl '’' = '\'' + repl '`' = '\'' + repl c = c + in T.map repl msg + + +configureCheckProject :: Bool -> Session () +configureCheckProject overrideCheckProject = setConfigSection "haskell" (A.toJSON $ def{checkProject = overrideCheckProject}) + + +referenceReady :: (FilePath -> Bool) -> Session FilePath +referenceReady pred = satisfyMaybe $ \case + FromServerMess (SMethod_CustomMethod p) (NotMess TNotificationMessage{_params}) + | A.Success fp <- A.fromJSON _params + , pred fp + , symbolVal p == "ghcide/reference/ready" + -> traceShow ("referenceReady", fp) $ Just fp + _ -> Nothing + +-- | Pattern match a message from ghcide indicating that a file has been indexed +isReferenceReady :: FilePath -> Session () +isReferenceReady p = void $ referenceReady (equalFilePath p) + +-- |wait for @timeout@ seconds and report an assertion failure +-- if any diagnostic messages arrive in that period +-- expectNoMoreDiagnostics :: (HasCallStack) => Seconds -> Session () +-- expectNoMoreDiagnostics timeout = +-- expectMessages SMethod_TextDocumentPublishDiagnostics timeout $ \diagsNot -> do +-- let fileUri = diagsNot ^. L.params . L.uri +-- actual = diagsNot ^. L.params . L.diagnostics +-- unless (actual == []) $ liftIO $ +-- assertFailure $ +-- "Got unexpected diagnostics for " <> show fileUri +-- <> " got " +-- <> show actual + +expectMessages :: SMethod m -> Seconds -> (TServerMessage m -> Session ()) -> Session () +expectMessages m timeout handle = do + -- Give any further diagnostic messages time to arrive. + liftIO $ sleep 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 (Proxy @"test") + i <- sendRequest cm $ A.toJSON GetShakeSessionQueueCount + go cm i + where + go cm i = handleMessages + where + handleMessages = (LspTest.message m >>= handle) <|> (void $ LspTest.responseForId cm i) <|> ignoreOthers + ignoreOthers = void LspTest.anyMessage >> handleMessages + +type Cursor = (UInt, UInt) +-- | 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 = expectDiagnosticsWithTags . map (second (map (\(ds, c, t) -> (ds, c, t, Nothing)))) + +unwrapDiagnostic :: TServerMessage Method_TextDocumentPublishDiagnostics -> (Uri, [Diagnostic]) +unwrapDiagnostic diagsNot = (diagsNot^. L.params . L.uri, diagsNot^. L.params . L.diagnostics) +expectDiagnosticsWithTags :: HasCallStack => [(String, [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)])] -> Session () +expectDiagnosticsWithTags expected = do + let f = getDocUri >=> liftIO . canonicalizeUri >=> pure . toNormalizedUri + next = unwrapDiagnostic <$> skipManyTill LspTest.anyMessage diagnostic + expected' <- Map.fromListWith (<>) <$> traverseOf (traverse . _1) f expected + expectDiagnosticsWithTags' next expected' + +diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) +diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics + +expectDiagnosticsWithTags' :: + (HasCallStack, MonadIO m) => + m (Uri, [Diagnostic]) -> + Map.Map NormalizedUri [(DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag)] -> + m () +expectDiagnosticsWithTags' next m | null m = do + (_,actual) <- next + case actual of + [] -> + return () + _ -> + liftIO $ assertFailure $ "Got unexpected diagnostics:" <> show actual + +expectDiagnosticsWithTags' next expected = go expected + where + go m + | Map.null m = pure () + | otherwise = do + (fileUri, actual) <- next + canonUri <- liftIO $ toNormalizedUri <$> canonicalizeUri fileUri + case Map.lookup canonUri m of + Nothing -> do + liftIO $ + assertFailure $ + "Got diagnostics for " <> show fileUri + <> " but only expected diagnostics for " + <> show (Map.keys m) + <> " got " + <> show actual + Just expected -> do + liftIO $ mapM_ (requireDiagnosticM actual) expected + liftIO $ + unless (length expected == length actual) $ + assertFailure $ + "Incorrect number of diagnostics for " <> show fileUri + <> ", expected " + <> show expected + <> " but got " + <> show actual + go $ Map.delete canonUri m + +-- expectCurrentDiagnostics :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> Session () +-- expectCurrentDiagnostics doc expected = do +-- diags <- getCurrentDiagnostics doc +-- checkDiagnosticsForDoc doc expected diags + +-- checkDiagnosticsForDoc :: HasCallStack => TextDocumentIdentifier -> [(DiagnosticSeverity, Cursor, T.Text)] -> [Diagnostic] -> Session () +-- checkDiagnosticsForDoc TextDocumentIdentifier {_uri} expected obtained = do +-- let expected' = Map.singleton nuri (map (\(ds, c, t) -> (ds, c, t, Nothing)) expected) +-- nuri = toNormalizedUri _uri +-- expectDiagnosticsWithTags' (return (_uri, obtained)) expected' + + +-- diagnostic :: Session (TNotificationMessage Method_TextDocumentPublishDiagnostics) +-- diagnostic = LspTest.message SMethod_TextDocumentPublishDiagnostics + + +requireDiagnosticM + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Assertion +requireDiagnosticM actuals expected = case requireDiagnostic actuals expected of + Nothing -> pure () + Just err -> assertFailure err + +type ErrorMsg = String + +cursorPosition :: Cursor -> Position +cursorPosition (line, col) = Position line col + +requireDiagnostic + :: (Foldable f, Show (f Diagnostic), HasCallStack) + => f Diagnostic + -> (DiagnosticSeverity, Cursor, T.Text, Maybe DiagnosticTag) + -> Maybe ErrorMsg +requireDiagnostic actuals expected@(severity, cursor, expectedMsg, expectedTag) + | any match actuals = Nothing + | otherwise = Just $ + "Could not find " <> show expected <> + " in " <> show actuals + where + match :: Diagnostic -> Bool + match d = + Just severity == d ^. L.severity + && cursorPosition cursor == d ^. range . start + && standardizeQuotes (T.toLower expectedMsg) `T.isInfixOf` + standardizeQuotes (T.toLower $ d ^. L.message) + && hasTag expectedTag (d ^. tags) + + hasTag :: Maybe DiagnosticTag -> Maybe [DiagnosticTag] -> Bool + hasTag Nothing _ = True + hasTag (Just _) Nothing = False + hasTag (Just actualTag) (Just tags) = actualTag `elem` tags + + + +expectNoDiagnostic :: HasCallStack => [L.TextDocumentIdentifier] -> Session () +expectNoDiagnostic xs = do + diags <- fmap concat $ traverse getCurrentDiagnostics xs + liftIO $ assertBool "Expecting no diags" $ null diags diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/a/a.cabal b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/a.cabal new file mode 100644 index 0000000000..093890733b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/a.cabal @@ -0,0 +1,14 @@ +cabal-version: 2.2 + +name: a +version: 0.1.0.0 +author: Fendor +maintainer: power.walross@gmail.com +build-type: Simple + +executable a + main-is: Main.hs + hs-source-dirs: src + ghc-options: -Wall + build-depends: base + default-language: Haskell2010 diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/a/src/Main.hs b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/src/Main.hs new file mode 100644 index 0000000000..81d0cfb17a --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/a/src/Main.hs @@ -0,0 +1,3 @@ +module Main where + +main = putStrLn "Hello, Haskell!" diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/cabal.project b/plugins/hls-core-plugin/test/testdata/cabal-exe/cabal.project new file mode 100644 index 0000000000..edcac420d9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/cabal.project @@ -0,0 +1 @@ +packages: ./a \ No newline at end of file diff --git a/plugins/hls-core-plugin/test/testdata/cabal-exe/hie.yaml b/plugins/hls-core-plugin/test/testdata/cabal-exe/hie.yaml new file mode 100644 index 0000000000..5c7ab11641 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/cabal-exe/hie.yaml @@ -0,0 +1,3 @@ +cradle: + cabal: + component: "exe:a" \ No newline at end of file diff --git a/plugins/hls-core-plugin/test/testdata/hover/Bar.hs b/plugins/hls-core-plugin/test/testdata/hover/Bar.hs new file mode 100644 index 0000000000..f9fde2a7cc --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/Bar.hs @@ -0,0 +1,4 @@ +module Bar (Bar(..)) where + +-- | Bar Haddock +data Bar = Bar diff --git a/plugins/hls-core-plugin/test/testdata/hover/Foo.hs b/plugins/hls-core-plugin/test/testdata/hover/Foo.hs new file mode 100644 index 0000000000..489a6ccd6b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/Foo.hs @@ -0,0 +1,6 @@ +module Foo (Bar, foo) where + +import Bar + +-- | foo Haddock +foo = Bar diff --git a/plugins/hls-core-plugin/test/testdata/hover/GotoHover.hs b/plugins/hls-core-plugin/test/testdata/hover/GotoHover.hs new file mode 100644 index 0000000000..6ff3eeffed --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/GotoHover.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} +{- HLINT ignore -} +module GotoHover ( module GotoHover) where +import Data.Text (Text, pack) +import Foo (Bar, foo) + + +data TypeConstructor = DataConstructor + { fff :: Text + , ggg :: Int } +aaa :: TypeConstructor +aaa = DataConstructor + { fff = "dfgy" + , ggg = 832 + } +bbb :: TypeConstructor +bbb = DataConstructor "mjgp" 2994 +ccc :: (Text, Int) +ccc = (fff bbb, ggg aaa) +ddd :: Num a => a -> a -> a +ddd vv ww = vv +! ww +a +! b = a - b +hhh (Just a) (><) = a >< a +iii a b = a `b` a +jjj s = pack $ s <> s +class MyClass a where + method :: a -> Int +instance MyClass Int where + method = succ +kkk :: MyClass a => Int -> a -> Int +kkk n c = n + method c + +doBind :: Maybe () +doBind = do unwrapped <- Just () + return unwrapped + +listCompBind :: [Char] +listCompBind = [ succ c | c <- "ptfx" ] + +multipleClause :: Bool -> Char +multipleClause True = 't' +multipleClause False = 'f' + +-- | Recognizable docs: kpqz +documented :: Monad m => Either Int (m a) +documented = Left 7518 + +listOfInt = [ 8391 :: Int, 6268 ] + +outer :: Bool +outer = undefined inner where + + inner :: Char + inner = undefined + +imported :: Bar +imported = foo + +aa2 :: Bool +aa2 = $(id [| True |]) + +hole :: Int +hole = _ + +hole2 :: a -> Maybe a +hole2 = _ + +-- A comment above a type defnition with a deriving clause +data Example = Example + deriving (Eq) diff --git a/plugins/hls-core-plugin/test/testdata/hover/RecordDotSyntax.hs b/plugins/hls-core-plugin/test/testdata/hover/RecordDotSyntax.hs new file mode 100644 index 0000000000..3680d08a3c --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/RecordDotSyntax.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedRecordDot, DuplicateRecordFields, NoFieldSelectors #-} + +module RecordDotSyntax ( module RecordDotSyntax) where + +import qualified Data.Maybe as M + +data MyRecord = MyRecord + { a :: String + , b :: Integer + , c :: MyChild + } deriving (Eq, Show) + +newtype MyChild = MyChild + { z :: String + } deriving (Eq, Show) + +x = MyRecord { a = "Hello", b = 12, c = MyChild { z = "there" } } +y = x.a ++ show x.b ++ x.c.z diff --git a/plugins/hls-core-plugin/test/testdata/hover/hie.yaml b/plugins/hls-core-plugin/test/testdata/hover/hie.yaml new file mode 100644 index 0000000000..e2b3e97c5d --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/hover/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Foo", "Bar", "GotoHover", "RecordDotSyntax"]}} diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/IgnoreFatal.hs b/plugins/hls-core-plugin/test/testdata/ignore-change/IgnoreFatal.hs new file mode 100644 index 0000000000..bf468edcb1 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/IgnoreFatal.hs @@ -0,0 +1,5 @@ +module IgnoreFatal where +import Data.Text + +x :: Text +x = "123" diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/cabal.project b/plugins/hls-core-plugin/test/testdata/ignore-change/cabal.project new file mode 100644 index 0000000000..c6bb6fb152 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/cabal.project @@ -0,0 +1 @@ +packages: ignore-fatal.cabal diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/hie.yaml b/plugins/hls-core-plugin/test/testdata/ignore-change/hie.yaml new file mode 100644 index 0000000000..4dc1a80b72 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/hie.yaml @@ -0,0 +1,3 @@ +cradle: + direct: {arguments: [-XOverloadedStrings]} + diff --git a/plugins/hls-core-plugin/test/testdata/ignore-change/ignore-fatal.cabal b/plugins/hls-core-plugin/test/testdata/ignore-change/ignore-fatal.cabal new file mode 100644 index 0000000000..6e831e0395 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-change/ignore-fatal.cabal @@ -0,0 +1,10 @@ +name: ignore-fatal +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: IgnoreFatal + hs-source-dirs: . + ghc-options: -Werror=missing-signatures diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/IgnoreFatal.hs b/plugins/hls-core-plugin/test/testdata/ignore-fatal/IgnoreFatal.hs new file mode 100644 index 0000000000..77b11c5bb3 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/IgnoreFatal.hs @@ -0,0 +1,8 @@ +-- "missing signature" is declared a fatal warning in the cabal file, +-- but is ignored in this module. + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module IgnoreFatal where + +a = 'a' diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/cabal.project b/plugins/hls-core-plugin/test/testdata/ignore-fatal/cabal.project new file mode 100644 index 0000000000..c6bb6fb152 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/cabal.project @@ -0,0 +1 @@ +packages: ignore-fatal.cabal diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/hie.yaml b/plugins/hls-core-plugin/test/testdata/ignore-fatal/hie.yaml new file mode 100644 index 0000000000..6ea3cebd0d --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/hie.yaml @@ -0,0 +1,4 @@ +cradle: + cabal: + - path: "." + component: "lib:ignore-fatal" diff --git a/plugins/hls-core-plugin/test/testdata/ignore-fatal/ignore-fatal.cabal b/plugins/hls-core-plugin/test/testdata/ignore-fatal/ignore-fatal.cabal new file mode 100644 index 0000000000..6e831e0395 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/ignore-fatal/ignore-fatal.cabal @@ -0,0 +1,10 @@ +name: ignore-fatal +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base + exposed-modules: IgnoreFatal + hs-source-dirs: . + ghc-options: -Werror=missing-signatures diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a-1.0.0-inplace new file mode 100644 index 0000000000..a54ea9bc4b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a-1.0.0-inplace @@ -0,0 +1,18 @@ +-this-package-name +a +-working-dir +a +-fbuilding-cabal-package +-O0 +-i. +-this-unit-id +a-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package +base +-package +text +-XHaskell98 +A diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a/A.hs b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a/A.hs new file mode 100644 index 0000000000..9a7d7e33c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b-1.0.0-inplace new file mode 100644 index 0000000000..d656a2539b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b-1.0.0-inplace @@ -0,0 +1,21 @@ +-this-package-name +b +-working-dir +b +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +b-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-reexported-module +A +-package +base +-XHaskell98 +B diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b/B.hs b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b/B.hs new file mode 100644 index 0000000000..2c6d4b28a2 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c-1.0.0-inplace new file mode 100644 index 0000000000..e60a95eda0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +c +-working-dir +c +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +c-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +b-1.0.0-inplace +-package +base +-XHaskell98 +C diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c/C.hs b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c/C.hs new file mode 100644 index 0000000000..1b2d305296 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/c/C.hs @@ -0,0 +1,4 @@ +module C(module C) where +import A +import B +cux = foo `seq` qux diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/cabal.project b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/cabal.project new file mode 100644 index 0000000000..96f52330c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/cabal.project @@ -0,0 +1,2 @@ +packages: a b c +multi-repl: True diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/hie.yaml b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/hie.yaml new file mode 100644 index 0000000000..34858b5f64 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit-reexport/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@b-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ] diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/a-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit/a-1.0.0-inplace new file mode 100644 index 0000000000..a54ea9bc4b --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/a-1.0.0-inplace @@ -0,0 +1,18 @@ +-this-package-name +a +-working-dir +a +-fbuilding-cabal-package +-O0 +-i. +-this-unit-id +a-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package +base +-package +text +-XHaskell98 +A diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/a/A.hs b/plugins/hls-core-plugin/test/testdata/multi-unit/a/A.hs new file mode 100644 index 0000000000..9a7d7e33c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Data.Text +foo = () diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/b-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit/b-1.0.0-inplace new file mode 100644 index 0000000000..b08c50c1ce --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/b-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +b +-working-dir +b +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +b-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-package +base +-XHaskell98 +B diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/b/B.hs b/plugins/hls-core-plugin/test/testdata/multi-unit/b/B.hs new file mode 100644 index 0000000000..2c6d4b28a2 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/c-1.0.0-inplace b/plugins/hls-core-plugin/test/testdata/multi-unit/c-1.0.0-inplace new file mode 100644 index 0000000000..7201a40de4 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/c-1.0.0-inplace @@ -0,0 +1,19 @@ +-this-package-name +c +-working-dir +c +-fbuilding-cabal-package +-O0 +-i +-i. +-this-unit-id +c-1.0.0-inplace +-hide-all-packages +-Wmissing-home-modules +-no-user-package-db +-package-id +a-1.0.0-inplace +-package +base +-XHaskell98 +C diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/c/C.hs b/plugins/hls-core-plugin/test/testdata/multi-unit/c/C.hs new file mode 100644 index 0000000000..b75a7fc3c7 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/cabal.project b/plugins/hls-core-plugin/test/testdata/multi-unit/cabal.project new file mode 100644 index 0000000000..96f52330c9 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/cabal.project @@ -0,0 +1,2 @@ +packages: a b c +multi-repl: True diff --git a/plugins/hls-core-plugin/test/testdata/multi-unit/hie.yaml b/plugins/hls-core-plugin/test/testdata/multi-unit/hie.yaml new file mode 100644 index 0000000000..34858b5f64 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi-unit/hie.yaml @@ -0,0 +1,6 @@ +cradle: + direct: + arguments: ["-unit" ,"@a-1.0.0-inplace" + ,"-unit" ,"@b-1.0.0-inplace" + ,"-unit" ,"@c-1.0.0-inplace" + ] diff --git a/plugins/hls-core-plugin/test/testdata/multi/a/A.hs b/plugins/hls-core-plugin/test/testdata/multi/a/A.hs new file mode 100644 index 0000000000..faf037ca84 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/a/A.hs @@ -0,0 +1,3 @@ +module A(foo) where +import Control.Concurrent.Async +foo = () diff --git a/plugins/hls-core-plugin/test/testdata/multi/a/a.cabal b/plugins/hls-core-plugin/test/testdata/multi/a/a.cabal new file mode 100644 index 0000000000..d95697264d --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/a/a.cabal @@ -0,0 +1,9 @@ +name: a +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, async >= 2.0 + exposed-modules: A + hs-source-dirs: . diff --git a/plugins/hls-core-plugin/test/testdata/multi/b/B.hs b/plugins/hls-core-plugin/test/testdata/multi/b/B.hs new file mode 100644 index 0000000000..2c6d4b28a2 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/b/B.hs @@ -0,0 +1,3 @@ +module B(module B) where +import A +qux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi/b/b.cabal b/plugins/hls-core-plugin/test/testdata/multi/b/b.cabal new file mode 100644 index 0000000000..e23f5177d8 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/b/b.cabal @@ -0,0 +1,9 @@ +name: b +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: B + hs-source-dirs: . diff --git a/plugins/hls-core-plugin/test/testdata/multi/c/C.hs b/plugins/hls-core-plugin/test/testdata/multi/c/C.hs new file mode 100644 index 0000000000..b75a7fc3c7 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/c/C.hs @@ -0,0 +1,3 @@ +module C(module C) where +import A +cux = foo diff --git a/plugins/hls-core-plugin/test/testdata/multi/c/c.cabal b/plugins/hls-core-plugin/test/testdata/multi/c/c.cabal new file mode 100644 index 0000000000..93ee004d94 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/c/c.cabal @@ -0,0 +1,9 @@ +name: c +version: 1.0.0 +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: base, a + exposed-modules: C + hs-source-dirs: . diff --git a/plugins/hls-core-plugin/test/testdata/multi/cabal.project b/plugins/hls-core-plugin/test/testdata/multi/cabal.project new file mode 100644 index 0000000000..317a89138e --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/cabal.project @@ -0,0 +1,3 @@ +packages: a b c + +allow-newer: base diff --git a/plugins/hls-core-plugin/test/testdata/multi/hie.yaml b/plugins/hls-core-plugin/test/testdata/multi/hie.yaml new file mode 100644 index 0000000000..c6b36d012c --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/multi/hie.yaml @@ -0,0 +1,8 @@ +cradle: + cabal: + - path: "./a" + component: "lib:a" + - path: "./b" + component: "lib:b" + - path: "./c" + component: "lib:c" diff --git a/plugins/hls-core-plugin/test/testdata/references/Main.hs b/plugins/hls-core-plugin/test/testdata/references/Main.hs new file mode 100644 index 0000000000..4a976f3fd0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/Main.hs @@ -0,0 +1,14 @@ +module Main where + +import References + +main :: IO () +main = return () + + + +a = 2 :: Int +b = a + 1 + +acc :: Account +acc = Savings diff --git a/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs b/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs new file mode 100644 index 0000000000..4840f46d8e --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/OtherModule.hs @@ -0,0 +1,9 @@ +module OtherModule (symbolDefinedInOtherModule, symbolDefinedInOtherOtherModule) where + +import OtherOtherModule + +symbolDefinedInOtherModule = 1 + +symbolLocalToOtherModule = 2 + +someFxn x = x + symbolLocalToOtherModule diff --git a/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs b/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs new file mode 100644 index 0000000000..d567b8cb97 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/OtherOtherModule.hs @@ -0,0 +1,3 @@ +module OtherOtherModule where + +symbolDefinedInOtherOtherModule = "asdf" diff --git a/plugins/hls-core-plugin/test/testdata/references/References.hs b/plugins/hls-core-plugin/test/testdata/references/References.hs new file mode 100644 index 0000000000..ac76b4de40 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/References.hs @@ -0,0 +1,25 @@ +module References where + +import OtherModule + +foo = bar + +bar = let x = bar 42 in const "hello" + +baz = do + x <- bar 23 + return $ bar 14 + +data Account = + Checking + | Savings + +bobsAccount = Checking + +bobHasChecking = case bobsAccount of + Checking -> True + Savings -> False + +x = symbolDefinedInOtherModule + +y = symbolDefinedInOtherOtherModule diff --git a/plugins/hls-core-plugin/test/testdata/references/hie.yaml b/plugins/hls-core-plugin/test/testdata/references/hie.yaml new file mode 100644 index 0000000000..db42bad0c0 --- /dev/null +++ b/plugins/hls-core-plugin/test/testdata/references/hie.yaml @@ -0,0 +1 @@ +cradle: {direct: {arguments: ["Main","OtherModule","OtherOtherModule","References"]}} diff --git a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs index e8a21396ee..66d9da3dd5 100644 --- a/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs +++ b/plugins/hls-semantic-tokens-plugin/test/SemanticTokensTest.hs @@ -37,8 +37,8 @@ import System.FilePath import Test.Hls (HasCallStack, PluginTestDescriptor, SMethod (SMethod_TextDocumentSemanticTokensFullDelta), - TestName, TestTree, - changeDoc, + TestName, TestRunner, + TestTree, changeDoc, defaultTestRunner, documentContents, fullCaps, goldenGitDiff, @@ -72,14 +72,14 @@ semanticTokensPlugin = Test.Hls.mkPluginTestDescriptor enabledSemanticDescriptor } } -goldenWithHaskellAndCapsOutPut :: Pretty b => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree +goldenWithHaskellAndCapsOutPut :: (Pretty b) => Config -> PluginTestDescriptor b -> TestName -> FS.VirtualFileTree -> FilePath -> String -> (TextDocumentIdentifier -> Session String) -> TestTree goldenWithHaskellAndCapsOutPut config plugin title tree path desc act = goldenGitDiff title (FS.vftOriginalRoot tree path <.> desc) $ - runSessionWithServerInTmpDir config plugin tree $ - fromString <$> do + fromString <$> (runSessionWithServerInTmpDir config plugin tree $ + do doc <- openDoc (path <.> "hs") "haskell" void waitForBuildQueue - act doc + act doc) goldenWithSemanticTokensWithDefaultConfig :: TestName -> FilePath -> TestTree goldenWithSemanticTokensWithDefaultConfig title path = diff --git a/src/HlsPlugins.hs b/src/HlsPlugins.hs index 1f5d091dc5..4e10e4b501 100644 --- a/src/HlsPlugins.hs +++ b/src/HlsPlugins.hs @@ -130,6 +130,7 @@ import qualified Development.IDE.Plugin.CodeAction as Refactor #if hls_semanticTokens import qualified Ide.Plugin.SemanticTokens as SemanticTokens #endif +import qualified Ide.Plugin.Core as Core data Log = forall a. (Pretty a) => Log PluginId a @@ -150,6 +151,7 @@ idePlugins recorder = pluginDescToIdePlugins allPlugins pluginRecorder :: forall log. (Pretty log) => PluginId -> Recorder (WithPriority log) pluginRecorder pluginId = cmapWithPrio (Log pluginId) recorder allPlugins = + let pId = "core" in Core.descriptor (pluginRecorder pId) pId: #if hls_cabal let pId = "cabal" in Cabal.descriptor (pluginRecorder pId) pId : #endif